{-# 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


-- | Cookie settings
data CookieSettings
    = CookieSettings
    { CookieSettings -> CookieEOL
cs_EOL :: CookieEOL
        -- ^ cookie expiration setting, see 'CookieEOL'
    , CookieSettings -> Maybe ByteString
cs_path :: Maybe BS.ByteString
        -- ^ a path for the cookie
    , CookieSettings -> Maybe ByteString
cs_domain :: Maybe BS.ByteString
        -- ^ a domain for the cookie. 'Nothing' means no domain is set
    , CookieSettings -> Bool
cs_HTTPOnly :: Bool
        -- ^ whether the cookie should be set as HttpOnly
    , CookieSettings -> Bool
cs_secure :: Bool
        -- ^ whether the cookie should be marked secure (sent over HTTPS only)
    }

-- | Setting cookie expiration
data CookieEOL
    = CookieValidUntil UTCTime
    -- ^ a point in time in UTC until the cookie is valid
    | CookieValidFor NominalDiffTime
    -- ^ a period (in seconds) for which the cookie is valid
    | CookieValidForSession
    -- ^ the cookie expires with the browser session
    | CookieValidForever
    -- ^ the cookie will have an expiration date in the far future

-- | Default cookie settings, equals
--
-- > CookieSettings
-- >   { cs_EOL      = CookieValidForSession
-- >   , cs_HTTPOnly = False
-- >   , cs_secure   = False
-- >   , cs_domain   = Nothing
-- >   , cs_path     = Just "/"
-- >   }
--
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
generateCookieHeaderString :: Text -> Text -> CookieSettings -> UTCTime -> ByteString
generateCookieHeaderString Text
name Text
value CookieSettings
cs UTCTime
now =
     let farFuture :: UTCTime
farFuture =
             -- don't forget to bump this ...
             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