diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,37 @@ +## 0.5.1 + +* Add the `Partitioned` cookie attribute. + +## 0.5.0 + +* Remove surrounding double quotes from cookie values when parsing [#31](https://github.com/snoyberg/cookie/pull/31) + + This is a breaking change, as it changes the behavior of `parseCookies` and `parseSetCookie` to no + longer include the surrounding double quotes in the cookie value. This is the correct behavior + according to the RFC. + +## 0.4.6 + +* Resolve redundant import of Data.Monoid [#26](https://github.com/snoyberg/cookie/pull/26) +* Added `renderSetCookieBS` and `renderCookiesBS` + +## 0.4.5 + +* Added `SameSite=None` + +## 0.4.4 + +* Dropped dependency on blaze-builder +* Made cookie text rendering slightly more efficient + +## 0.4.3 + +* Added `defaultSetCookie` [#16](https://github.com/snoyberg/cookie/pull/16) + +## 0.4.2.1 + +* Clarified MIT license + +## 0.4.2 + +* Added SameSite [#13](https://github.com/snoyberg/cookie/pull/13) diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,25 +1,20 @@ -The following license covers this documentation, and the source code, except -where otherwise indicated. - -Copyright 2010, Michael Snoyman. All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: +Copyright (c) 2010 Michael Snoyman, http://www.yesodweb.com/ -* Redistributions of source code must retain the above copyright notice, this - list of conditions and the following disclaimer. +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: -* Redistributions in binary form must reproduce the above copyright notice, - this list of conditions and the following disclaimer in the documentation - and/or other materials provided with the distribution. +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR -IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF -MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO -EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, -INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT -NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, -OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF -LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE -OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,5 @@ +## cookie + +[![Build Status](https://github.com/snoyberg/cookie/actions/workflows/tests.yaml/badge.svg)](https://github.com/snoyberg/cookie/actions) + +HTTP cookie parsing and rendering diff --git a/Setup.lhs b/Setup.lhs deleted file mode 100644 --- a/Setup.lhs +++ /dev/null @@ -1,8 +0,0 @@ -#!/usr/bin/env runhaskell - -> module Main where -> import Distribution.Simple -> import System.Cmd (system) - -> main :: IO () -> main = defaultMain diff --git a/Web/Cookie.hs b/Web/Cookie.hs --- a/Web/Cookie.hs +++ b/Web/Cookie.hs @@ -1,13 +1,34 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Web.Cookie ( -- * Server to client - SetCookie (..) + -- ** 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 @@ -20,19 +41,24 @@ import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 -import Data.Char (toLower) -import Blaze.ByteString.Builder (Builder, fromByteString, copyByteString) -import Blaze.ByteString.Builder.Char8 (fromChar) +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.Time (UTCTime, formatTime, parseTime) -import System.Locale (defaultTimeLocale) -import Control.Arrow (first) +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 (encodeUtf8, decodeUtf8With) +import Data.Text.Encoding (encodeUtf8Builder, decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode) -import Control.Arrow ((***)) -import Data.Maybe (isJust) +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)] @@ -43,96 +69,227 @@ where go = decodeUtf8With lenientDecode --- FIXME to speed things up, skip encodeUtf8 and use fromText instead renderCookiesText :: CookiesText -> Builder -renderCookiesText = renderCookies . map (encodeUtf8 *** encodeUtf8) +renderCookiesText = renderCookiesBuilder . map (encodeUtf8Builder *** encodeUtf8Builder) type Cookies = [(S.ByteString, S.ByteString)] +semicolon :: Word8 +semicolon = 59 + +equalsSign :: Word8 +equalsSign = 61 + +space :: Word8 +space = 32 + +doubleQuote :: Word8 +doubleQuote = 34 + -- | Decode the value of a \"Cookie\" request header into key/value pairs. parseCookies :: S.ByteString -> Cookies parseCookies s | S.null s = [] | otherwise = - let (x, y) = breakDiscard 59 s -- semicolon + let (x, y) = breakDiscard semicolon s in parseCookie x : parseCookies y parseCookie :: S.ByteString -> (S.ByteString, S.ByteString) parseCookie s = - let (key, value) = breakDiscard 61 s -- equals sign - key' = S.dropWhile (== 32) key -- space - in (key', value) + let (key, value) = breakDiscard equalsSign s + key' = S.dropWhile (== space) key + value' = dropEnds doubleQuote value + in (key', value') breakDiscard :: Word8 -> S.ByteString -> (S.ByteString, S.ByteString) breakDiscard w s = - let (x, y) = S.breakByte w s + let (x, y) = S.break (== w) s in (x, S.drop 1 y) -renderCookies :: Cookies -> Builder -renderCookies [] = mempty -renderCookies cs = +dropEnds :: Word8 -> S.ByteString -> S.ByteString +dropEnds w s = + case S.unsnoc s of + Just (s', w') | w' == w -> case S.uncons s' of + Just (w'', s'') | w'' == w -> s'' + _ -> s + _ -> s + +type CookieBuilder = (Builder, Builder) + +renderCookiesBuilder :: [CookieBuilder] -> Builder +renderCookiesBuilder [] = mempty +renderCookiesBuilder cs = foldr1 go $ map renderCookie cs where - go x y = x `mappend` fromChar ';' `mappend` y + go x y = x `mappend` char8 ';' `mappend` y -renderCookie :: (S.ByteString, S.ByteString) -> Builder -renderCookie (k, v) = fromByteString k `mappend` fromChar '=' - `mappend` fromByteString v +renderCookie :: CookieBuilder -> Builder +renderCookie (k, v) = k `mappend` char8 '=' `mappend` v +renderCookies :: Cookies -> Builder +renderCookies = renderCookiesBuilder . map (byteString *** byteString) + +-- | @since 0.4.6 +renderCookiesBS :: Cookies -> S.ByteString +renderCookiesBS = L.toStrict . toLazyByteString . 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 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 or . data SetCookie = SetCookie - { setCookieName :: S.ByteString - , setCookieValue :: S.ByteString - , setCookiePath :: Maybe S.ByteString - , setCookieExpires :: Maybe UTCTime - , setCookieDomain :: Maybe S.ByteString - , setCookieHttpOnly :: Bool + { setCookieName :: S.ByteString -- ^ The name of the cookie. Default value: @"name"@ + , setCookieValue :: S.ByteString -- ^ The value of the cookie. Default value: @"value"@ + , 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). + , 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). + , 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). + , setCookieDomain :: Maybe S.ByteString -- ^ The domain for which the cookie should be sent. Default value: @Nothing@ (The browser defaults to the current domain). + , setCookieHttpOnly :: Bool -- ^ Marks the cookie as "HTTP only", i.e. not accessible from Javascript. Default value: @False@ + , setCookieSecure :: Bool -- ^ Instructs the browser to only send the cookie over HTTPS. Default value: @False@ + , setCookieSameSite :: Maybe SameSiteOption -- ^ The "same site" policy of the cookie, i.e. whether it should be sent with cross-site requests. Default value: @Nothing@ + , 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 (Eq, Show, Read) + deriving (Eq, Show) +-- | Data type representing the options for a +data SameSiteOption = Lax + | Strict + | None + deriving (Show, Eq) + +instance NFData SameSiteOption where + rnf x = x `seq` () + +-- | Directs the browser to send the cookie for (e.g. @GET@), but not for unsafe ones (e.g. @POST@) +sameSiteLax :: SameSiteOption +sameSiteLax = 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 = Strict + +-- | +-- Directs the browser to send the cookie for cross-site requests. +-- +-- @since 0.4.5 +sameSiteNone :: SameSiteOption +sameSiteNone = None + +instance NFData SetCookie where + rnf (SetCookie a b c d e f g h i j) = + a `seq` + b `seq` + rnfMBS c `seq` + rnf d `seq` + rnf e `seq` + rnfMBS f `seq` + rnf g `seq` + rnf h `seq` + rnf i `seq` + rnf j + where + -- For backwards compatibility + rnfMBS Nothing = () + rnfMBS (Just bs) = bs `seq` () + +-- | @'def' = 'defaultSetCookie'@ +instance Default SetCookie where + def = 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 + { setCookieName = "name" + , setCookieValue = "value" + , setCookiePath = Nothing + , setCookieExpires = Nothing + , setCookieMaxAge = Nothing + , setCookieDomain = Nothing + , setCookieHttpOnly = False + , setCookieSecure = False + , setCookieSameSite = Nothing + , setCookiePartitioned = False + } + renderSetCookie :: SetCookie -> Builder renderSetCookie sc = mconcat - [ fromByteString (setCookieName sc) - , fromChar '=' - , fromByteString (setCookieValue sc) + [ byteString (setCookieName sc) + , char8 '=' + , byteString (setCookieValue sc) , case setCookiePath sc of Nothing -> mempty - Just path -> copyByteString "; path=" - `mappend` fromByteString path + Just path -> byteStringCopy "; Path=" + `mappend` byteString path , case setCookieExpires sc of Nothing -> mempty - Just e -> copyByteString "; expires=" `mappend` - fromByteString (formatCookieExpires e) + Just e -> byteStringCopy "; Expires=" `mappend` + byteString (formatCookieExpires e) + , case setCookieMaxAge sc of + Nothing -> mempty + Just ma -> byteStringCopy "; Max-Age=" `mappend` + byteString (formatCookieMaxAge ma) , case setCookieDomain sc of Nothing -> mempty - Just d -> copyByteString "; domain=" `mappend` - fromByteString d + Just d -> byteStringCopy "; Domain=" `mappend` + byteString d , if setCookieHttpOnly sc - then copyByteString "; HttpOnly" + then byteStringCopy "; HttpOnly" else mempty + , if setCookieSecure sc + then byteStringCopy "; Secure" + else mempty + , case setCookieSameSite sc of + Nothing -> mempty + Just Lax -> byteStringCopy "; SameSite=Lax" + Just Strict -> byteStringCopy "; SameSite=Strict" + Just None -> byteStringCopy "; SameSite=None" + , if setCookiePartitioned sc + then byteStringCopy "; Partitioned" + else mempty ] +-- | @since 0.4.6 +renderSetCookieBS :: SetCookie -> S.ByteString +renderSetCookieBS = L.toStrict . toLazyByteString . renderSetCookie + parseSetCookie :: S.ByteString -> SetCookie parseSetCookie a = SetCookie - { setCookieName = key - , setCookieValue = value - , setCookiePath = lookup "path" pairs + { setCookieName = name + , setCookieValue = dropEnds doubleQuote value + , setCookiePath = lookup "path" flags , setCookieExpires = - lookup "expires" pairs >>= parseCookieExpires - , setCookieDomain = lookup "domain" pairs - , setCookieHttpOnly = isJust $ lookup "HttpOnly" pairs + lookup "expires" flags >>= parseCookieExpires + , setCookieMaxAge = + lookup "max-age" flags >>= parseCookieMaxAge + , setCookieDomain = lookup "domain" flags + , setCookieHttpOnly = isJust $ lookup "httponly" flags + , setCookieSecure = isJust $ lookup "secure" flags + , setCookieSameSite = case lookup "samesite" flags of + Just "Lax" -> Just Lax + Just "Strict" -> Just Strict + Just "None" -> Just None + _ -> Nothing + , setCookiePartitioned = isJust $ lookup "partitioned" flags } where - (key, value, b) = parsePair a - pairs = map (first $ S8.map toLower) $ parsePairs b - parsePair bs = - let (k, bs') = breakDiscard 61 bs -- equals sign - (v, bs'') = breakDiscard 59 bs' -- semicolon - in (k, v, S.dropWhile (== 32) bs'') -- space - parsePairs bs = - if S.null bs - then [] - else let (k, v, bs') = parsePair bs - in (k, v) : parsePairs bs' + pairs = map (parsePair . dropSpace) $ S.split semicolon a + (name, value) = fromMaybe mempty $ listToMaybe pairs + flags = map (first (S8.map toLower)) $ drop 1 pairs + parsePair = breakDiscard equalsSign + dropSpace = S.dropWhile (== space) expiresFormat :: String expiresFormat = "%a, %d-%b-%Y %X GMT" @@ -143,4 +300,27 @@ S8.pack . formatTime defaultTimeLocale expiresFormat parseCookieExpires :: S.ByteString -> Maybe UTCTime -parseCookieExpires = parseTime defaultTimeLocale expiresFormat . S8.unpack +parseCookieExpires = + fmap fuzzYear . parseTimeM True defaultTimeLocale expiresFormat . S8.unpack + where + -- See: https://github.com/snoyberg/cookie/issues/5 + fuzzYear orig@(UTCTime day diff) + | x >= 70 && x <= 99 = addYear 1900 + | x >= 0 && x <= 69 = addYear 2000 + | otherwise = orig + where + (x, y, z) = toGregorian day + addYear x' = UTCTime (fromGregorian (x + x') y z) diff + +-- | Format a 'DiffTime' for a cookie. +formatCookieMaxAge :: DiffTime -> S.ByteString +formatCookieMaxAge difftime = S8.pack $ show (num `div` denom) + where rational = toRational difftime + num = numerator rational + denom = denominator rational + +parseCookieMaxAge :: S.ByteString -> Maybe DiffTime +parseCookieMaxAge bs + | all isDigit unpacked = Just $ secondsToDiffTime $ read unpacked + | otherwise = Nothing + where unpacked = S8.unpack bs diff --git a/cookie.cabal b/cookie.cabal --- a/cookie.cabal +++ b/cookie.cabal @@ -1,26 +1,45 @@ +cabal-version: >= 1.10 name: cookie -version: 0.3.0.2 -license: BSD3 +version: 0.5.1 +license: MIT license-file: LICENSE author: Michael Snoyman maintainer: Michael Snoyman synopsis: HTTP cookie parsing and rendering +description: Hackage documentation generation is not reliable. For up to date documentation, please see: . category: Web, Yesod stability: Stable -cabal-version: >= 1.6 build-type: Simple -homepage: http://github.com/snoyberg/cookie +homepage: https://github.com/snoyberg/cookie +extra-source-files: README.md ChangeLog.md library + default-language: Haskell2010 build-depends: base >= 4 && < 5 - , bytestring >= 0.9.1.4 && < 0.10 - , blaze-builder >= 0.2.1 && < 0.4 - , old-locale >= 1 && < 1.1 - , time >= 1.1.4 - , text >= 0.7 && < 1.0 + , bytestring >= 0.10.2 + , time >= 1.5 + , text >= 1.1 + , data-default-class + , deepseq exposed-modules: Web.Cookie ghc-options: -Wall +test-suite test + default-language: Haskell2010 + hs-source-dirs: test + main-is: Spec.hs + type: exitcode-stdio-1.0 + build-depends: base + , HUnit + , QuickCheck + , bytestring >= 0.10.2 + , cookie + , tasty + , tasty-hunit + , tasty-quickcheck + , text >= 1.1 + , time >= 1.5 + source-repository head type: git - location: git://github.com/snoyberg/cookie.git + location: https://github.com/snoyberg/cookie.git diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,131 @@ +{-# OPTIONS_GHC -Wno-orphans #-} +module Main where + +import Test.Tasty (defaultMain, testGroup, TestTree) +import Test.Tasty.QuickCheck (testProperty) +import Test.Tasty.HUnit (testCase) +import Test.QuickCheck +import Test.HUnit ((@=?), Assertion) + +import Web.Cookie +import Data.ByteString.Builder (Builder, toLazyByteString) +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString.Lazy as L +import Data.Word (Word8) +import Control.Arrow ((***)) +import Data.Time (UTCTime (UTCTime), toGregorian) +import qualified Data.Text as T + +main :: IO () +main = defaultMain $ testGroup "cookie" + [ testProperty "parse/render cookies" propParseRenderCookies + , testProperty "parse/render SetCookie" propParseRenderSetCookie + , testProperty "parse/render cookies text" propParseRenderCookiesText + , testCase "parseCookies" caseParseCookies + , testCase "parseQuotedCookies" caseParseQuotedCookies + , testCase "parseQuotedSetCookie" caseParseQuotedSetCookie + , twoDigit 24 2024 + , twoDigit 69 2069 + , twoDigit 70 1970 + ] + +propParseRenderCookies :: Cookies' -> Bool +propParseRenderCookies cs' = + parseCookies (builderToBs $ renderCookies cs) == cs + where + cs = map (fromUnChars *** fromUnChars) cs' + +propParseRenderCookiesText :: Cookies' -> Bool +propParseRenderCookiesText cs' = + parseCookiesText (builderToBs $ renderCookiesText cs) == cs + where + cs = map (T.pack . map unChar'' *** T.pack . map unChar'') cs' + unChar'' = toEnum . fromEnum . unChar' + +fromUnChars :: [Char'] -> S.ByteString +fromUnChars = S.pack . map unChar' + +builderToBs :: Builder -> S.ByteString +builderToBs = S.concat . L.toChunks . toLazyByteString + +type Cookies' = [([Char'], [Char'])] +newtype Char' = Char' { unChar' :: Word8 } +instance Show Char' where + show (Char' w) = [toEnum $ fromEnum w] + showList = (++) . show . concatMap show +instance Arbitrary Char' where + arbitrary = Char' . toEnum <$> choose (62, 125) +newtype SameSiteOption' = SameSiteOption' { unSameSiteOption' :: SameSiteOption } +instance Arbitrary SameSiteOption' where + arbitrary = fmap SameSiteOption' (elements [sameSiteLax, sameSiteStrict, sameSiteNone]) + +propParseRenderSetCookie :: SetCookie -> Bool +propParseRenderSetCookie sc = + parseSetCookie (builderToBs $ renderSetCookie sc) == sc + +instance Arbitrary SetCookie where + arbitrary = do + name <- fmap fromUnChars arbitrary + value <- fmap fromUnChars arbitrary + path <- fmap (fmap fromUnChars) arbitrary + expires <- fmap (parseCookieExpires . formatCookieExpires) + (UTCTime <$> fmap toEnum arbitrary <*> return 0) + domain <- fmap (fmap fromUnChars) arbitrary + httponly <- arbitrary + secure <- arbitrary + sameSite <- fmap (fmap unSameSiteOption') arbitrary + partitioned <- arbitrary + return def + { setCookieName = name + , setCookieValue = value + , setCookiePath = path + , setCookieExpires = expires + , setCookieDomain = domain + , setCookieHttpOnly = httponly + , setCookieSecure = secure + , setCookieSameSite = sameSite + , setCookiePartitioned = partitioned + } + +caseParseCookies :: Assertion +caseParseCookies = do + let input = S8.pack "a=a1;b=b2; c=c3" + expected = [("a", "a1"), ("b", "b2"), ("c", "c3")] + map (S8.pack *** S8.pack) expected @=? parseCookies input + +-- TODO: Use `Year` from Data.Time when we'll remove support for GHC <9.2 +type Year = Integer + +-- Tests for two digit years, see: +-- +-- https://github.com/snoyberg/cookie/issues/5 +twoDigit :: Year -> Year -> TestTree +twoDigit x y = + testCase ("year " ++ show x) (y @=? year) + where + (year, _, _) = toGregorian day + day = + case setCookieExpires sc of + Just (UTCTime day' _) -> day' + Nothing -> error $ "setCookieExpires == Nothing for: " ++ show str + sc = parseSetCookie str + str = S8.pack $ concat + [ "foo=bar; Expires=Mon, 29-Jul-" + , show x + , " 04:52:08 GMT" + ] + +caseParseQuotedCookies :: Assertion +caseParseQuotedCookies = do + let input = S8.pack "a=\"a1\";b=\"b2\"; c=\"c3\"" + expected = [("a", "a1"), ("b", "b2"), ("c", "c3")] + map (S8.pack *** S8.pack) expected @=? parseCookies input + +caseParseQuotedSetCookie :: Assertion +caseParseQuotedSetCookie = do + let input = S8.pack "a=\"a1\"" + result = parseSetCookie input + resultNameAndValue = (setCookieName result, setCookieValue result) + expected = (S8.pack "a", S8.pack "a1") + expected @=? resultNameAndValue