1{-# LANGUAGE OverloadedStrings #-}
2module Web.Cookie
3    ( -- * Server to client
4      -- ** Data type
5      SetCookie
6    , setCookieName
7    , setCookieValue
8    , setCookiePath
9    , setCookieExpires
10    , setCookieMaxAge
11    , setCookieDomain
12    , setCookieHttpOnly
13    , setCookieSecure
14    , setCookieSameSite
15    , SameSiteOption
16    , sameSiteLax
17    , sameSiteStrict
18    , sameSiteNone
19      -- ** Functions
20    , parseSetCookie
21    , renderSetCookie
22    , defaultSetCookie
23    , def
24      -- * Client to server
25    , Cookies
26    , parseCookies
27    , renderCookies
28      -- ** UTF8 Version
29    , CookiesText
30    , parseCookiesText
31    , renderCookiesText
32      -- * Expires field
33    , expiresFormat
34    , formatCookieExpires
35    , parseCookieExpires
36    ) where
37
38import qualified Data.ByteString as S
39import qualified Data.ByteString.Char8 as S8
40import Data.Char (toLower, isDigit)
41import Data.ByteString.Builder (Builder, byteString, char8)
42import Data.ByteString.Builder.Extra (byteStringCopy)
43import Data.Monoid (mempty, mappend, mconcat)
44import Data.Word (Word8)
45import Data.Ratio (numerator, denominator)
46import Data.Time (UTCTime (UTCTime), toGregorian, fromGregorian, formatTime, parseTimeM, defaultTimeLocale)
47import Data.Time.Clock (DiffTime, secondsToDiffTime)
48import Control.Arrow (first, (***))
49import Data.Text (Text)
50import Data.Text.Encoding (encodeUtf8Builder, decodeUtf8With)
51import Data.Text.Encoding.Error (lenientDecode)
52import Data.Maybe (isJust)
53import Data.Default.Class (Default (def))
54import Control.DeepSeq (NFData (rnf))
55
56-- | Textual cookies. Functions assume UTF8 encoding.
57type CookiesText = [(Text, Text)]
58
59parseCookiesText :: S.ByteString -> CookiesText
60parseCookiesText =
61    map (go *** go) . parseCookies
62  where
63    go = decodeUtf8With lenientDecode
64
65renderCookiesText :: CookiesText -> Builder
66renderCookiesText = renderCookiesBuilder . map (encodeUtf8Builder *** encodeUtf8Builder)
67
68type Cookies = [(S.ByteString, S.ByteString)]
69
70-- | Decode the value of a \"Cookie\" request header into key/value pairs.
71parseCookies :: S.ByteString -> Cookies
72parseCookies s
73  | S.null s = []
74  | otherwise =
75    let (x, y) = breakDiscard 59 s -- semicolon
76     in parseCookie x : parseCookies y
77
78parseCookie :: S.ByteString -> (S.ByteString, S.ByteString)
79parseCookie s =
80    let (key, value) = breakDiscard 61 s -- equals sign
81        key' = S.dropWhile (== 32) key -- space
82     in (key', value)
83
84breakDiscard :: Word8 -> S.ByteString -> (S.ByteString, S.ByteString)
85breakDiscard w s =
86    let (x, y) = S.break (== w) s
87     in (x, S.drop 1 y)
88
89type CookieBuilder = (Builder, Builder)
90
91renderCookiesBuilder :: [CookieBuilder] -> Builder
92renderCookiesBuilder [] = mempty
93renderCookiesBuilder cs =
94    foldr1 go $ map renderCookie cs
95  where
96    go x y = x `mappend` char8 ';' `mappend` y
97
98renderCookie :: CookieBuilder -> Builder
99renderCookie (k, v) = k `mappend` char8 '=' `mappend` v
100
101renderCookies :: Cookies -> Builder
102renderCookies = renderCookiesBuilder . map (byteString *** byteString)
103
104-- | Data type representing the key-value pair to use for a cookie, as well as configuration options for it.
105--
106-- ==== Creating a SetCookie
107--
108-- 'SetCookie' does not export a constructor; instead, use 'defaultSetCookie' and override values (see <http://www.yesodweb.com/book/settings-types> for details):
109--
110-- @
111-- import Web.Cookie
112-- :set -XOverloadedStrings
113-- let cookie = 'defaultSetCookie' { 'setCookieName' = "cookieName", 'setCookieValue' = "cookieValue" }
114-- @
115--
116-- ==== Cookie Configuration
117--
118-- 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>.
119data SetCookie = SetCookie
120    { setCookieName :: S.ByteString -- ^ The name of the cookie. Default value: @"name"@
121    , setCookieValue :: S.ByteString -- ^ The value of the cookie. Default value: @"value"@
122    , 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).
123    , 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).
124    , 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).
125    , setCookieDomain :: Maybe S.ByteString -- ^ The domain for which the cookie should be sent. Default value: @Nothing@ (The browser defaults to the current domain).
126    , setCookieHttpOnly :: Bool -- ^ Marks the cookie as "HTTP only", i.e. not accessible from Javascript. Default value: @False@
127    , setCookieSecure :: Bool -- ^ Instructs the browser to only send the cookie over HTTPS. Default value: @False@
128    , setCookieSameSite :: Maybe SameSiteOption -- ^ The "same site" policy of the cookie, i.e. whether it should be sent with cross-site requests. Default value: @Nothing@
129    }
130    deriving (Eq, Show)
131
132-- | Data type representing the options for a <https://tools.ietf.org/html/draft-west-first-party-cookies-07#section-4.1 SameSite cookie>
133data SameSiteOption = Lax
134                    | Strict
135                    | None
136                    deriving (Show, Eq)
137
138instance NFData SameSiteOption where
139  rnf x = x `seq` ()
140
141-- | 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@)
142sameSiteLax :: SameSiteOption
143sameSiteLax = Lax
144
145-- | 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.
146sameSiteStrict :: SameSiteOption
147sameSiteStrict = Strict
148
149-- |
150-- Directs the browser to send the cookie for cross-site requests.
151--
152-- @since 0.4.5
153sameSiteNone :: SameSiteOption
154sameSiteNone = None
155
156instance NFData SetCookie where
157    rnf (SetCookie a b c d e f g h i) =
158        a `seq`
159        b `seq`
160        rnfMBS c `seq`
161        rnf d `seq`
162        rnf e `seq`
163        rnfMBS f `seq`
164        rnf g `seq`
165        rnf h `seq`
166        rnf i
167      where
168        -- For backwards compatibility
169        rnfMBS Nothing = ()
170        rnfMBS (Just bs) = bs `seq` ()
171
172-- | @'def' = 'defaultSetCookie'@
173instance Default SetCookie where
174    def = defaultSetCookie
175
176-- | 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'.
177--
178-- @since 0.4.2.2
179defaultSetCookie :: SetCookie
180defaultSetCookie = SetCookie
181    { setCookieName     = "name"
182    , setCookieValue    = "value"
183    , setCookiePath     = Nothing
184    , setCookieExpires  = Nothing
185    , setCookieMaxAge   = Nothing
186    , setCookieDomain   = Nothing
187    , setCookieHttpOnly = False
188    , setCookieSecure   = False
189    , setCookieSameSite = Nothing
190    }
191
192renderSetCookie :: SetCookie -> Builder
193renderSetCookie sc = mconcat
194    [ byteString (setCookieName sc)
195    , char8 '='
196    , byteString (setCookieValue sc)
197    , case setCookiePath sc of
198        Nothing -> mempty
199        Just path -> byteStringCopy "; Path="
200                     `mappend` byteString path
201    , case setCookieExpires sc of
202        Nothing -> mempty
203        Just e -> byteStringCopy "; Expires=" `mappend`
204                  byteString (formatCookieExpires e)
205    , case setCookieMaxAge sc of
206        Nothing -> mempty
207        Just ma -> byteStringCopy"; Max-Age=" `mappend`
208                   byteString (formatCookieMaxAge ma)
209    , case setCookieDomain sc of
210        Nothing -> mempty
211        Just d -> byteStringCopy "; Domain=" `mappend`
212                  byteString d
213    , if setCookieHttpOnly sc
214        then byteStringCopy "; HttpOnly"
215        else mempty
216    , if setCookieSecure sc
217        then byteStringCopy "; Secure"
218        else mempty
219    , case setCookieSameSite sc of
220        Nothing -> mempty
221        Just Lax -> byteStringCopy "; SameSite=Lax"
222        Just Strict -> byteStringCopy "; SameSite=Strict"
223        Just None -> byteStringCopy "; SameSite=None"
224    ]
225
226parseSetCookie :: S.ByteString -> SetCookie
227parseSetCookie a = SetCookie
228    { setCookieName = name
229    , setCookieValue = value
230    , setCookiePath = lookup "path" flags
231    , setCookieExpires =
232        lookup "expires" flags >>= parseCookieExpires
233    , setCookieMaxAge =
234        lookup "max-age" flags >>= parseCookieMaxAge
235    , setCookieDomain = lookup "domain" flags
236    , setCookieHttpOnly = isJust $ lookup "httponly" flags
237    , setCookieSecure = isJust $ lookup "secure" flags
238    , setCookieSameSite = case lookup "samesite" flags of
239        Just "Lax" -> Just Lax
240        Just "Strict" -> Just Strict
241        Just "None" -> Just None
242        _ -> Nothing
243    }
244  where
245    pairs = map (parsePair . dropSpace) $ S.split 59 a ++ [S8.empty] -- 59 = semicolon
246    (name, value) = head pairs
247    flags = map (first (S8.map toLower)) $ tail pairs
248    parsePair = breakDiscard 61 -- equals sign
249    dropSpace = S.dropWhile (== 32) -- space
250
251expiresFormat :: String
252expiresFormat = "%a, %d-%b-%Y %X GMT"
253
254-- | Format a 'UTCTime' for a cookie.
255formatCookieExpires :: UTCTime -> S.ByteString
256formatCookieExpires =
257    S8.pack . formatTime defaultTimeLocale expiresFormat
258
259parseCookieExpires :: S.ByteString -> Maybe UTCTime
260parseCookieExpires =
261    fmap fuzzYear . parseTimeM True defaultTimeLocale expiresFormat . S8.unpack
262  where
263    -- See: https://github.com/snoyberg/cookie/issues/5
264    fuzzYear orig@(UTCTime day diff)
265        | x >= 70 && x <= 99 = addYear 1900
266        | x >= 0 && x <= 69 = addYear 2000
267        | otherwise = orig
268      where
269        (x, y, z) = toGregorian day
270        addYear x' = UTCTime (fromGregorian (x + x') y z) diff
271
272-- | Format a 'DiffTime' for a cookie.
273formatCookieMaxAge :: DiffTime -> S.ByteString
274formatCookieMaxAge difftime = S8.pack $ show (num `div` denom)
275  where rational = toRational difftime
276        num = numerator rational
277        denom = denominator rational
278
279parseCookieMaxAge :: S.ByteString -> Maybe DiffTime
280parseCookieMaxAge bs
281  | all isDigit unpacked = Just $ secondsToDiffTime $ read unpacked
282  | otherwise = Nothing
283  where unpacked = S8.unpack bs
284