{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Web.Cookie
(
SetCookie
, setCookieName
, setCookieValue
, setCookiePath
, setCookieExpires
, setCookieMaxAge
, setCookieDomain
, setCookieHttpOnly
, setCookieSecure
, setCookieSameSite
, SameSiteOption
, sameSiteLax
, sameSiteStrict
, sameSiteNone
, parseSetCookie
, renderSetCookie
, renderSetCookieBS
, defaultSetCookie
, def
, Cookies
, parseCookies
, renderCookies
, renderCookiesBS
, CookiesText
, parseCookiesText
, renderCookiesText
, 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)
import Data.Default.Class (Default (def))
import Control.DeepSeq (NFData (rnf))
type CookiesText = [(Text, Text)]
parseCookiesText :: S.ByteString -> CookiesText
parseCookiesText :: ByteString -> CookiesText
parseCookiesText =
forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> Text
go forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** ByteString -> Text
go) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Cookies
parseCookies
where
go :: ByteString -> Text
go = OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode
renderCookiesText :: CookiesText -> Builder
renderCookiesText :: CookiesText -> Builder
renderCookiesText = [CookieBuilder] -> Builder
renderCookiesBuilder forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (Text -> Builder
encodeUtf8Builder 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)]
parseCookies :: S.ByteString -> Cookies
parseCookies :: ByteString -> Cookies
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
in ByteString -> (ByteString, ByteString)
parseCookie ByteString
x forall a. a -> [a] -> [a]
: ByteString -> Cookies
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
key' :: ByteString
key' = (Word8 -> Bool) -> ByteString -> ByteString
S.dropWhile (forall a. Eq a => a -> a -> Bool
== Word8
32) ByteString
key
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 (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 [] = forall a. Monoid a => a
mempty
renderCookiesBuilder [CookieBuilder]
cs =
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Builder -> Builder -> Builder
go forall a b. (a -> b) -> a -> b
$ 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 forall a. Monoid a => a -> a -> a
`mappend` Char -> Builder
char8 Char
';' forall a. Monoid a => a -> a -> a
`mappend` Builder
y
renderCookie :: CookieBuilder -> Builder
renderCookie :: CookieBuilder -> Builder
renderCookie (Builder
k, Builder
v) = Builder
k forall a. Monoid a => a -> a -> a
`mappend` Char -> Builder
char8 Char
'=' forall a. Monoid a => a -> a -> a
`mappend` Builder
v
renderCookies :: Cookies -> Builder
renderCookies :: Cookies -> Builder
renderCookies = [CookieBuilder] -> Builder
renderCookiesBuilder forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> Builder
byteString forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** ByteString -> Builder
byteString)
renderCookiesBS :: Cookies -> S.ByteString
renderCookiesBS :: Cookies -> ByteString
renderCookiesBS = ByteString -> ByteString
L.toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
toLazyByteString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cookies -> Builder
renderCookies
data SetCookie = SetCookie
{ SetCookie -> ByteString
setCookieName :: S.ByteString
, SetCookie -> ByteString
setCookieValue :: S.ByteString
, SetCookie -> Maybe ByteString
setCookiePath :: Maybe S.ByteString
, SetCookie -> Maybe UTCTime
setCookieExpires :: Maybe UTCTime
, SetCookie -> Maybe DiffTime
setCookieMaxAge :: Maybe DiffTime
, SetCookie -> Maybe ByteString
setCookieDomain :: Maybe S.ByteString
, SetCookie -> Bool
setCookieHttpOnly :: Bool
, SetCookie -> Bool
setCookieSecure :: Bool
, SetCookie -> Maybe SameSiteOption
setCookieSameSite :: Maybe SameSiteOption
}
deriving (SetCookie -> SetCookie -> Bool
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
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 SameSiteOption = Lax
| Strict
| None
deriving (Int -> SameSiteOption -> ShowS
[SameSiteOption] -> ShowS
SameSiteOption -> String
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
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 seq :: forall a b. a -> b -> b
`seq` ()
sameSiteLax :: SameSiteOption
sameSiteLax :: SameSiteOption
sameSiteLax = SameSiteOption
Lax
sameSiteStrict :: SameSiteOption
sameSiteStrict :: SameSiteOption
sameSiteStrict = SameSiteOption
Strict
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 seq :: forall a b. a -> b -> b
`seq`
ByteString
b seq :: forall a b. a -> b -> b
`seq`
forall {a}. Maybe a -> ()
rnfMBS Maybe ByteString
c seq :: forall a b. a -> b -> b
`seq`
forall a. NFData a => a -> ()
rnf Maybe UTCTime
d seq :: forall a b. a -> b -> b
`seq`
forall a. NFData a => a -> ()
rnf Maybe DiffTime
e seq :: forall a b. a -> b -> b
`seq`
forall {a}. Maybe a -> ()
rnfMBS Maybe ByteString
f seq :: forall a b. a -> b -> b
`seq`
forall a. NFData a => a -> ()
rnf Bool
g seq :: forall a b. a -> b -> b
`seq`
forall a. NFData a => a -> ()
rnf Bool
h seq :: forall a b. a -> b -> b
`seq`
forall a. NFData a => a -> ()
rnf Maybe SameSiteOption
i
where
rnfMBS :: Maybe a -> ()
rnfMBS Maybe a
Nothing = ()
rnfMBS (Just a
bs) = a
bs seq :: forall a b. a -> b -> b
`seq` ()
instance Default SetCookie where
def :: SetCookie
def = SetCookie
defaultSetCookie
defaultSetCookie :: SetCookie
defaultSetCookie :: SetCookie
defaultSetCookie = SetCookie
{ setCookieName :: ByteString
setCookieName = ByteString
"name"
, setCookieValue :: ByteString
setCookieValue = ByteString
"value"
, setCookiePath :: Maybe ByteString
setCookiePath = forall a. Maybe a
Nothing
, setCookieExpires :: Maybe UTCTime
setCookieExpires = forall a. Maybe a
Nothing
, setCookieMaxAge :: Maybe DiffTime
setCookieMaxAge = forall a. Maybe a
Nothing
, setCookieDomain :: Maybe ByteString
setCookieDomain = forall a. Maybe a
Nothing
, setCookieHttpOnly :: Bool
setCookieHttpOnly = Bool
False
, setCookieSecure :: Bool
setCookieSecure = Bool
False
, setCookieSameSite :: Maybe SameSiteOption
setCookieSameSite = forall a. Maybe a
Nothing
}
renderSetCookie :: SetCookie -> Builder
renderSetCookie :: SetCookie -> Builder
renderSetCookie SetCookie
sc = 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 -> forall a. Monoid a => a
mempty
Just ByteString
path -> ByteString -> Builder
byteStringCopy ByteString
"; Path="
forall a. Monoid a => a -> a -> a
`mappend` ByteString -> Builder
byteString ByteString
path
, case SetCookie -> Maybe UTCTime
setCookieExpires SetCookie
sc of
Maybe UTCTime
Nothing -> forall a. Monoid a => a
mempty
Just UTCTime
e -> ByteString -> Builder
byteStringCopy ByteString
"; Expires=" 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 -> forall a. Monoid a => a
mempty
Just DiffTime
ma -> ByteString -> Builder
byteStringCopyByteString
"; Max-Age=" 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 -> forall a. Monoid a => a
mempty
Just ByteString
d -> ByteString -> Builder
byteStringCopy ByteString
"; Domain=" 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 forall a. Monoid a => a
mempty
, if SetCookie -> Bool
setCookieSecure SetCookie
sc
then ByteString -> Builder
byteStringCopy ByteString
"; Secure"
else forall a. Monoid a => a
mempty
, case SetCookie -> Maybe SameSiteOption
setCookieSameSite SetCookie
sc of
Maybe SameSiteOption
Nothing -> 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"
]
renderSetCookieBS :: SetCookie -> S.ByteString
renderSetCookieBS :: SetCookie -> ByteString
renderSetCookieBS = ByteString -> ByteString
L.toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
toLazyByteString forall b c a. (b -> c) -> (a -> b) -> a -> c
. SetCookie -> Builder
renderSetCookie
parseSetCookie :: S.ByteString -> SetCookie
parseSetCookie :: ByteString -> SetCookie
parseSetCookie ByteString
a = SetCookie
{ setCookieName :: ByteString
setCookieName = ByteString
name
, setCookieValue :: ByteString
setCookieValue = ByteString
value
, setCookiePath :: Maybe ByteString
setCookiePath = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
"path" Cookies
flags
, setCookieExpires :: Maybe UTCTime
setCookieExpires =
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
"expires" Cookies
flags forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> Maybe UTCTime
parseCookieExpires
, setCookieMaxAge :: Maybe DiffTime
setCookieMaxAge =
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
"max-age" Cookies
flags forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> Maybe DiffTime
parseCookieMaxAge
, setCookieDomain :: Maybe ByteString
setCookieDomain = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
"domain" Cookies
flags
, setCookieHttpOnly :: Bool
setCookieHttpOnly = forall a. Maybe a -> Bool
isJust forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
"httponly" Cookies
flags
, setCookieSecure :: Bool
setCookieSecure = forall a. Maybe a -> Bool
isJust forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
"secure" Cookies
flags
, setCookieSameSite :: Maybe SameSiteOption
setCookieSameSite = case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
"samesite" Cookies
flags of
Just ByteString
"Lax" -> forall a. a -> Maybe a
Just SameSiteOption
Lax
Just ByteString
"Strict" -> forall a. a -> Maybe a
Just SameSiteOption
Strict
Just ByteString
"None" -> forall a. a -> Maybe a
Just SameSiteOption
None
Maybe ByteString
_ -> forall a. Maybe a
Nothing
}
where
pairs :: Cookies
pairs = forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> (ByteString, ByteString)
parsePair forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
dropSpace) forall a b. (a -> b) -> a -> b
$ Word8 -> ByteString -> [ByteString]
S.split Word8
59 ByteString
a forall a. [a] -> [a] -> [a]
++ [ByteString
S8.empty]
(ByteString
name, ByteString
value) = forall a. [a] -> a
head Cookies
pairs
flags :: Cookies
flags = forall a b. (a -> b) -> [a] -> [b]
map (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)) forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
tail Cookies
pairs
parsePair :: ByteString -> (ByteString, ByteString)
parsePair = Word8 -> ByteString -> (ByteString, ByteString)
breakDiscard Word8
61
dropSpace :: ByteString -> ByteString
dropSpace = (Word8 -> Bool) -> ByteString -> ByteString
S.dropWhile (forall a. Eq a => a -> a -> Bool
== Word8
32)
expiresFormat :: String
expiresFormat :: String
expiresFormat = String
"%a, %d-%b-%Y %X GMT"
formatCookieExpires :: UTCTime -> S.ByteString
formatCookieExpires :: UTCTime -> ByteString
formatCookieExpires =
String -> ByteString
S8.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
expiresFormat
parseCookieExpires :: S.ByteString -> Maybe UTCTime
parseCookieExpires :: ByteString -> Maybe UTCTime
parseCookieExpires =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UTCTime -> UTCTime
fuzzYear forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> String -> String -> m t
parseTimeM Bool
True TimeLocale
defaultTimeLocale String
expiresFormat forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
S8.unpack
where
fuzzYear :: UTCTime -> UTCTime
fuzzYear orig :: UTCTime
orig@(UTCTime Day
day DiffTime
diff)
| Integer
x forall a. Ord a => a -> a -> Bool
>= Integer
70 Bool -> Bool -> Bool
&& Integer
x forall a. Ord a => a -> a -> Bool
<= Integer
99 = Integer -> UTCTime
addYear Integer
1900
| Integer
x forall a. Ord a => a -> a -> Bool
>= Integer
0 Bool -> Bool -> Bool
&& Integer
x 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 forall a. Num a => a -> a -> a
+ Integer
x') Int
y Int
z) DiffTime
diff
formatCookieMaxAge :: DiffTime -> S.ByteString
formatCookieMaxAge :: DiffTime -> ByteString
formatCookieMaxAge DiffTime
difftime = String -> ByteString
S8.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show (Integer
num forall a. Integral a => a -> a -> a
`div` Integer
denom)
where rational :: Rational
rational = forall a. Real a => a -> Rational
toRational DiffTime
difftime
num :: Integer
num = forall a. Ratio a -> a
numerator Rational
rational
denom :: Integer
denom = forall a. Ratio a -> a
denominator Rational
rational
parseCookieMaxAge :: S.ByteString -> Maybe DiffTime
parseCookieMaxAge :: ByteString -> Maybe DiffTime
parseCookieMaxAge ByteString
bs
| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isDigit String
unpacked = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Integer -> DiffTime
secondsToDiffTime forall a b. (a -> b) -> a -> b
$ forall a. Read a => String -> a
read String
unpacked
| Bool
otherwise = forall a. Maybe a
Nothing
where unpacked :: String
unpacked = ByteString -> String
S8.unpack ByteString
bs