{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Web.Cookie
    ( -- * Server to client
      -- ** Data type
      SetCookie
    , setCookieName
    , setCookieValue
    , setCookiePath
    , setCookieExpires
    , setCookieMaxAge
    , setCookieDomain
    , setCookieHttpOnly
    , setCookieSecure
    , setCookieSameSite
    , setCookiePartitioned
    , SameSiteOption
    , sameSiteLax
    , sameSiteStrict
    , sameSiteNone
      -- ** Functions
    , parseSetCookie
    , renderSetCookie
    , renderSetCookieBS
    , defaultSetCookie
    , def
      -- * Client to server
    , Cookies
    , parseCookies
    , renderCookies
    , renderCookiesBS
      -- ** 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 qualified Data.ByteString.Lazy as L
import Data.Char (toLower, isDigit)
import Data.ByteString.Builder (Builder, byteString, char8, toLazyByteString)
import Data.ByteString.Builder.Extra (byteStringCopy)
#if !(MIN_VERSION_base(4,8,0))
import Data.Monoid (mempty, mappend, mconcat)
#endif
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, fromMaybe, listToMaybe)
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 :: StrictByteString -> CookiesText
parseCookiesText =
    ((StrictByteString, StrictByteString) -> (Text, Text))
-> [(StrictByteString, StrictByteString)] -> CookiesText
forall a b. (a -> b) -> [a] -> [b]
map (StrictByteString -> Text
go (StrictByteString -> Text)
-> (StrictByteString -> Text)
-> (StrictByteString, StrictByteString)
-> (Text, Text)
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** StrictByteString -> Text
go) ([(StrictByteString, StrictByteString)] -> CookiesText)
-> (StrictByteString -> [(StrictByteString, StrictByteString)])
-> StrictByteString
-> CookiesText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrictByteString -> [(StrictByteString, StrictByteString)]
parseCookies
  where
    go :: StrictByteString -> Text
go = OnDecodeError -> StrictByteString -> 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 b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
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)]

semicolon :: Word8
semicolon :: Word8
semicolon = Word8
59

equalsSign :: Word8
equalsSign :: Word8
equalsSign = Word8
61

space :: Word8
space :: Word8
space = Word8
32

doubleQuote :: Word8
doubleQuote :: Word8
doubleQuote = Word8
34

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

parseCookie :: S.ByteString -> (S.ByteString, S.ByteString)
parseCookie :: StrictByteString -> (StrictByteString, StrictByteString)
parseCookie StrictByteString
s =
    let (StrictByteString
key, StrictByteString
value) = Word8 -> StrictByteString -> (StrictByteString, StrictByteString)
breakDiscard Word8
equalsSign StrictByteString
s
        key' :: StrictByteString
key' = (Word8 -> Bool) -> StrictByteString -> StrictByteString
S.dropWhile (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
space) StrictByteString
key
        value' :: StrictByteString
value' = Word8 -> StrictByteString -> StrictByteString
dropEnds Word8
doubleQuote StrictByteString
value
     in (StrictByteString
key', StrictByteString
value')

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

dropEnds :: Word8 -> S.ByteString -> S.ByteString
dropEnds :: Word8 -> StrictByteString -> StrictByteString
dropEnds Word8
w StrictByteString
s =
    case StrictByteString -> Maybe (StrictByteString, Word8)
S.unsnoc StrictByteString
s of
        Just (StrictByteString
s', Word8
w') | Word8
w' Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
w -> case StrictByteString -> Maybe (Word8, StrictByteString)
S.uncons StrictByteString
s' of
            Just (Word8
w'', StrictByteString
s'') | Word8
w'' Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
w -> StrictByteString
s''
            Maybe (Word8, StrictByteString)
_ -> StrictByteString
s
        Maybe (StrictByteString, Word8)
_ -> StrictByteString
s

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 a. (a -> a -> a) -> [a] -> a
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 :: [(StrictByteString, StrictByteString)] -> Builder
renderCookies = [CookieBuilder] -> Builder
renderCookiesBuilder ([CookieBuilder] -> Builder)
-> ([(StrictByteString, StrictByteString)] -> [CookieBuilder])
-> [(StrictByteString, StrictByteString)]
-> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((StrictByteString, StrictByteString) -> CookieBuilder)
-> [(StrictByteString, StrictByteString)] -> [CookieBuilder]
forall a b. (a -> b) -> [a] -> [b]
map (StrictByteString -> Builder
byteString (StrictByteString -> Builder)
-> (StrictByteString -> Builder)
-> (StrictByteString, StrictByteString)
-> CookieBuilder
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** StrictByteString -> Builder
byteString)

-- | @since 0.4.6
renderCookiesBS :: Cookies -> S.ByteString
renderCookiesBS :: [(StrictByteString, StrictByteString)] -> StrictByteString
renderCookiesBS = LazyByteString -> StrictByteString
L.toStrict (LazyByteString -> StrictByteString)
-> ([(StrictByteString, StrictByteString)] -> LazyByteString)
-> [(StrictByteString, StrictByteString)]
-> StrictByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> LazyByteString
toLazyByteString (Builder -> LazyByteString)
-> ([(StrictByteString, StrictByteString)] -> Builder)
-> [(StrictByteString, StrictByteString)]
-> LazyByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(StrictByteString, StrictByteString)] -> Builder
renderCookies

-- | 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 -> StrictByteString
setCookieName :: S.ByteString -- ^ The name of the cookie. Default value: @"name"@
    , SetCookie -> StrictByteString
setCookieValue :: S.ByteString -- ^ The value of the cookie. Default value: @"value"@
    , SetCookie -> Maybe StrictByteString
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 StrictByteString
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@
    , SetCookie -> Bool
setCookiePartitioned :: Bool -- ^ Cookies marked Partitioned are double-keyed: by the origin that sets them and the origin of the top-level page. Default value: @False@
    }
    deriving (SetCookie -> SetCookie -> Bool
(SetCookie -> SetCookie -> Bool)
-> (SetCookie -> SetCookie -> Bool) -> Eq SetCookie
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SetCookie -> SetCookie -> Bool
== :: SetCookie -> SetCookie -> Bool
$c/= :: SetCookie -> SetCookie -> Bool
/= :: 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
$cshowsPrec :: Int -> SetCookie -> ShowS
showsPrec :: Int -> SetCookie -> ShowS
$cshow :: SetCookie -> String
show :: SetCookie -> String
$cshowList :: [SetCookie] -> ShowS
showList :: [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
$cshowsPrec :: Int -> SameSiteOption -> ShowS
showsPrec :: Int -> SameSiteOption -> ShowS
$cshow :: SameSiteOption -> String
show :: SameSiteOption -> String
$cshowList :: [SameSiteOption] -> ShowS
showList :: [SameSiteOption] -> ShowS
Show, SameSiteOption -> SameSiteOption -> Bool
(SameSiteOption -> SameSiteOption -> Bool)
-> (SameSiteOption -> SameSiteOption -> Bool) -> Eq SameSiteOption
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SameSiteOption -> SameSiteOption -> Bool
== :: SameSiteOption -> SameSiteOption -> Bool
$c/= :: SameSiteOption -> SameSiteOption -> Bool
/= :: SameSiteOption -> SameSiteOption -> Bool
Eq)

instance NFData SameSiteOption where
  rnf :: SameSiteOption -> ()
rnf 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 StrictByteString
a StrictByteString
b Maybe StrictByteString
c Maybe UTCTime
d Maybe DiffTime
e Maybe StrictByteString
f Bool
g Bool
h Maybe SameSiteOption
i Bool
j) =
        StrictByteString
a StrictByteString -> () -> ()
forall a b. a -> b -> b
`seq`
        StrictByteString
b StrictByteString -> () -> ()
forall a b. a -> b -> b
`seq`
        Maybe StrictByteString -> ()
forall {a}. Maybe a -> ()
rnfMBS Maybe StrictByteString
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 StrictByteString -> ()
forall {a}. Maybe a -> ()
rnfMBS Maybe StrictByteString
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 () -> () -> ()
forall a b. a -> b -> b
`seq`
        Bool -> ()
forall a. NFData a => a -> ()
rnf Bool
j
      where
        -- For backwards compatibility
        rnfMBS :: Maybe a -> ()
rnfMBS Maybe a
Nothing = ()
        rnfMBS (Just a
bs) = a
bs a -> () -> ()
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
    { setCookieName :: StrictByteString
setCookieName     = StrictByteString
"name"
    , setCookieValue :: StrictByteString
setCookieValue    = StrictByteString
"value"
    , setCookiePath :: Maybe StrictByteString
setCookiePath     = Maybe StrictByteString
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 StrictByteString
setCookieDomain   = Maybe StrictByteString
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
    , setCookiePartitioned :: Bool
setCookiePartitioned = Bool
False
    }

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

-- | @since 0.4.6
renderSetCookieBS :: SetCookie -> S.ByteString
renderSetCookieBS :: SetCookie -> StrictByteString
renderSetCookieBS = LazyByteString -> StrictByteString
L.toStrict (LazyByteString -> StrictByteString)
-> (SetCookie -> LazyByteString) -> SetCookie -> StrictByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> LazyByteString
toLazyByteString (Builder -> LazyByteString)
-> (SetCookie -> Builder) -> SetCookie -> LazyByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SetCookie -> Builder
renderSetCookie

parseSetCookie :: S.ByteString -> SetCookie
parseSetCookie :: StrictByteString -> SetCookie
parseSetCookie StrictByteString
a = SetCookie
    { setCookieName :: StrictByteString
setCookieName = StrictByteString
name
    , setCookieValue :: StrictByteString
setCookieValue = Word8 -> StrictByteString -> StrictByteString
dropEnds Word8
doubleQuote StrictByteString
value
    , setCookiePath :: Maybe StrictByteString
setCookiePath = StrictByteString
-> [(StrictByteString, StrictByteString)] -> Maybe StrictByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup StrictByteString
"path" [(StrictByteString, StrictByteString)]
flags
    , setCookieExpires :: Maybe UTCTime
setCookieExpires =
        StrictByteString
-> [(StrictByteString, StrictByteString)] -> Maybe StrictByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup StrictByteString
"expires" [(StrictByteString, StrictByteString)]
flags Maybe StrictByteString
-> (StrictByteString -> Maybe UTCTime) -> Maybe UTCTime
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= StrictByteString -> Maybe UTCTime
parseCookieExpires
    , setCookieMaxAge :: Maybe DiffTime
setCookieMaxAge =
        StrictByteString
-> [(StrictByteString, StrictByteString)] -> Maybe StrictByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup StrictByteString
"max-age" [(StrictByteString, StrictByteString)]
flags Maybe StrictByteString
-> (StrictByteString -> Maybe DiffTime) -> Maybe DiffTime
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= StrictByteString -> Maybe DiffTime
parseCookieMaxAge
    , setCookieDomain :: Maybe StrictByteString
setCookieDomain = StrictByteString
-> [(StrictByteString, StrictByteString)] -> Maybe StrictByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup StrictByteString
"domain" [(StrictByteString, StrictByteString)]
flags
    , setCookieHttpOnly :: Bool
setCookieHttpOnly = Maybe StrictByteString -> Bool
forall a. Maybe a -> Bool
isJust (Maybe StrictByteString -> Bool) -> Maybe StrictByteString -> Bool
forall a b. (a -> b) -> a -> b
$ StrictByteString
-> [(StrictByteString, StrictByteString)] -> Maybe StrictByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup StrictByteString
"httponly" [(StrictByteString, StrictByteString)]
flags
    , setCookieSecure :: Bool
setCookieSecure = Maybe StrictByteString -> Bool
forall a. Maybe a -> Bool
isJust (Maybe StrictByteString -> Bool) -> Maybe StrictByteString -> Bool
forall a b. (a -> b) -> a -> b
$ StrictByteString
-> [(StrictByteString, StrictByteString)] -> Maybe StrictByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup StrictByteString
"secure" [(StrictByteString, StrictByteString)]
flags
    , setCookieSameSite :: Maybe SameSiteOption
setCookieSameSite = case StrictByteString
-> [(StrictByteString, StrictByteString)] -> Maybe StrictByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup StrictByteString
"samesite" [(StrictByteString, StrictByteString)]
flags of
        Just StrictByteString
"Lax" -> SameSiteOption -> Maybe SameSiteOption
forall a. a -> Maybe a
Just SameSiteOption
Lax
        Just StrictByteString
"Strict" -> SameSiteOption -> Maybe SameSiteOption
forall a. a -> Maybe a
Just SameSiteOption
Strict
        Just StrictByteString
"None" -> SameSiteOption -> Maybe SameSiteOption
forall a. a -> Maybe a
Just SameSiteOption
None
        Maybe StrictByteString
_ -> Maybe SameSiteOption
forall a. Maybe a
Nothing
    , setCookiePartitioned :: Bool
setCookiePartitioned = Maybe StrictByteString -> Bool
forall a. Maybe a -> Bool
isJust (Maybe StrictByteString -> Bool) -> Maybe StrictByteString -> Bool
forall a b. (a -> b) -> a -> b
$ StrictByteString
-> [(StrictByteString, StrictByteString)] -> Maybe StrictByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup StrictByteString
"partitioned" [(StrictByteString, StrictByteString)]
flags
    }
  where
    pairs :: [(StrictByteString, StrictByteString)]
pairs = (StrictByteString -> (StrictByteString, StrictByteString))
-> [StrictByteString] -> [(StrictByteString, StrictByteString)]
forall a b. (a -> b) -> [a] -> [b]
map (StrictByteString -> (StrictByteString, StrictByteString)
parsePair (StrictByteString -> (StrictByteString, StrictByteString))
-> (StrictByteString -> StrictByteString)
-> StrictByteString
-> (StrictByteString, StrictByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrictByteString -> StrictByteString
dropSpace) ([StrictByteString] -> [(StrictByteString, StrictByteString)])
-> [StrictByteString] -> [(StrictByteString, StrictByteString)]
forall a b. (a -> b) -> a -> b
$ Word8 -> StrictByteString -> [StrictByteString]
S.split Word8
semicolon StrictByteString
a
    (StrictByteString
name, StrictByteString
value) = (StrictByteString, StrictByteString)
-> Maybe (StrictByteString, StrictByteString)
-> (StrictByteString, StrictByteString)
forall a. a -> Maybe a -> a
fromMaybe (StrictByteString, StrictByteString)
forall a. Monoid a => a
mempty (Maybe (StrictByteString, StrictByteString)
 -> (StrictByteString, StrictByteString))
-> Maybe (StrictByteString, StrictByteString)
-> (StrictByteString, StrictByteString)
forall a b. (a -> b) -> a -> b
$ [(StrictByteString, StrictByteString)]
-> Maybe (StrictByteString, StrictByteString)
forall a. [a] -> Maybe a
listToMaybe [(StrictByteString, StrictByteString)]
pairs
    flags :: [(StrictByteString, StrictByteString)]
flags = ((StrictByteString, StrictByteString)
 -> (StrictByteString, StrictByteString))
-> [(StrictByteString, StrictByteString)]
-> [(StrictByteString, StrictByteString)]
forall a b. (a -> b) -> [a] -> [b]
map ((StrictByteString -> StrictByteString)
-> (StrictByteString, StrictByteString)
-> (StrictByteString, StrictByteString)
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((Char -> Char) -> StrictByteString -> StrictByteString
S8.map Char -> Char
toLower)) ([(StrictByteString, StrictByteString)]
 -> [(StrictByteString, StrictByteString)])
-> [(StrictByteString, StrictByteString)]
-> [(StrictByteString, StrictByteString)]
forall a b. (a -> b) -> a -> b
$ Int
-> [(StrictByteString, StrictByteString)]
-> [(StrictByteString, StrictByteString)]
forall a. Int -> [a] -> [a]
drop Int
1 [(StrictByteString, StrictByteString)]
pairs
    parsePair :: StrictByteString -> (StrictByteString, StrictByteString)
parsePair = Word8 -> StrictByteString -> (StrictByteString, StrictByteString)
breakDiscard Word8
equalsSign
    dropSpace :: StrictByteString -> StrictByteString
dropSpace = (Word8 -> Bool) -> StrictByteString -> StrictByteString
S.dropWhile (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
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 -> StrictByteString
formatCookieExpires =
    String -> StrictByteString
S8.pack (String -> StrictByteString)
-> (UTCTime -> String) -> UTCTime -> StrictByteString
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 :: StrictByteString -> Maybe UTCTime
parseCookieExpires =
    (UTCTime -> UTCTime) -> Maybe UTCTime -> Maybe UTCTime
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UTCTime -> UTCTime
fuzzYear (Maybe UTCTime -> Maybe UTCTime)
-> (StrictByteString -> Maybe UTCTime)
-> StrictByteString
-> 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)
-> (StrictByteString -> String)
-> StrictByteString
-> Maybe UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrictByteString -> 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 -> StrictByteString
formatCookieMaxAge DiffTime
difftime = String -> StrictByteString
S8.pack (String -> StrictByteString) -> String -> StrictByteString
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 :: StrictByteString -> Maybe DiffTime
parseCookieMaxAge StrictByteString
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 = StrictByteString -> String
S8.unpack StrictByteString
bs