{-# 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
{ 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 (UTCTime
farFuture UTCTime -> UTCTime -> NominalDiffTime
`diffUTCTime` UTCTime
now))
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