{-# 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 ByteString
s
  | ByteString -> Bool
S.null ByteString
s = []
  | Bool
otherwise =
    let (ByteString
x, ByteString
y) = Word8 -> ByteString -> (ByteString, ByteString)
breakDiscard Word8
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 ByteString
s =
    let (ByteString
key, ByteString
value) = Word8 -> ByteString -> (ByteString, ByteString)
breakDiscard Word8
61 ByteString
s -- equals sign
        key' :: ByteString
key' = (Word8 -> Bool) -> ByteString -> ByteString
S.dropWhile (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
32) ByteString
key -- space
     in (ByteString
key', ByteString
value)

breakDiscard :: Word8 -> S.ByteString -> (S.ByteString, S.ByteString)
breakDiscard :: Word8 -> ByteString -> (ByteString, ByteString)
breakDiscard Word8
w ByteString
s =
    let (ByteString
x, 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 Int
1 ByteString
y)

type CookieBuilder = (Builder, Builder)

renderCookiesBuilder :: [CookieBuilder] -> Builder
renderCookiesBuilder :: [CookieBuilder] -> Builder
renderCookiesBuilder [] = Builder
forall a. Monoid a => a
mempty
renderCookiesBuilder [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 Builder
x Builder
y = Builder
x Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Char -> Builder
char8 Char
';' Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Builder
y

renderCookie :: CookieBuilder -> Builder
renderCookie :: CookieBuilder -> Builder
renderCookie (Builder
k, Builder
v) = Builder
k Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Char -> Builder
char8 Char
'=' 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 SameSiteOption
x = SameSiteOption
x SameSiteOption -> () -> ()
`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 ByteString
a ByteString
b Maybe ByteString
c Maybe UTCTime
d Maybe DiffTime
e Maybe ByteString
f Bool
g Bool
h Maybe SameSiteOption
i) =
        ByteString
a ByteString -> () -> ()
`seq`
        ByteString
b ByteString -> () -> ()
`seq`
        Maybe ByteString -> ()
forall a. Maybe a -> ()
rnfMBS Maybe ByteString
c () -> () -> ()
`seq`
        Maybe UTCTime -> ()
forall a. NFData a => a -> ()
rnf Maybe UTCTime
d () -> () -> ()
`seq`
        Maybe DiffTime -> ()
forall a. NFData a => a -> ()
rnf Maybe DiffTime
e () -> () -> ()
`seq`
        Maybe ByteString -> ()
forall a. Maybe a -> ()
rnfMBS Maybe ByteString
f () -> () -> ()
`seq`
        Bool -> ()
forall a. NFData a => a -> ()
rnf Bool
g () -> () -> ()
`seq`
        Bool -> ()
forall a. NFData a => a -> ()
rnf Bool
h () -> () -> ()
`seq`
        Maybe SameSiteOption -> ()
forall a. NFData a => a -> ()
rnf Maybe SameSiteOption
i
      where
        -- For backwards compatibility
        rnfMBS :: Maybe a -> ()
rnfMBS Maybe a
Nothing = ()
        rnfMBS (Just a
bs) = a
bs a -> () -> ()
`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     = ByteString
"name"
    , setCookieValue :: ByteString
setCookieValue    = ByteString
"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 SetCookie
sc = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
    [ ByteString -> Builder
byteString (SetCookie -> ByteString
setCookieName SetCookie
sc)
    , Char -> Builder
char8 Char
'='
    , ByteString -> Builder
byteString (SetCookie -> ByteString
setCookieValue SetCookie
sc)
    , case SetCookie -> Maybe ByteString
setCookiePath SetCookie
sc of
        Maybe ByteString
Nothing -> Builder
forall a. Monoid a => a
mempty
        Just ByteString
path -> ByteString -> Builder
byteStringCopy ByteString
"; 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
        Maybe UTCTime
Nothing -> Builder
forall a. Monoid a => a
mempty
        Just UTCTime
e -> ByteString -> Builder
byteStringCopy ByteString
"; 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
        Maybe DiffTime
Nothing -> Builder
forall a. Monoid a => a
mempty
        Just DiffTime
ma -> ByteString -> Builder
byteStringCopyByteString
"; 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
        Maybe ByteString
Nothing -> Builder
forall a. Monoid a => a
mempty
        Just ByteString
d -> ByteString -> Builder
byteStringCopy ByteString
"; 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 ByteString
"; HttpOnly"
        else Builder
forall a. Monoid a => a
mempty
    , if SetCookie -> Bool
setCookieSecure SetCookie
sc
        then ByteString -> Builder
byteStringCopy ByteString
"; Secure"
        else Builder
forall a. Monoid a => a
mempty
    , case SetCookie -> Maybe SameSiteOption
setCookieSameSite SetCookie
sc of
        Maybe SameSiteOption
Nothing -> Builder
forall a. Monoid a => a
mempty
        Just SameSiteOption
Lax -> ByteString -> Builder
byteStringCopy ByteString
"; SameSite=Lax"
        Just SameSiteOption
Strict -> ByteString -> Builder
byteStringCopy ByteString
"; SameSite=Strict"
        Just SameSiteOption
None -> ByteString -> Builder
byteStringCopy ByteString
"; SameSite=None"
    ]

parseSetCookie :: S.ByteString -> SetCookie
parseSetCookie :: ByteString -> SetCookie
parseSetCookie 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 ByteString
"path" [(ByteString, ByteString)]
flags
    , setCookieExpires :: Maybe UTCTime
setCookieExpires =
        ByteString -> [(ByteString, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
"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 ByteString
"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 ByteString
"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 ByteString
"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 ByteString
"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 ByteString
"samesite" [(ByteString, ByteString)]
flags of
        Just ByteString
"Lax" -> SameSiteOption -> Maybe SameSiteOption
forall a. a -> Maybe a
Just SameSiteOption
Lax
        Just ByteString
"Strict" -> SameSiteOption -> Maybe SameSiteOption
forall a. a -> Maybe a
Just SameSiteOption
Strict
        Just ByteString
"None" -> SameSiteOption -> Maybe SameSiteOption
forall a. a -> Maybe a
Just SameSiteOption
None
        Maybe ByteString
_ -> 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 Word8
59 ByteString
a [ByteString] -> [ByteString] -> [ByteString]
forall a. [a] -> [a] -> [a]
++ [ByteString
S8.empty] -- 59 = semicolon
    (ByteString
name, 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 Word8
61 -- equals sign
    dropSpace :: ByteString -> ByteString
dropSpace = (Word8 -> Bool) -> ByteString -> ByteString
S.dropWhile (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
32) -- space

expiresFormat :: String
expiresFormat :: String
expiresFormat = String
"%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 DiffTime
diff)
        | Integer
x Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
70 Bool -> Bool -> Bool
&& Integer
x Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
99 = Integer -> UTCTime
addYear Integer
1900
        | Integer
x Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
0 Bool -> Bool -> Bool
&& Integer
x Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
69 = Integer -> UTCTime
addYear Integer
2000
        | Bool
otherwise = UTCTime
orig
      where
        (Integer
x, Int
y, Int
z) = Day -> (Integer, Int, Int)
toGregorian Day
day
        addYear :: Integer -> UTCTime
addYear 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 = 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 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