diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 index 0000000..7d9edf5 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,11 @@ +## 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 new file mode 100644 index 0000000..d326dd8 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (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. diff --git a/README.md b/README.md new file mode 100644 index 0000000..9e3c631 --- /dev/null +++ b/README.md @@ -0,0 +1,5 @@ +## cookie + +[![Build Status](https://travis-ci.org/snoyberg/cookie.svg?branch=master)](https://travis-ci.org/snoyberg/cookie) + +HTTP cookie parsing and rendering diff --git a/Setup.lhs b/Setup.lhs new file mode 100755 index 0000000..1bc517f --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,8 @@ +#!/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 new file mode 100644 index 0000000..a956d67 --- /dev/null +++ b/Web/Cookie.hs @@ -0,0 +1,271 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +module Web.Cookie + ( -- * Server to client + -- ** Data type + SetCookie + , setCookieName + , setCookieValue + , setCookiePath + , setCookieExpires + , setCookieMaxAge + , setCookieDomain + , setCookieHttpOnly + , setCookieSecure + , setCookieSameSite + , SameSiteOption + , sameSiteLax + , sameSiteStrict + -- ** Functions + , parseSetCookie + , renderSetCookie + , defaultSetCookie + , def + -- * Client to server + , Cookies + , parseCookies + , renderCookies + -- ** 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 Data.Char (toLower) +import Blaze.ByteString.Builder (Builder, fromByteString, copyByteString) +import Blaze.ByteString.Builder.Char8 (fromChar) +import Data.Monoid (mempty, mappend, mconcat) +import Data.Word (Word8) +import Data.Ratio (numerator, denominator) +import Data.Time (UTCTime (UTCTime), toGregorian, fromGregorian, formatTime, parseTime) +import Data.Time.Clock (DiffTime, secondsToDiffTime) +#if MIN_VERSION_time(1, 5, 0) +import Data.Time (defaultTimeLocale) +#else +import System.Locale (defaultTimeLocale) +#endif +import Control.Arrow (first) +import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8, decodeUtf8With) +import Data.Text.Encoding.Error (lenientDecode) +import Control.Arrow ((***)) +import Data.Maybe (isJust) +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 + +-- FIXME to speed things up, skip encodeUtf8 and use fromText instead +renderCookiesText :: CookiesText -> Builder +renderCookiesText = renderCookies . map (encodeUtf8 *** encodeUtf8) + +type Cookies = [(S.ByteString, S.ByteString)] + +-- | 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 + 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) + +breakDiscard :: Word8 -> S.ByteString -> (S.ByteString, S.ByteString) +breakDiscard w s = + let (x, y) = S.breakByte w s + in (x, S.drop 1 y) + +renderCookies :: Cookies -> Builder +renderCookies [] = mempty +renderCookies cs = + foldr1 go $ map renderCookie cs + where + go x y = x `mappend` fromChar ';' `mappend` y + +renderCookie :: (S.ByteString, S.ByteString) -> Builder +renderCookie (k, v) = fromByteString k `mappend` fromChar '=' + `mappend` fromByteString v +-- | 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 -- ^ Marks the cookie as "same site", i.e. should not be sent with cross-site requests. Default value: @Nothing@ + } + deriving (Eq, Show) + +-- | Data type representing the options for a SameSite cookie +data SameSiteOption = Lax | Strict deriving (Show, Eq) + +instance NFData SameSiteOption where + rnf x = x `seq` () + +sameSiteLax :: SameSiteOption +sameSiteLax = Lax + +sameSiteStrict :: SameSiteOption +sameSiteStrict = Strict + +instance NFData SetCookie where + rnf (SetCookie a b c d e f g h i) = + a `seq` + b `seq` + rnfMBS c `seq` + rnf d `seq` + rnf e `seq` + rnfMBS f `seq` + rnf g `seq` + rnf h `seq` + rnf i + 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 + } + +renderSetCookie :: SetCookie -> Builder +renderSetCookie sc = mconcat + [ fromByteString (setCookieName sc) + , fromChar '=' + , fromByteString (setCookieValue sc) + , case setCookiePath sc of + Nothing -> mempty + Just path -> copyByteString "; Path=" + `mappend` fromByteString path + , case setCookieExpires sc of + Nothing -> mempty + Just e -> copyByteString "; Expires=" `mappend` + fromByteString (formatCookieExpires e) + , case setCookieMaxAge sc of + Nothing -> mempty + Just ma -> copyByteString"; Max-Age=" `mappend` + fromByteString (formatCookieMaxAge ma) + , case setCookieDomain sc of + Nothing -> mempty + Just d -> copyByteString "; Domain=" `mappend` + fromByteString d + , if setCookieHttpOnly sc + then copyByteString "; HttpOnly" + else mempty + , if setCookieSecure sc + then copyByteString "; Secure" + else mempty + , case setCookieSameSite sc of + Nothing -> mempty + Just Lax -> copyByteString "; SameSite=Lax" + Just Strict -> copyByteString "; SameSite=Strict" + ] + +parseSetCookie :: S.ByteString -> SetCookie +parseSetCookie a = SetCookie + { setCookieName = name + , setCookieValue = 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 + _ -> Nothing + } + 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 + +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 . parseTime 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 (\ c -> c >= '0' && c <= '9') $ unpacked = Just $ secondsToDiffTime $ read unpacked + | otherwise = Nothing + where unpacked = S8.unpack bs diff --git a/cookie.cabal b/cookie.cabal new file mode 100644 index 0000000..f1b571b --- /dev/null +++ b/cookie.cabal @@ -0,0 +1,48 @@ +name: cookie +version: 0.4.3 +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.8 +build-type: Simple +homepage: http://github.com/snoyberg/cookie +extra-source-files: README.md ChangeLog.md + +library + build-depends: base >= 4 && < 5 + , bytestring >= 0.9.1.4 + , blaze-builder >= 0.2.1 + , old-locale >= 1 + , time >= 1.4 + , text >= 0.7 + , data-default-class + , deepseq + exposed-modules: Web.Cookie + ghc-options: -Wall + +test-suite test + hs-source-dirs: test + main-is: Spec.hs + type: exitcode-stdio-1.0 + build-depends: base + , HUnit + , QuickCheck + , blaze-builder + , bytestring + , cookie + , tasty + , tasty-hunit + , tasty-quickcheck + , text + -- Bug in time 1.4.0, see: + -- https://github.com/snoyberg/cookie/issues/9 + , time >= 1.4.0.2 + +source-repository head + type: git + location: git://github.com/snoyberg/cookie.git diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 index 0000000..5768621 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,107 @@ +import Test.Tasty (defaultMain, testGroup) +import Test.Tasty.QuickCheck (testProperty) +import Test.Tasty.HUnit (testCase) +import Test.QuickCheck +import Test.HUnit ((@=?), Assertion) + +import Web.Cookie +import Blaze.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 Control.Applicative ((<$>), (<*>)) +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 + , 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 = fmap (Char' . toEnum) $ choose (62, 125) +newtype SameSiteOption' = SameSiteOption' { unSameSiteOption' :: SameSiteOption } +instance Arbitrary SameSiteOption' where + arbitrary = fmap SameSiteOption' (elements [sameSiteLax, sameSiteStrict]) + +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 + return def + { setCookieName = name + , setCookieValue = value + , setCookiePath = path + , setCookieExpires = expires + , setCookieDomain = domain + , setCookieHttpOnly = httponly + , setCookieSecure = secure + , setCookieSameSite = sameSite + } + +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 + +-- Tests for two digit years, see: +-- +-- https://github.com/snoyberg/cookie/issues/5 +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" + ]