cookie-0.5.1/Web/0000755000000000000000000000000014772505222011677 5ustar0000000000000000cookie-0.5.1/test/0000755000000000000000000000000014772505222012141 5ustar0000000000000000cookie-0.5.1/Web/Cookie.hs0000644000000000000000000002676514772505222013464 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Web.Cookie ( -- * Server to client -- ** 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 , renderCookiesText -- * Expires field , 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, fromMaybe, listToMaybe) import Data.Default.Class (Default (def)) import Control.DeepSeq (NFData (rnf)) -- | Textual cookies. Functions assume UTF8 encoding. type CookiesText = [(Text, Text)] parseCookiesText :: S.ByteString -> CookiesText parseCookiesText = map (go *** go) . parseCookies where go = decodeUtf8With lenientDecode renderCookiesText :: CookiesText -> Builder 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 semicolon s in parseCookie x : parseCookies y parseCookie :: S.ByteString -> (S.ByteString, S.ByteString) parseCookie s = 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 renderCookiesBuilder [] = mempty renderCookiesBuilder cs = foldr1 go $ map renderCookie cs where go x y = x `mappend` char8 ';' `mappend` y 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 -- ^ 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) -- | 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 [ byteString (setCookieName sc) , char8 '=' , byteString (setCookieValue sc) , case setCookiePath sc of Nothing -> mempty Just path -> byteStringCopy "; Path=" `mappend` byteString path , case setCookieExpires sc of Nothing -> mempty 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 -> byteStringCopy "; Domain=" `mappend` byteString d , if setCookieHttpOnly sc 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 = name , setCookieValue = dropEnds doubleQuote value , setCookiePath = lookup "path" flags , setCookieExpires = 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 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" -- | Format a 'UTCTime' for a cookie. formatCookieExpires :: UTCTime -> S.ByteString formatCookieExpires = S8.pack . formatTime defaultTimeLocale expiresFormat parseCookieExpires :: S.ByteString -> Maybe UTCTime 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 cookie-0.5.1/test/Spec.hs0000644000000000000000000001105714772505222013373 0ustar0000000000000000{-# 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 cookie-0.5.1/README.md0000644000000000000000000000026714772505030012443 0ustar0000000000000000## 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 cookie-0.5.1/ChangeLog.md0000644000000000000000000000160014772505222013330 0ustar0000000000000000## 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) cookie-0.5.1/LICENSE0000644000000000000000000000207514772505030012170 0ustar0000000000000000Copyright (c) 2010 Michael Snoyman, http://www.yesodweb.com/ 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: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. 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. cookie-0.5.1/cookie.cabal0000644000000000000000000000276014772505222013424 0ustar0000000000000000cabal-version: >= 1.10 name: cookie 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 build-type: Simple homepage: https://github.com/snoyberg/cookie extra-source-files: README.md ChangeLog.md library default-language: Haskell2010 build-depends: base >= 4 && < 5 , 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: https://github.com/snoyberg/cookie.git