add Web.Scotty.Cookie

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 [ \"\<html\>\<body\>\"
+                       , 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
+                                        }
+

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 "/"

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,

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" .