diff --git a/Web/Scotty/Cookie.hs b/Web/Scotty/Cookie.hs new file mode 100644 index 00000000..629e2bcc --- /dev/null +++ b/Web/Scotty/Cookie.hs @@ -0,0 +1,131 @@ +{-| +Module : Web.Scotty.Cookie +Copyright : (c) 2014, 2015 Mārtiņš Mačs, + (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 '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 (re-exported from 'cookie') + , CookiesText + , makeSimpleCookie + -- ** cookie configuration + , SetCookie + , defaultSetCookie + , setCookieName + , setCookieValue + , setCookiePath + , setCookieExpires + , setCookieMaxAge + , setCookieDomain + , setCookieHttpOnly + , setCookieSecure + , setCookieSameSite + , SameSiteOption + , sameSiteNone + , sameSiteLax + , sameSiteStrict + ) 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, renderSetCookie, defaultSetCookie, CookiesText, parseCookiesText, SameSiteOption, sameSiteStrict, sameSiteNone, sameSiteLax) +-- scotty +import Web.Scotty.Trans (ActionT, ScottyError(..), addHeader, header) +-- time +import Data.Time.Clock.POSIX ( posixSecondsToUTCTime ) +-- text +import Data.Text (Text) +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 () +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 + +-- | Lookup one cookie name +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 = (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) 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 () +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 = T.encodeUtf8 n + , setCookieValue = T.encodeUtf8 v + } + diff --git a/examples/cookies.hs b/examples/cookies.hs index d3bd4521..387e2efb 100644 --- a/examples/cookies.hs +++ b/examples/cookies.hs @@ -1,36 +1,14 @@ {-# 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_) -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 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 +26,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 +35,5 @@ main = scotty 3000 $ do post "/set-a-cookie" $ do name' <- param "name" value' <- param "value" - setCookie name' value' + setSimpleCookie name' value' redirect "/" diff --git a/scotty.cabal b/scotty.cabal index 7bb6242d..235cc334 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 @@ -78,6 +79,7 @@ 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, exceptions >= 0.7 && < 0.11, http-types >= 0.9.1 && < 0.13, @@ -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.8, transformers >= 0.3.0.0 && < 0.7, transformers-base >= 0.4.1 && < 0.5, transformers-compat >= 0.4 && < 0.8, 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" .