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