{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Web.Spock.Internal.Cookies where
import Data.Time
import qualified Data.ByteString as BS
import qualified Data.ByteString.Builder as B
import qualified Data.ByteString.Lazy as BSL
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Web.Cookie as C
import qualified Network.HTTP.Types.URI as URI (urlEncode, urlDecode)
#if MIN_VERSION_base(4,8,0)
#else
import Control.Applicative
#endif
data CookieSettings
= CookieSettings
{ cs_EOL :: CookieEOL
, cs_path :: Maybe BS.ByteString
, cs_domain :: Maybe BS.ByteString
, cs_HTTPOnly :: Bool
, cs_secure :: Bool
}
data CookieEOL
= CookieValidUntil UTCTime
| CookieValidFor NominalDiffTime
| CookieValidForSession
| CookieValidForever
defaultCookieSettings :: CookieSettings
defaultCookieSettings =
CookieSettings
{ cs_EOL = CookieValidForSession
, cs_HTTPOnly = False
, cs_secure = False
, cs_domain = Nothing
, cs_path = Just "/"
}
parseCookies :: BS.ByteString -> [(T.Text, T.Text)]
parseCookies =
map (\(a, b) -> (T.decodeUtf8 a, T.decodeUtf8 $ URI.urlDecode True b)) .
C.parseCookies
generateCookieHeaderString ::
T.Text
-> T.Text
-> CookieSettings
-> UTCTime
-> BS.ByteString
generateCookieHeaderString name value cs now =
let farFuture =
UTCTime (fromGregorian 2030 1 1) 0
(expire, maxAge) =
case cs_EOL cs of
CookieValidUntil t ->
(Just t, Just (t `diffUTCTime` now))
CookieValidFor x ->
(Just (x `addUTCTime` now), Just x)
CookieValidForSession ->
(Nothing, Nothing)
CookieValidForever ->
(Just farFuture, Just (farFuture `diffUTCTime` now))
adjustMaxAge t =
if t < 0 then 0 else t
cookieVal =
C.def
{ C.setCookieName = T.encodeUtf8 name
, C.setCookieValue = URI.urlEncode True $ T.encodeUtf8 value
, C.setCookiePath = cs_path cs
, C.setCookieExpires = expire
, C.setCookieMaxAge = (fromRational . adjustMaxAge . toRational) <$> maxAge
, C.setCookieDomain = cs_domain cs
, C.setCookieHttpOnly = cs_HTTPOnly cs
, C.setCookieSecure = cs_secure cs
}
in renderCookie cookieVal
renderCookie :: C.SetCookie -> BS.ByteString
renderCookie = BSL.toStrict . B.toLazyByteString . C.renderSetCookie