{-# LANGUAGE OverloadedStrings #-}
module Web.Cookie
    ( -- * Server to client
      -- ** Data type
      SetCookie
    , setCookieName
    , setCookieValue
    , setCookiePath
    , setCookieExpires
    , setCookieMaxAge
    , setCookieDomain
    , setCookieHttpOnly
    , setCookieSecure
    , setCookieSameSite
    , SameSiteOption
    , sameSiteLax
    , sameSiteStrict
    , sameSiteNone
      -- ** Functions
    , parseSetCookie
    , renderSetCookie
    , defaultSetCookie
    , def
      -- * Client to server
    , Cookies
    , parseCookies
    , renderCookies
      -- ** UTF8 Version
    , CookiesText
    , parseCookiesText
    , renderCookiesText
      -- * Expires field
    , expiresFormat
    , formatCookieExpires
    , parseCookieExpires
    ) where

import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import Data.Char (toLower, isDigit)
import Data.ByteString.Builder (Builder, byteString, char8)
import Data.ByteString.Builder.Extra (byteStringCopy)
import Data.Monoid (mempty, mappend, mconcat)
import Data.Word (Word8)
import Data.Ratio (numerator, denominator)
import Data.Time (UTCTime (UTCTime), toGregorian, fromGregorian, formatTime, parseTimeM, defaultTimeLocale)
import Data.Time.Clock (DiffTime, secondsToDiffTime)
import Control.Arrow (first, (***))
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8Builder, decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
import Data.Maybe (isJust)
import Data.Default.Class (Default (def))
import Control.DeepSeq (NFData (rnf))

-- | Textual cookies. Functions assume UTF8 encoding.
type CookiesText = [(Text, Text)]

parseCookiesText :: S.ByteString -> CookiesText
parseCookiesText :: ByteString -> CookiesText
parseCookiesText =
    ((ByteString, ByteString) -> (Text, Text))
-> [(ByteString, ByteString)] -> CookiesText
forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> Text
go (ByteString -> Text)
-> (ByteString -> Text) -> (ByteString, ByteString) -> (Text, Text)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** ByteString -> Text
go) ([(ByteString, ByteString)] -> CookiesText)
-> (ByteString -> [(ByteString, ByteString)])
-> ByteString
-> CookiesText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [(ByteString, ByteString)]
parseCookies
  where
    go :: ByteString -> Text
go = OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode

renderCookiesText :: CookiesText -> Builder
renderCookiesText :: CookiesText -> Builder
renderCookiesText = [CookieBuilder] -> Builder
renderCookiesBuilder ([CookieBuilder] -> Builder)
-> (CookiesText -> [CookieBuilder]) -> CookiesText -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, Text) -> CookieBuilder) -> CookiesText -> [CookieBuilder]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Builder
encodeUtf8Builder (Text -> Builder)
-> (Text -> Builder) -> (Text, Text) -> CookieBuilder
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** Text -> Builder
encodeUtf8Builder)

type Cookies = [(S.ByteString, S.ByteString)]

-- | Decode the value of a \"Cookie\" request header into key/value pairs.
parseCookies :: S.ByteString -> Cookies
parseCookies :: ByteString -> [(ByteString, ByteString)]
parseCookies s :: ByteString
s
  | ByteString -> Bool
S.null ByteString
s = []
  | Bool
otherwise =
    let (x :: ByteString
x, y :: ByteString
y) = Word8 -> ByteString -> (ByteString, ByteString)
breakDiscard 59 ByteString
s -- semicolon
     in ByteString -> (ByteString, ByteString)
parseCookie ByteString
x (ByteString, ByteString)
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. a -> [a] -> [a]
: ByteString -> [(ByteString, ByteString)]
parseCookies ByteString
y

parseCookie :: S.ByteString -> (S.ByteString, S.ByteString)
parseCookie :: ByteString -> (ByteString, ByteString)
parseCookie s :: ByteString
s =
    let (key :: ByteString
key, value :: ByteString
value) = Word8 -> ByteString -> (ByteString, ByteString)
breakDiscard 61 ByteString
s -- equals sign
        key' :: ByteString
key' = (Word8 -> Bool) -> ByteString -> ByteString
S.dropWhile (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== 32) ByteString
key -- space
     in (ByteString
key', ByteString
value)

breakDiscard :: Word8 -> S.ByteString -> (S.ByteString, S.ByteString)
breakDiscard :: Word8 -> ByteString -> (ByteString, ByteString)
breakDiscard w :: Word8
w s :: ByteString
s =
    let (x :: ByteString
x, y :: ByteString
y) = (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
S.break (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
w) ByteString
s
     in (ByteString
x, Int -> ByteString -> ByteString
S.drop 1 ByteString
y)

type CookieBuilder = (Builder, Builder)

renderCookiesBuilder :: [CookieBuilder] -> Builder
renderCookiesBuilder :: [CookieBuilder] -> Builder
renderCookiesBuilder [] = Builder
forall a. Monoid a => a
mempty
renderCookiesBuilder cs :: [CookieBuilder]
cs =
    (Builder -> Builder -> Builder) -> [Builder] -> Builder
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Builder -> Builder -> Builder
go ([Builder] -> Builder) -> [Builder] -> Builder
forall a b. (a -> b) -> a -> b
$ (CookieBuilder -> Builder) -> [CookieBuilder] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map CookieBuilder -> Builder
renderCookie [CookieBuilder]
cs
  where
    go :: Builder -> Builder -> Builder
go x :: Builder
x y :: Builder
y = Builder
x Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Char -> Builder
char8 ';' Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Builder
y

renderCookie :: CookieBuilder -> Builder
renderCookie :: CookieBuilder -> Builder
renderCookie (k :: Builder
k, v :: Builder
v) = Builder
k Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Char -> Builder
char8 '=' Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Builder
v

renderCookies :: Cookies -> Builder
renderCookies :: [(ByteString, ByteString)] -> Builder
renderCookies = [CookieBuilder] -> Builder
renderCookiesBuilder ([CookieBuilder] -> Builder)
-> ([(ByteString, ByteString)] -> [CookieBuilder])
-> [(ByteString, ByteString)]
-> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ByteString, ByteString) -> CookieBuilder)
-> [(ByteString, ByteString)] -> [CookieBuilder]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> Builder
byteString (ByteString -> Builder)
-> (ByteString -> Builder)
-> (ByteString, ByteString)
-> CookieBuilder
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** ByteString -> Builder
byteString)

-- | Data type representing the key-value pair to use for a cookie, as well as configuration options for it.
--
-- ==== Creating a SetCookie
--
-- 'SetCookie' does not export a constructor; instead, use 'defaultSetCookie' and override values (see <http://www.yesodweb.com/book/settings-types> for details):
--
-- @
-- import Web.Cookie
-- :set -XOverloadedStrings
-- let cookie = 'defaultSetCookie' { 'setCookieName' = "cookieName", 'setCookieValue' = "cookieValue" }
-- @
--
-- ==== Cookie Configuration
--
-- Cookies have several configuration options; a brief summary of each option is given below. For more information, see <http://tools.ietf.org/html/rfc6265#section-4.1.2 RFC 6265> or <https://en.wikipedia.org/wiki/HTTP_cookie#Cookie_attributes Wikipedia>.
data SetCookie = SetCookie
    { SetCookie -> ByteString
setCookieName :: S.ByteString -- ^ The name of the cookie. Default value: @"name"@
    , SetCookie -> ByteString
setCookieValue :: S.ByteString -- ^ The value of the cookie. Default value: @"value"@
    , SetCookie -> Maybe ByteString
setCookiePath :: Maybe S.ByteString -- ^ The URL path for which the cookie should be sent. Default value: @Nothing@ (The browser defaults to the path of the request that sets the cookie).
    , SetCookie -> Maybe UTCTime
setCookieExpires :: Maybe UTCTime -- ^ The time at which to expire the cookie. Default value: @Nothing@ (The browser will default to expiring a cookie when the browser is closed).
    , SetCookie -> Maybe DiffTime
setCookieMaxAge :: Maybe DiffTime -- ^ The maximum time to keep the cookie, in seconds. Default value: @Nothing@ (The browser defaults to expiring a cookie when the browser is closed).
    , SetCookie -> Maybe ByteString
setCookieDomain :: Maybe S.ByteString -- ^ The domain for which the cookie should be sent. Default value: @Nothing@ (The browser defaults to the current domain).
    , SetCookie -> Bool
setCookieHttpOnly :: Bool -- ^ Marks the cookie as "HTTP only", i.e. not accessible from Javascript. Default value: @False@
    , SetCookie -> Bool
setCookieSecure :: Bool -- ^ Instructs the browser to only send the cookie over HTTPS. Default value: @False@
    , SetCookie -> Maybe SameSiteOption
setCookieSameSite :: Maybe SameSiteOption -- ^ The "same site" policy of the cookie, i.e. whether it should be sent with cross-site requests. Default value: @Nothing@
    }
    deriving (SetCookie -> SetCookie -> Bool
(SetCookie -> SetCookie -> Bool)
-> (SetCookie -> SetCookie -> Bool) -> Eq SetCookie
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SetCookie -> SetCookie -> Bool
$c/= :: SetCookie -> SetCookie -> Bool
== :: SetCookie -> SetCookie -> Bool
$c== :: SetCookie -> SetCookie -> Bool
Eq, Int -> SetCookie -> ShowS
[SetCookie] -> ShowS
SetCookie -> String
(Int -> SetCookie -> ShowS)
-> (SetCookie -> String)
-> ([SetCookie] -> ShowS)
-> Show SetCookie
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SetCookie] -> ShowS
$cshowList :: [SetCookie] -> ShowS
show :: SetCookie -> String
$cshow :: SetCookie -> String
showsPrec :: Int -> SetCookie -> ShowS
$cshowsPrec :: Int -> SetCookie -> ShowS
Show)

-- | Data type representing the options for a <https://tools.ietf.org/html/draft-west-first-party-cookies-07#section-4.1 SameSite cookie>
data SameSiteOption = Lax
                    | Strict
                    | None
                    deriving (Int -> SameSiteOption -> ShowS
[SameSiteOption] -> ShowS
SameSiteOption -> String
(Int -> SameSiteOption -> ShowS)
-> (SameSiteOption -> String)
-> ([SameSiteOption] -> ShowS)
-> Show SameSiteOption
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SameSiteOption] -> ShowS
$cshowList :: [SameSiteOption] -> ShowS
show :: SameSiteOption -> String
$cshow :: SameSiteOption -> String
showsPrec :: Int -> SameSiteOption -> ShowS
$cshowsPrec :: Int -> SameSiteOption -> ShowS
Show, SameSiteOption -> SameSiteOption -> Bool
(SameSiteOption -> SameSiteOption -> Bool)
-> (SameSiteOption -> SameSiteOption -> Bool) -> Eq SameSiteOption
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SameSiteOption -> SameSiteOption -> Bool
$c/= :: SameSiteOption -> SameSiteOption -> Bool
== :: SameSiteOption -> SameSiteOption -> Bool
$c== :: SameSiteOption -> SameSiteOption -> Bool
Eq)

instance NFData SameSiteOption where
  rnf :: SameSiteOption -> ()
rnf x :: SameSiteOption
x = SameSiteOption
x SameSiteOption -> () -> ()
forall a b. a -> b -> b
`seq` ()

-- | Directs the browser to send the cookie for <https://tools.ietf.org/html/rfc7231#section-4.2.1 safe requests> (e.g. @GET@), but not for unsafe ones (e.g. @POST@)
sameSiteLax :: SameSiteOption
sameSiteLax :: SameSiteOption
sameSiteLax = SameSiteOption
Lax

-- | Directs the browser to not send the cookie for /any/ cross-site request, including e.g. a user clicking a link in their email to open a page on your site.
sameSiteStrict :: SameSiteOption
sameSiteStrict :: SameSiteOption
sameSiteStrict = SameSiteOption
Strict

-- |
-- Directs the browser to send the cookie for cross-site requests.
--
-- @since 0.4.5
sameSiteNone :: SameSiteOption
sameSiteNone :: SameSiteOption
sameSiteNone = SameSiteOption
None

instance NFData SetCookie where
    rnf :: SetCookie -> ()
rnf (SetCookie a :: ByteString
a b :: ByteString
b c :: Maybe ByteString
c d :: Maybe UTCTime
d e :: Maybe DiffTime
e f :: Maybe ByteString
f g :: Bool
g h :: Bool
h i :: Maybe SameSiteOption
i) =
        ByteString
a ByteString -> () -> ()
forall a b. a -> b -> b
`seq`
        ByteString
b ByteString -> () -> ()
forall a b. a -> b -> b
`seq`
        Maybe ByteString -> ()
forall t. Maybe t -> ()
rnfMBS Maybe ByteString
c () -> () -> ()
forall a b. a -> b -> b
`seq`
        Maybe UTCTime -> ()
forall a. NFData a => a -> ()
rnf Maybe UTCTime
d () -> () -> ()
forall a b. a -> b -> b
`seq`
        Maybe DiffTime -> ()
forall a. NFData a => a -> ()
rnf Maybe DiffTime
e () -> () -> ()
forall a b. a -> b -> b
`seq`
        Maybe ByteString -> ()
forall t. Maybe t -> ()
rnfMBS Maybe ByteString
f () -> () -> ()
forall a b. a -> b -> b
`seq`
        Bool -> ()
forall a. NFData a => a -> ()
rnf Bool
g () -> () -> ()
forall a b. a -> b -> b
`seq`
        Bool -> ()
forall a. NFData a => a -> ()
rnf Bool
h () -> () -> ()
forall a b. a -> b -> b
`seq`
        Maybe SameSiteOption -> ()
forall a. NFData a => a -> ()
rnf Maybe SameSiteOption
i
      where
        -- For backwards compatibility
        rnfMBS :: Maybe t -> ()
rnfMBS Nothing = ()
        rnfMBS (Just bs :: t
bs) = t
bs t -> () -> ()
forall a b. a -> b -> b
`seq` ()

-- | @'def' = 'defaultSetCookie'@
instance Default SetCookie where
    def :: SetCookie
def = SetCookie
defaultSetCookie

-- | A minimal 'SetCookie'. All fields are 'Nothing' or 'False' except @'setCookieName' = "name"@ and @'setCookieValue' = "value"@. You need this to construct a 'SetCookie', because it does not export a constructor. Equivalently, you may use 'def'.
--
-- @since 0.4.2.2
defaultSetCookie :: SetCookie
defaultSetCookie :: SetCookie
defaultSetCookie = SetCookie :: ByteString
-> ByteString
-> Maybe ByteString
-> Maybe UTCTime
-> Maybe DiffTime
-> Maybe ByteString
-> Bool
-> Bool
-> Maybe SameSiteOption
-> SetCookie
SetCookie
    { setCookieName :: ByteString
setCookieName     = "name"
    , setCookieValue :: ByteString
setCookieValue    = "value"
    , setCookiePath :: Maybe ByteString
setCookiePath     = Maybe ByteString
forall a. Maybe a
Nothing
    , setCookieExpires :: Maybe UTCTime
setCookieExpires  = Maybe UTCTime
forall a. Maybe a
Nothing
    , setCookieMaxAge :: Maybe DiffTime
setCookieMaxAge   = Maybe DiffTime
forall a. Maybe a
Nothing
    , setCookieDomain :: Maybe ByteString
setCookieDomain   = Maybe ByteString
forall a. Maybe a
Nothing
    , setCookieHttpOnly :: Bool
setCookieHttpOnly = Bool
False
    , setCookieSecure :: Bool
setCookieSecure   = Bool
False
    , setCookieSameSite :: Maybe SameSiteOption
setCookieSameSite = Maybe SameSiteOption
forall a. Maybe a
Nothing
    }

renderSetCookie :: SetCookie -> Builder
renderSetCookie :: SetCookie -> Builder
renderSetCookie sc :: SetCookie
sc = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
    [ ByteString -> Builder
byteString (SetCookie -> ByteString
setCookieName SetCookie
sc)
    , Char -> Builder
char8 '='
    , ByteString -> Builder
byteString (SetCookie -> ByteString
setCookieValue SetCookie
sc)
    , case SetCookie -> Maybe ByteString
setCookiePath SetCookie
sc of
        Nothing -> Builder
forall a. Monoid a => a
mempty
        Just path :: ByteString
path -> ByteString -> Builder
byteStringCopy "; Path="
                     Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` ByteString -> Builder
byteString ByteString
path
    , case SetCookie -> Maybe UTCTime
setCookieExpires SetCookie
sc of
        Nothing -> Builder
forall a. Monoid a => a
mempty
        Just e :: UTCTime
e -> ByteString -> Builder
byteStringCopy "; Expires=" Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend`
                  ByteString -> Builder
byteString (UTCTime -> ByteString
formatCookieExpires UTCTime
e)
    , case SetCookie -> Maybe DiffTime
setCookieMaxAge SetCookie
sc of
        Nothing -> Builder
forall a. Monoid a => a
mempty
        Just ma :: DiffTime
ma -> ByteString -> Builder
byteStringCopy"; Max-Age=" Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend`
                   ByteString -> Builder
byteString (DiffTime -> ByteString
formatCookieMaxAge DiffTime
ma)
    , case SetCookie -> Maybe ByteString
setCookieDomain SetCookie
sc of
        Nothing -> Builder
forall a. Monoid a => a
mempty
        Just d :: ByteString
d -> ByteString -> Builder
byteStringCopy "; Domain=" Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend`
                  ByteString -> Builder
byteString ByteString
d
    , if SetCookie -> Bool
setCookieHttpOnly SetCookie
sc
        then ByteString -> Builder
byteStringCopy "; HttpOnly"
        else Builder
forall a. Monoid a => a
mempty
    , if SetCookie -> Bool
setCookieSecure SetCookie
sc
        then ByteString -> Builder
byteStringCopy "; Secure"
        else Builder
forall a. Monoid a => a
mempty
    , case SetCookie -> Maybe SameSiteOption
setCookieSameSite SetCookie
sc of
        Nothing -> Builder
forall a. Monoid a => a
mempty
        Just Lax -> ByteString -> Builder
byteStringCopy "; SameSite=Lax"
        Just Strict -> ByteString -> Builder
byteStringCopy "; SameSite=Strict"
        Just None -> ByteString -> Builder
byteStringCopy "; SameSite=None"
    ]

parseSetCookie :: S.ByteString -> SetCookie
parseSetCookie :: ByteString -> SetCookie
parseSetCookie a :: ByteString
a = SetCookie :: ByteString
-> ByteString
-> Maybe ByteString
-> Maybe UTCTime
-> Maybe DiffTime
-> Maybe ByteString
-> Bool
-> Bool
-> Maybe SameSiteOption
-> SetCookie
SetCookie
    { setCookieName :: ByteString
setCookieName = ByteString
name
    , setCookieValue :: ByteString
setCookieValue = ByteString
value
    , setCookiePath :: Maybe ByteString
setCookiePath = ByteString -> [(ByteString, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup "path" [(ByteString, ByteString)]
flags
    , setCookieExpires :: Maybe UTCTime
setCookieExpires =
        ByteString -> [(ByteString, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup "expires" [(ByteString, ByteString)]
flags Maybe ByteString -> (ByteString -> Maybe UTCTime) -> Maybe UTCTime
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> Maybe UTCTime
parseCookieExpires
    , setCookieMaxAge :: Maybe DiffTime
setCookieMaxAge =
        ByteString -> [(ByteString, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup "max-age" [(ByteString, ByteString)]
flags Maybe ByteString
-> (ByteString -> Maybe DiffTime) -> Maybe DiffTime
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> Maybe DiffTime
parseCookieMaxAge
    , setCookieDomain :: Maybe ByteString
setCookieDomain = ByteString -> [(ByteString, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup "domain" [(ByteString, ByteString)]
flags
    , setCookieHttpOnly :: Bool
setCookieHttpOnly = Maybe ByteString -> Bool
forall a. Maybe a -> Bool
isJust (Maybe ByteString -> Bool) -> Maybe ByteString -> Bool
forall a b. (a -> b) -> a -> b
$ ByteString -> [(ByteString, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup "httponly" [(ByteString, ByteString)]
flags
    , setCookieSecure :: Bool
setCookieSecure = Maybe ByteString -> Bool
forall a. Maybe a -> Bool
isJust (Maybe ByteString -> Bool) -> Maybe ByteString -> Bool
forall a b. (a -> b) -> a -> b
$ ByteString -> [(ByteString, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup "secure" [(ByteString, ByteString)]
flags
    , setCookieSameSite :: Maybe SameSiteOption
setCookieSameSite = case ByteString -> [(ByteString, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup "samesite" [(ByteString, ByteString)]
flags of
        Just "Lax" -> SameSiteOption -> Maybe SameSiteOption
forall a. a -> Maybe a
Just SameSiteOption
Lax
        Just "Strict" -> SameSiteOption -> Maybe SameSiteOption
forall a. a -> Maybe a
Just SameSiteOption
Strict
        Just "None" -> SameSiteOption -> Maybe SameSiteOption
forall a. a -> Maybe a
Just SameSiteOption
None
        _ -> Maybe SameSiteOption
forall a. Maybe a
Nothing
    }
  where
    pairs :: [(ByteString, ByteString)]
pairs = (ByteString -> (ByteString, ByteString))
-> [ByteString] -> [(ByteString, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> (ByteString, ByteString)
parsePair (ByteString -> (ByteString, ByteString))
-> (ByteString -> ByteString)
-> ByteString
-> (ByteString, ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
dropSpace) ([ByteString] -> [(ByteString, ByteString)])
-> [ByteString] -> [(ByteString, ByteString)]
forall a b. (a -> b) -> a -> b
$ Word8 -> ByteString -> [ByteString]
S.split 59 ByteString
a [ByteString] -> [ByteString] -> [ByteString]
forall a. [a] -> [a] -> [a]
++ [ByteString
S8.empty] -- 59 = semicolon
    (name :: ByteString
name, value :: ByteString
value) = [(ByteString, ByteString)] -> (ByteString, ByteString)
forall a. [a] -> a
head [(ByteString, ByteString)]
pairs
    flags :: [(ByteString, ByteString)]
flags = ((ByteString, ByteString) -> (ByteString, ByteString))
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map ((ByteString -> ByteString)
-> (ByteString, ByteString) -> (ByteString, ByteString)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((Char -> Char) -> ByteString -> ByteString
S8.map Char -> Char
toLower)) ([(ByteString, ByteString)] -> [(ByteString, ByteString)])
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a b. (a -> b) -> a -> b
$ [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. [a] -> [a]
tail [(ByteString, ByteString)]
pairs
    parsePair :: ByteString -> (ByteString, ByteString)
parsePair = Word8 -> ByteString -> (ByteString, ByteString)
breakDiscard 61 -- equals sign
    dropSpace :: ByteString -> ByteString
dropSpace = (Word8 -> Bool) -> ByteString -> ByteString
S.dropWhile (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== 32) -- space

expiresFormat :: String
expiresFormat :: String
expiresFormat = "%a, %d-%b-%Y %X GMT"

-- | Format a 'UTCTime' for a cookie.
formatCookieExpires :: UTCTime -> S.ByteString
formatCookieExpires :: UTCTime -> ByteString
formatCookieExpires =
    String -> ByteString
S8.pack (String -> ByteString)
-> (UTCTime -> String) -> UTCTime -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
expiresFormat

parseCookieExpires :: S.ByteString -> Maybe UTCTime
parseCookieExpires :: ByteString -> Maybe UTCTime
parseCookieExpires =
    (UTCTime -> UTCTime) -> Maybe UTCTime -> Maybe UTCTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UTCTime -> UTCTime
fuzzYear (Maybe UTCTime -> Maybe UTCTime)
-> (ByteString -> Maybe UTCTime) -> ByteString -> Maybe UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> TimeLocale -> String -> String -> Maybe UTCTime
forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> String -> String -> m t
parseTimeM Bool
True TimeLocale
defaultTimeLocale String
expiresFormat (String -> Maybe UTCTime)
-> (ByteString -> String) -> ByteString -> Maybe UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
S8.unpack
  where
    -- See: https://github.com/snoyberg/cookie/issues/5
    fuzzYear :: UTCTime -> UTCTime
fuzzYear orig :: UTCTime
orig@(UTCTime day :: Day
day diff :: DiffTime
diff)
        | Integer
x Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= 70 Bool -> Bool -> Bool
&& Integer
x Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= 99 = Integer -> UTCTime
addYear 1900
        | Integer
x Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= 0 Bool -> Bool -> Bool
&& Integer
x Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= 69 = Integer -> UTCTime
addYear 2000
        | Bool
otherwise = UTCTime
orig
      where
        (x :: Integer
x, y :: Int
y, z :: Int
z) = Day -> (Integer, Int, Int)
toGregorian Day
day
        addYear :: Integer -> UTCTime
addYear x' :: Integer
x' = Day -> DiffTime -> UTCTime
UTCTime (Integer -> Int -> Int -> Day
fromGregorian (Integer
x Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
x') Int
y Int
z) DiffTime
diff

-- | Format a 'DiffTime' for a cookie.
formatCookieMaxAge :: DiffTime -> S.ByteString
formatCookieMaxAge :: DiffTime -> ByteString
formatCookieMaxAge difftime :: DiffTime
difftime = String -> ByteString
S8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Integer -> String
forall a. Show a => a -> String
show (Integer
num Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
denom)
  where rational :: Rational
rational = DiffTime -> Rational
forall a. Real a => a -> Rational
toRational DiffTime
difftime
        num :: Integer
num = Rational -> Integer
forall a. Ratio a -> a
numerator Rational
rational
        denom :: Integer
denom = Rational -> Integer
forall a. Ratio a -> a
denominator Rational
rational

parseCookieMaxAge :: S.ByteString -> Maybe DiffTime
parseCookieMaxAge :: ByteString -> Maybe DiffTime
parseCookieMaxAge bs :: ByteString
bs
  | (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isDigit String
unpacked = DiffTime -> Maybe DiffTime
forall a. a -> Maybe a
Just (DiffTime -> Maybe DiffTime) -> DiffTime -> Maybe DiffTime
forall a b. (a -> b) -> a -> b
$ Integer -> DiffTime
secondsToDiffTime (Integer -> DiffTime) -> Integer -> DiffTime
forall a b. (a -> b) -> a -> b
$ String -> Integer
forall a. Read a => String -> a
read String
unpacked
  | Bool
otherwise = Maybe DiffTime
forall a. Maybe a
Nothing
  where unpacked :: String
unpacked = ByteString -> String
S8.unpack ByteString
bs