diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,15 @@ +## 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) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,5 +1,5 @@ ## cookie -[![Build Status](https://travis-ci.org/snoyberg/cookie.svg?branch=master)](https://travis-ci.org/snoyberg/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 @@ -13,6 +13,7 @@ , setCookieHttpOnly , setCookieSecure , setCookieSameSite + , setCookiePartitioned , SameSiteOption , sameSiteLax , sameSiteStrict @@ -55,7 +56,7 @@ import Data.Text (Text) import Data.Text.Encoding (encodeUtf8Builder, decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode) -import Data.Maybe (isJust) +import Data.Maybe (isJust, fromMaybe, listToMaybe) import Data.Default.Class (Default (def)) import Control.DeepSeq (NFData (rnf)) @@ -73,25 +74,46 @@ 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.break (== w) s in (x, S.drop 1 y) +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 @@ -136,6 +158,7 @@ , 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) @@ -164,7 +187,7 @@ sameSiteNone = None instance NFData SetCookie where - rnf (SetCookie a b c d e f g h i) = + rnf (SetCookie a b c d e f g h i j) = a `seq` b `seq` rnfMBS c `seq` @@ -173,7 +196,8 @@ rnfMBS f `seq` rnf g `seq` rnf h `seq` - rnf i + rnf i `seq` + rnf j where -- For backwards compatibility rnfMBS Nothing = () @@ -197,6 +221,7 @@ , setCookieHttpOnly = False , setCookieSecure = False , setCookieSameSite = Nothing + , setCookiePartitioned = False } renderSetCookie :: SetCookie -> Builder @@ -214,7 +239,7 @@ byteString (formatCookieExpires e) , case setCookieMaxAge sc of Nothing -> mempty - Just ma -> byteStringCopy"; Max-Age=" `mappend` + Just ma -> byteStringCopy "; Max-Age=" `mappend` byteString (formatCookieMaxAge ma) , case setCookieDomain sc of Nothing -> mempty @@ -231,6 +256,9 @@ 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 @@ -240,7 +268,7 @@ parseSetCookie :: S.ByteString -> SetCookie parseSetCookie a = SetCookie { setCookieName = name - , setCookieValue = value + , setCookieValue = dropEnds doubleQuote value , setCookiePath = lookup "path" flags , setCookieExpires = lookup "expires" flags >>= parseCookieExpires @@ -254,13 +282,14 @@ Just "Strict" -> Just Strict Just "None" -> Just None _ -> Nothing + , setCookiePartitioned = isJust $ lookup "partitioned" flags } where - pairs = map (parsePair . dropSpace) $ S.split 59 a ++ [S8.empty] -- 59 = semicolon - (name, value) = head pairs - flags = map (first (S8.map toLower)) $ tail pairs - parsePair = breakDiscard 61 -- equals sign - dropSpace = S.dropWhile (== 32) -- space + 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" diff --git a/cookie.cabal b/cookie.cabal --- a/cookie.cabal +++ b/cookie.cabal @@ -1,5 +1,6 @@ +cabal-version: >= 1.10 name: cookie -version: 0.4.6 +version: 0.5.1 license: MIT license-file: LICENSE author: Michael Snoyman @@ -8,9 +9,8 @@ description: Hackage documentation generation is not reliable. For up to date documentation, please see: . category: Web, Yesod stability: Stable -cabal-version: >= 1.10 build-type: Simple -homepage: http://github.com/snoyberg/cookie +homepage: https://github.com/snoyberg/cookie extra-source-files: README.md ChangeLog.md library @@ -42,4 +42,4 @@ 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 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,18 +1,19 @@ -import Test.Tasty (defaultMain, testGroup) +{-# 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, word8, toLazyByteString) +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 Data.Monoid (mconcat) import Control.Arrow ((***)) -import Control.Applicative ((<$>), (<*>)) import Data.Time (UTCTime (UTCTime), toGregorian) import qualified Data.Text as T @@ -22,6 +23,8 @@ , 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 @@ -52,7 +55,7 @@ show (Char' w) = [toEnum $ fromEnum w] showList = (++) . show . concatMap show instance Arbitrary Char' where - arbitrary = fmap (Char' . toEnum) $ choose (62, 125) + arbitrary = Char' . toEnum <$> choose (62, 125) newtype SameSiteOption' = SameSiteOption' { unSameSiteOption' :: SameSiteOption } instance Arbitrary SameSiteOption' where arbitrary = fmap SameSiteOption' (elements [sameSiteLax, sameSiteStrict, sameSiteNone]) @@ -72,6 +75,7 @@ httponly <- arbitrary secure <- arbitrary sameSite <- fmap (fmap unSameSiteOption') arbitrary + partitioned <- arbitrary return def { setCookieName = name , setCookieValue = value @@ -81,6 +85,7 @@ , setCookieHttpOnly = httponly , setCookieSecure = secure , setCookieSameSite = sameSite + , setCookiePartitioned = partitioned } caseParseCookies :: Assertion @@ -89,16 +94,20 @@ 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 + Just (UTCTime day' _) -> day' Nothing -> error $ "setCookieExpires == Nothing for: " ++ show str sc = parseSetCookie str str = S8.pack $ concat @@ -106,3 +115,17 @@ , 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