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