From 85282a9157e23ea41e5496bcafceab2266bdce44 Mon Sep 17 00:00:00 2001 From: Marco Zocca Date: Sat, 10 Jun 2023 15:26:30 +0200 Subject: [PATCH 1/9] add Web.Scotty.Cookie --- Web/Scotty/Cookie.hs | 365 +++++++++++++++++++++++++++++++++++++++++++ scotty.cabal | 3 + 2 files changed, 368 insertions(+) create mode 100644 Web/Scotty/Cookie.hs diff --git a/Web/Scotty/Cookie.hs b/Web/Scotty/Cookie.hs new file mode 100644 index 00000000..3024311b --- /dev/null +++ b/Web/Scotty/Cookie.hs @@ -0,0 +1,365 @@ +{-| +Module : Web.Scotty.Cookie +Copyright : (c) 2014, 2015 Mārtiņš Mačs, + (c) 2010, 2023 Michael Snoyman, + (c) 2023 Marco Zocca + +License : BSD-3-Clause +Maintainer : +Stability : experimental +Portability : GHC + +This module provides utilities for adding cookie support inside @scotty@ applications. Most code has been adapted from 'cookie' and 'scotty-cookie'. + +== Example + +A simple hit counter that stores the number of page visits in a cookie: + +@ +\{\-\# LANGUAGE OverloadedStrings \#\-\} + +import Control.Monad +import Data.Monoid +import Data.Maybe +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Read as TL (decimal) +import Web.Scotty (scotty, html) +import Web.Scotty.Cookie (getCookie, setSimpleCookie) + +main :: IO () +main = scotty 3000 $ + get \"/\" $ do + hits <- liftM (fromMaybe \"0\") $ 'getCookie' \"hits\" + let hits' = + case TL.decimal hits of + Right n -> TL.pack . show . (+1) $ (fst n :: Integer) + Left _ -> \"1\" + 'setSimpleCookie' \"hits\" $ TL.toStrict hits' + html $ mconcat [ \"\\\" + , hits' + , \"\<\/body\>\<\/html\>\" + ] +@ +-} +{-# LANGUAGE OverloadedStrings #-} +module Web.Scotty.Cookie ( + -- * Set cookie + setCookie + , setSimpleCookie + -- * Get cookie(s) + , getCookie + , getCookies + -- * Delete a cookie + , deleteCookie + -- * Helpers and advanced interface + , CookiesText + , makeSimpleCookie + , SetCookie + , defaultSetCookie + , parseSetCookie + , renderCookies + , renderCookiesBuilder + , renderCookiesText + , SameSiteOption + , sameSiteNone + , sameSiteLax + , sameSiteStrict + ) where + +import Control.Arrow (first, (***)) +import Control.Monad ( liftM ) +import Data.Char (toLower, isDigit) +-- import Data.Monoid (mempty, mappend, mconcat) +import Data.Word (Word8) +import Data.Ratio (numerator, denominator) +import Data.Maybe (isJust) + +-- bytestring +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 +import Data.ByteString.Builder (Builder, byteString, char8, toLazyByteString) +import Data.ByteString.Builder.Extra (byteStringCopy) +import qualified Data.ByteString.Lazy as BSL (toStrict) +-- scotty +import Web.Scotty.Trans (ActionT, ScottyError(..), addHeader, header) +-- time +import Data.Time (UTCTime (UTCTime), toGregorian, fromGregorian, formatTime, parseTimeM, defaultTimeLocale) +import Data.Time.Clock (DiffTime, secondsToDiffTime) +import Data.Time.Clock.POSIX ( posixSecondsToUTCTime ) +-- text +import Data.Text (Text) +import qualified Data.Text.Lazy.Encoding as TL +import Data.Text.Encoding (encodeUtf8Builder, decodeUtf8With, encodeUtf8) +import Data.Text.Encoding.Error (lenientDecode) +-- deepseq +import Control.DeepSeq (NFData (rnf)) + + + + +setCookie :: (Monad m, ScottyError e) + => SetCookie + -> ActionT e m () +setCookie c = addHeader "Set-Cookie" (TL.decodeUtf8 . toLazyByteString $ renderSetCookie c) + + +-- | 'makeSimpleCookie' and 'setCookie' combined. +setSimpleCookie :: (Monad m, ScottyError e) + => Text -- ^ name + -> Text -- ^ value + -> ActionT e m () +setSimpleCookie n v = setCookie $ makeSimpleCookie n v + + +getCookie :: (Monad m, ScottyError e) + => Text -- ^ name + -> ActionT e m (Maybe Text) +getCookie c = lookup c <$> getCookies + + +-- | Returns all cookies +getCookies :: (Monad m, ScottyError e) + => ActionT e m CookiesText +getCookies = liftM (maybe [] parse) $ header "Cookie" + where parse = parseCookiesText . BSL.toStrict . TL.encodeUtf8 + + +deleteCookie :: (Monad m, ScottyError e) + => Text -- ^ name + -> ActionT e m () +deleteCookie c = setCookie $ (makeSimpleCookie c "") { setCookieExpires = Just $ posixSecondsToUTCTime 0 } + + +-- | Construct a simple cookie (an UTF-8 string pair with default cookie options) +makeSimpleCookie :: Text -- ^ name + -> Text -- ^ value + -> SetCookie +makeSimpleCookie n v = defaultSetCookie { setCookieName = encodeUtf8 n + , setCookieValue = encodeUtf8 v + } + + +-- | 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)] + +-- | 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.break (== w) s + in (x, S.drop 1 y) + +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) + +-- | 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@ + } + 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) = + 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` () + +-- | 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 + [ 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" + ] + +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 + Just "None" -> Just None + _ -> 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 . 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/scotty.cabal b/scotty.cabal index 7bb6242d..b626015f 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -68,6 +68,7 @@ Library Exposed-modules: Web.Scotty Web.Scotty.Trans Web.Scotty.Internal.Types + Web.Scotty.Cookie other-modules: Web.Scotty.Action Web.Scotty.Route Web.Scotty.Util @@ -79,6 +80,7 @@ Library bytestring >= 0.10.0.2 && < 0.12, case-insensitive >= 1.0.0.1 && < 1.3, data-default-class >= 0.0.1 && < 0.2, + deepseq >= 1.4, exceptions >= 0.7 && < 0.11, http-types >= 0.9.1 && < 0.13, monad-control >= 1.0.0.3 && < 1.1, @@ -86,6 +88,7 @@ Library network >= 2.6.0.2 && < 3.2, regex-compat >= 0.95.1 && < 0.96, text >= 0.11.3.1 && < 2.1, + time >= 1.11, transformers >= 0.3.0.0 && < 0.7, transformers-base >= 0.4.1 && < 0.5, transformers-compat >= 0.4 && < 0.8, From 9851e24af4f815b43aba16f2c8bcdae534049bc9 Mon Sep 17 00:00:00 2001 From: Marco Zocca Date: Sat, 10 Jun 2023 15:27:54 +0200 Subject: [PATCH 2/9] add Web.Scotty.Cookie --- Web/Scotty/Cookie.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/Web/Scotty/Cookie.hs b/Web/Scotty/Cookie.hs index 3024311b..02c91a1b 100644 --- a/Web/Scotty/Cookie.hs +++ b/Web/Scotty/Cookie.hs @@ -69,7 +69,6 @@ module Web.Scotty.Cookie ( import Control.Arrow (first, (***)) import Control.Monad ( liftM ) import Data.Char (toLower, isDigit) --- import Data.Monoid (mempty, mappend, mconcat) import Data.Word (Word8) import Data.Ratio (numerator, denominator) import Data.Maybe (isJust) From cb0372c5a2887a8a1b33cd661f66ac7c67fc1ddc Mon Sep 17 00:00:00 2001 From: Marco Zocca Date: Sat, 10 Jun 2023 16:25:00 +0200 Subject: [PATCH 3/9] add Web.Scotty.Cookie tests --- test/Web/ScottySpec.hs | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) diff --git a/test/Web/ScottySpec.hs b/test/Web/ScottySpec.hs index 2fcb6c54..2b47d242 100644 --- a/test/Web/ScottySpec.hs +++ b/test/Web/ScottySpec.hs @@ -16,6 +16,7 @@ import qualified Control.Exception as E import Web.Scotty as Scotty hiding (get, post, put, patch, delete, request, options) import qualified Web.Scotty as Scotty +import qualified Web.Scotty.Cookie as SC (getCookie, setSimpleCookie, deleteCookie) #if !defined(mingw32_HOST_OS) import Control.Concurrent.Async (withAsync) @@ -171,6 +172,25 @@ spec = do it "stops the execution of an action" $ do get "/scotty" `shouldRespondWith` 400 + describe "setSimpleCookie" $ do + withApp (Scotty.get "/scotty" $ SC.setSimpleCookie "foo" "bar") $ do + it "responds with a Set-Cookie header" $ do + get "/scotty" `shouldRespondWith` 200 {matchHeaders = ["Set-Cookie" <:> "foo=bar"]} + + describe "getCookie" $ do + withApp (Scotty.get "/scotty" $ do + mt <- SC.getCookie "foo" + case mt of + Just "bar" -> Scotty.status status200 + _ -> Scotty.status status400 ) $ do + it "finds the right cookie in the request headers" $ do + request "GET" "/scotty" [("Cookie", "foo=bar")] "" `shouldRespondWith` 200 + + describe "deleteCookie" $ do + withApp (Scotty.get "/scotty" $ SC.deleteCookie "foo") $ do + it "responds with a Set-Cookie header with expiry date Jan 1, 1970" $ do + get "/scotty" `shouldRespondWith` 200 {matchHeaders = ["Set-Cookie" <:> "foo=; Expires=Thu, 01-Jan-1970 00:00:00 GMT"]} + -- Unix sockets not available on Windows #if !defined(mingw32_HOST_OS) describe "scottySocket" . From e269357f4dd1f21b51e610659eebe2cc75cd523e Mon Sep 17 00:00:00 2001 From: Marco Zocca Date: Sun, 11 Jun 2023 10:24:09 +0200 Subject: [PATCH 4/9] revert to importing cookie, add docs and fix re-exports --- Web/Scotty/Cookie.hs | 287 +++++-------------------------------------- scotty.cabal | 2 +- 2 files changed, 30 insertions(+), 259 deletions(-) diff --git a/Web/Scotty/Cookie.hs b/Web/Scotty/Cookie.hs index 02c91a1b..14cea6d6 100644 --- a/Web/Scotty/Cookie.hs +++ b/Web/Scotty/Cookie.hs @@ -1,15 +1,14 @@ {-| Module : Web.Scotty.Cookie Copyright : (c) 2014, 2015 Mārtiņš Mačs, - (c) 2010, 2023 Michael Snoyman, (c) 2023 Marco Zocca License : BSD-3-Clause -Maintainer : +Maintainer : Stability : experimental Portability : GHC -This module provides utilities for adding cookie support inside @scotty@ applications. Most code has been adapted from 'cookie' and 'scotty-cookie'. +This module provides utilities for adding cookie support inside @scotty@ applications. Most code has been adapted from 'scotty-cookie'. == Example @@ -51,51 +50,48 @@ module Web.Scotty.Cookie ( , getCookies -- * Delete a cookie , deleteCookie - -- * Helpers and advanced interface + -- * Helpers and advanced interface (re-exported from 'cookie') , CookiesText , makeSimpleCookie + -- ** cookie configuration , SetCookie - , defaultSetCookie - , parseSetCookie - , renderCookies - , renderCookiesBuilder - , renderCookiesText + , setCookieName + , setCookieValue + , setCookiePath + , setCookieExpires + , setCookieMaxAge + , setCookieDomain + , setCookieHttpOnly + , setCookieSecure + , setCookieSameSite , SameSiteOption , sameSiteNone , sameSiteLax , sameSiteStrict + , defaultSetCookie + -- ** parsing and rendering + , parseSetCookie + , renderCookies + , renderCookiesText ) where -import Control.Arrow (first, (***)) -import Control.Monad ( liftM ) -import Data.Char (toLower, isDigit) -import Data.Word (Word8) -import Data.Ratio (numerator, denominator) -import Data.Maybe (isJust) - -- bytestring -import qualified Data.ByteString as S -import qualified Data.ByteString.Char8 as S8 -import Data.ByteString.Builder (Builder, byteString, char8, toLazyByteString) -import Data.ByteString.Builder.Extra (byteStringCopy) +import Data.ByteString.Builder (toLazyByteString) import qualified Data.ByteString.Lazy as BSL (toStrict) +-- cookie +import Web.Cookie (SetCookie, setCookieName , setCookieValue, setCookiePath, setCookieExpires, setCookieMaxAge, setCookieDomain, setCookieHttpOnly, setCookieSecure, setCookieSameSite, parseSetCookie, renderCookies, renderCookiesText, renderSetCookie, defaultSetCookie, CookiesText, parseCookiesText, SameSiteOption, sameSiteStrict, sameSiteNone, sameSiteLax) -- scotty import Web.Scotty.Trans (ActionT, ScottyError(..), addHeader, header) -- time -import Data.Time (UTCTime (UTCTime), toGregorian, fromGregorian, formatTime, parseTimeM, defaultTimeLocale) -import Data.Time.Clock (DiffTime, secondsToDiffTime) import Data.Time.Clock.POSIX ( posixSecondsToUTCTime ) -- text import Data.Text (Text) -import qualified Data.Text.Lazy.Encoding as TL -import Data.Text.Encoding (encodeUtf8Builder, decodeUtf8With, encodeUtf8) -import Data.Text.Encoding.Error (lenientDecode) --- deepseq -import Control.DeepSeq (NFData (rnf)) - +import qualified Data.Text.Encoding as T (encodeUtf8) +import qualified Data.Text.Lazy.Encoding as TL (encodeUtf8, decodeUtf8) +-- | Set a cookie, with full access to its options (see 'SetCookie') setCookie :: (Monad m, ScottyError e) => SetCookie -> ActionT e m () @@ -109,7 +105,7 @@ setSimpleCookie :: (Monad m, ScottyError e) -> ActionT e m () setSimpleCookie n v = setCookie $ makeSimpleCookie n v - +-- | Lookup one cookie name getCookie :: (Monad m, ScottyError e) => Text -- ^ name -> ActionT e m (Maybe Text) @@ -119,10 +115,10 @@ getCookie c = lookup c <$> getCookies -- | Returns all cookies getCookies :: (Monad m, ScottyError e) => ActionT e m CookiesText -getCookies = liftM (maybe [] parse) $ header "Cookie" +getCookies = (maybe [] parse) <$> header "Cookie" where parse = parseCookiesText . BSL.toStrict . TL.encodeUtf8 - +-- | Browsers don't directly delete a cookie, but setting its expiry to a past date (e.g. the UNIX epoch) and it value to the empty string ensures that the cookie will be invalidated (when it will be actually deleted by the browser seems to be implementation-dependent). deleteCookie :: (Monad m, ScottyError e) => Text -- ^ name -> ActionT e m () @@ -133,232 +129,7 @@ deleteCookie c = setCookie $ (makeSimpleCookie c "") { setCookieExpires = Just $ makeSimpleCookie :: Text -- ^ name -> Text -- ^ value -> SetCookie -makeSimpleCookie n v = defaultSetCookie { setCookieName = encodeUtf8 n - , setCookieValue = encodeUtf8 v +makeSimpleCookie n v = defaultSetCookie { setCookieName = T.encodeUtf8 n + , setCookieValue = T.encodeUtf8 v } - --- | 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)] - --- | 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.break (== w) s - in (x, S.drop 1 y) - -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) - --- | 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@ - } - 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) = - 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` () - --- | 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 - [ 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" - ] - -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 - Just "None" -> Just None - _ -> 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 . 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/scotty.cabal b/scotty.cabal index b626015f..8059d979 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -79,8 +79,8 @@ Library blaze-builder >= 0.3.3.0 && < 0.5, bytestring >= 0.10.0.2 && < 0.12, case-insensitive >= 1.0.0.1 && < 1.3, + cookie >= 0.4, data-default-class >= 0.0.1 && < 0.2, - deepseq >= 1.4, exceptions >= 0.7 && < 0.11, http-types >= 0.9.1 && < 0.13, monad-control >= 1.0.0.3 && < 1.1, From 5687e47af515df93525a342b4e64a362b68739c1 Mon Sep 17 00:00:00 2001 From: Marco Zocca Date: Sun, 11 Jun 2023 10:29:17 +0200 Subject: [PATCH 5/9] fix doc around deleteCookie --- Web/Scotty/Cookie.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Web/Scotty/Cookie.hs b/Web/Scotty/Cookie.hs index 14cea6d6..f182e04c 100644 --- a/Web/Scotty/Cookie.hs +++ b/Web/Scotty/Cookie.hs @@ -118,7 +118,7 @@ getCookies :: (Monad m, ScottyError e) getCookies = (maybe [] parse) <$> header "Cookie" where parse = parseCookiesText . BSL.toStrict . TL.encodeUtf8 --- | Browsers don't directly delete a cookie, but setting its expiry to a past date (e.g. the UNIX epoch) and it value to the empty string ensures that the cookie will be invalidated (when it will be actually deleted by the browser seems to be implementation-dependent). +-- | Browsers don't directly delete a cookie, but setting its expiry to a past date (e.g. the UNIX epoch) ensures that the cookie will be invalidated (whether and when it will be actually deleted by the browser seems to be browser-dependent). deleteCookie :: (Monad m, ScottyError e) => Text -- ^ name -> ActionT e m () From 6ed08510d5a056fe62f1f6dc123ccefe39f85d83 Mon Sep 17 00:00:00 2001 From: Marco Zocca Date: Mon, 12 Jun 2023 12:43:15 +0200 Subject: [PATCH 6/9] fewer re-exports --- Web/Scotty/Cookie.hs | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) diff --git a/Web/Scotty/Cookie.hs b/Web/Scotty/Cookie.hs index f182e04c..629e2bcc 100644 --- a/Web/Scotty/Cookie.hs +++ b/Web/Scotty/Cookie.hs @@ -55,6 +55,7 @@ module Web.Scotty.Cookie ( , makeSimpleCookie -- ** cookie configuration , SetCookie + , defaultSetCookie , setCookieName , setCookieValue , setCookiePath @@ -68,18 +69,13 @@ module Web.Scotty.Cookie ( , sameSiteNone , sameSiteLax , sameSiteStrict - , defaultSetCookie - -- ** parsing and rendering - , parseSetCookie - , renderCookies - , renderCookiesText ) where -- bytestring import Data.ByteString.Builder (toLazyByteString) import qualified Data.ByteString.Lazy as BSL (toStrict) -- cookie -import Web.Cookie (SetCookie, setCookieName , setCookieValue, setCookiePath, setCookieExpires, setCookieMaxAge, setCookieDomain, setCookieHttpOnly, setCookieSecure, setCookieSameSite, parseSetCookie, renderCookies, renderCookiesText, renderSetCookie, defaultSetCookie, CookiesText, parseCookiesText, SameSiteOption, sameSiteStrict, sameSiteNone, sameSiteLax) +import Web.Cookie (SetCookie, setCookieName , setCookieValue, setCookiePath, setCookieExpires, setCookieMaxAge, setCookieDomain, setCookieHttpOnly, setCookieSecure, setCookieSameSite, renderSetCookie, defaultSetCookie, CookiesText, parseCookiesText, SameSiteOption, sameSiteStrict, sameSiteNone, sameSiteLax) -- scotty import Web.Scotty.Trans (ActionT, ScottyError(..), addHeader, header) -- time From 5ec6608e47df7a04c2ef299d62409ca7dbfded1c Mon Sep 17 00:00:00 2001 From: Marco Zocca Date: Thu, 15 Jun 2023 08:49:07 +0200 Subject: [PATCH 7/9] relax lower bound on time --- scotty.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/scotty.cabal b/scotty.cabal index 8059d979..235cc334 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -88,7 +88,7 @@ Library network >= 2.6.0.2 && < 3.2, regex-compat >= 0.95.1 && < 0.96, text >= 0.11.3.1 && < 2.1, - time >= 1.11, + time >= 1.8, transformers >= 0.3.0.0 && < 0.7, transformers-base >= 0.4.1 && < 0.5, transformers-compat >= 0.4 && < 0.8, From ca588b2b7dc7de7dd591d8184f8a7ccb1b53fa40 Mon Sep 17 00:00:00 2001 From: Marco Zocca Date: Thu, 15 Jun 2023 08:57:27 +0200 Subject: [PATCH 8/9] adapt scotty-cookies example program to use new module as well --- examples/cookies.hs | 27 ++++----------------------- 1 file changed, 4 insertions(+), 23 deletions(-) diff --git a/examples/cookies.hs b/examples/cookies.hs index d3bd4521..39669dbb 100644 --- a/examples/cookies.hs +++ b/examples/cookies.hs @@ -1,6 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} --- This examples requires you to: cabal install cookie --- and: cabal install blaze-html +-- This examples requires you to: cabal install blaze-html module Main (main) where import Control.Monad (forM_) @@ -14,23 +13,7 @@ import qualified Text.Blaze.Html5 as H import Text.Blaze.Html5.Attributes import Text.Blaze.Html.Renderer.Text (renderHtml) import Web.Scotty -import Web.Cookie - -makeCookie :: BS.ByteString -> BS.ByteString -> SetCookie -makeCookie n v = def { setCookieName = n, setCookieValue = v } - -renderSetCookie' :: SetCookie -> Text -renderSetCookie' = T.decodeUtf8 . B.toLazyByteString . renderSetCookie - -setCookie :: BS.ByteString -> BS.ByteString -> ActionM () -setCookie n v = setHeader "Set-Cookie" (renderSetCookie' (makeCookie n v)) - -getCookies :: ActionM (Maybe CookiesText) -getCookies = - fmap (fmap (parseCookiesText . lazyToStrict . T.encodeUtf8)) $ - header "Cookie" - where - lazyToStrict = BS.concat . BSL.toChunks +import Web.Scotty.Cookie (CookiesText, setSimpleCookie, getCookies) renderCookiesTable :: CookiesText -> H.Html renderCookiesTable cs = @@ -48,9 +31,7 @@ main = scotty 3000 $ do get "/" $ do cookies <- getCookies html $ renderHtml $ do - case cookies of - Just cs -> renderCookiesTable cs - Nothing -> return () + renderCookiesTable cookies H.form H.! method "post" H.! action "/set-a-cookie" $ do H.input H.! type_ "text" H.! name "name" H.input H.! type_ "text" H.! name "value" @@ -59,5 +40,5 @@ main = scotty 3000 $ do post "/set-a-cookie" $ do name' <- param "name" value' <- param "value" - setCookie name' value' + setSimpleCookie name' value' redirect "/" From dbca35ac313bcfc22730c1f4824530882ff5f3b5 Mon Sep 17 00:00:00 2001 From: Marco Zocca Date: Thu, 15 Jun 2023 21:43:33 +0200 Subject: [PATCH 9/9] scotty-cookies : remove unneeded imports --- examples/cookies.hs | 5 ----- 1 file changed, 5 deletions(-) diff --git a/examples/cookies.hs b/examples/cookies.hs index 39669dbb..387e2efb 100644 --- a/examples/cookies.hs +++ b/examples/cookies.hs @@ -3,11 +3,6 @@ module Main (main) where import Control.Monad (forM_) -import Data.Text.Lazy (Text) -import qualified Data.Text.Lazy.Encoding as T -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as BSL -import qualified Blaze.ByteString.Builder as B import qualified Text.Blaze.Html5 as H import Text.Blaze.Html5.Attributes