Add Snap.Cookie with a Cookie type using lenses

snap-core.cabal

@@ -106,6 +106,7 @@ Library
     build-depends: old-locale >= 1 && <2
 
   exposed-modules:
+    Snap.Cookie,
     Snap.Core,
     Snap.Internal.Core,
     Snap.Internal.Debug,
@@ -136,11 +137,13 @@ Library
     bytestring-builder        >= 0.10.4  && < 0.11,
     case-insensitive          >= 1.1     && < 1.3,
     containers                >= 0.3     && < 1.0,
+    data-default              >= 0.7.1   && < 1.0,
     directory                 >= 1       && < 2,
     filepath                  >= 1.1     && < 2.0,
     lifted-base               >= 0.1     && < 0.3,
     io-streams                >= 1.3     && < 1.6,
     hashable                  >= 1.2.0.6 && < 1.3,
+    lens                      >= 3.0     && < 5.0,
     monad-control             >= 1.0     && < 1.1,
     mtl                       >= 2.0     && < 2.3,
     random                    >= 1       && < 2,
@@ -206,6 +209,7 @@ Test-suite testsuite
     build-depends: old-locale >= 1 && <2
 
   other-modules:
+    Snap.Cookie,
     Snap.Core,
     Snap.Internal.Debug,
     Snap.Internal.Http.Types,
@@ -246,11 +250,13 @@ Test-suite testsuite
     bytestring-builder,
     case-insensitive,
     containers,
+    data-default,
     directory,
     filepath,
     hashable,
     lifted-base,
     io-streams,
+    lens,
     monad-control,
     mtl,
     random,

src/Snap/Cookie.hs

@@ -0,0 +1,55 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+------------------------------------------------------------------------------
+-- | New Cookie implementation.
+
+module Snap.Cookie where
+
+------------------------------------------------------------------------------
+import           Control.Lens.TH (makeLenses)
+import           Data.ByteString (ByteString, empty)
+import           Data.Default
+import           Data.Time (UTCTime)
+
+
+------------------------------------------------------------------------------
+-- | SameSite strictness policy.
+data SameSite = Lax | Strict
+                deriving (Eq, Show)
+
+
+------------------------------------------------------------------------------
+-- | A datatype representing an HTTP cookie.
+data Cookie = Cookie {
+      -- | The name of the cookie.
+      _cookieName     :: !ByteString
+
+      -- | The cookie's string value.
+    , _cookieValue    :: !ByteString
+
+      -- | The cookie's expiration value, if it has one.
+    , _cookieExpires  :: !(Maybe UTCTime)
+
+      -- | The cookie's \"domain\" value, if it has one.
+    , _cookieDomain   :: !(Maybe ByteString)
+
+      -- | The cookie path.
+    , _cookiePath     :: !(Maybe ByteString)
+
+      -- | Tag as secure cookie?
+    , _cookieSecure   :: !Bool
+
+      -- | HTTP only?
+    , _cookieHttpOnly :: !Bool
+
+      -- | SameSite strictness policy.
+    , _cookieSameSite :: !(Maybe SameSite)
+} deriving (Eq, Show)
+
+
+makeLenses ''Cookie
+
+
+------------------------------------------------------------------------------
+instance Default Cookie where
+  def = Cookie empty empty Nothing Nothing Nothing False False Nothing

src/Snap/Core.hs

@@ -163,7 +163,7 @@ module Snap.Core
 
 ------------------------------------------------------------------------------
 import           Snap.Internal.Core       (EscapeHttpHandler, EscapeSnap (..), MonadSnap (..), NoHandlerException (..), Snap, addToOutput, bracketSnap, catchFinishWith, dir, escapeHttp, expireCookie, extendTimeout, finishWith, getCookie, getParam, getParams, getPostParam, getPostParams, getQueryParam, getQueryParams, getRequest, getResponse, getTimeoutModifier, getsRequest, getsResponse, ifTop, ipHeaderFilter, ipHeaderFilter', localRequest, logError, method, methods, modifyRequest, modifyResponse, modifyTimeout, pass, path, pathArg, putRequest, putResponse, readCookie, readRequestBody, redirect, redirect', runRequestBody, runSnap, sendFile, sendFilePartial, setTimeout, terminateConnection, transformRequestBody, withRequest, withResponse, writeBS, writeBuilder, writeLBS, writeLazyText, writeText)
-import           Snap.Internal.Http.Types (Cookie (..), HasHeaders (..), HttpVersion, Method (..), Params, Request (rqClientAddr, rqClientPort, rqContentLength, rqContextPath, rqCookies, rqHeaders, rqHostName, rqIsSecure, rqLocalHostname, rqMethod, rqParams, rqPathInfo, rqPostParams, rqQueryParams, rqQueryString, rqServerAddr, rqServerPort, rqURI, rqVersion), Response (rspStatus, rspStatusReason), addHeader, addResponseCookie, clearContentLength, deleteHeader, deleteResponseCookie, emptyResponse, formatHttpTime, getHeader, getResponseCookie, getResponseCookies, listHeaders, modifyResponseBody, modifyResponseCookie, parseHttpTime, rqModifyParams, rqParam, rqPostParam, rqQueryParam, rqRemoteAddr, rqRemotePort, rqSetParam, setContentLength, setContentType, setHeader, setResponseBody, setResponseCode, setResponseStatus)
+import           Snap.Internal.Http.Types (Cookie (..), HasHeaders (..), HttpVersion, Method (..), Params, Request (rqClientAddr, rqClientPort, rqContentLength, rqContextPath, rqHeaders, rqHostName, rqIsSecure, rqLocalHostname, rqMethod, rqParams, rqPathInfo, rqPostParams, rqQueryParams, rqQueryString, rqServerAddr, rqServerPort, rqURI, rqVersion), Response (rspStatus, rspStatusReason), addHeader, addResponseCookie, clearContentLength, deleteHeader, deleteResponseCookie, emptyResponse, formatHttpTime, getHeader, getResponseCookie, getResponseCookies, listHeaders, modifyResponseBody, modifyResponseCookie, parseHttpTime, rqCookies, rqModifyParams, rqParam, rqPostParam, rqQueryParam, rqRemoteAddr, rqRemotePort, rqSetParam, setContentLength, setContentType, setHeader, setResponseBody, setResponseCode, setResponseStatus)
 import           Snap.Internal.Instances  ()
 import           Snap.Internal.Parsing    (buildUrlEncoded, parseUrlEncoded, printUrlEncoded, urlDecode, urlEncode, urlEncodeBuilder)
 import           Snap.Internal.Routing    (route, routeLocal)

src/Snap/Internal/Core.hs

@@ -128,7 +128,8 @@ import qualified Data.ByteString.Internal           as S (accursedUnutterablePer
 #endif
 ------------------------------------------------------------------------------
 import qualified Data.Readable                      as R
-import           Snap.Internal.Http.Types           (Cookie (..), HasHeaders (..), HttpVersion, Method (..), Params, Request (..), Response (..), ResponseBody (..), StreamProc, addHeader, addResponseCookie, clearContentLength, deleteHeader, deleteResponseCookie, emptyResponse, formatHttpTime, formatLogTime, getHeader, getResponseCookie, getResponseCookies, listHeaders, modifyResponseBody, modifyResponseCookie, normalizeMethod, parseHttpTime, rqModifyParams, rqParam, rqPostParam, rqQueryParam, rqSetParam, rspBodyMap, rspBodyToEnum, setContentLength, setContentType, setHeader, setResponseBody, setResponseCode, setResponseStatus, statusReasonMap)
+import qualified Snap.Cookie                        as C
+import           Snap.Internal.Http.Types           (Cookie (..), IsCookie (..), HasHeaders (..), HttpVersion, Method (..), Params, Request (..), Response (..), ResponseBody (..), StreamProc, rqCookies, addHeader, addResponseCookie, clearContentLength, deleteHeader, deleteResponseCookie, emptyResponse, formatHttpTime, formatLogTime, getHeader, getResponseCookie, getResponseCookies, listHeaders, modifyResponseBody, modifyResponseCookie, normalizeMethod, parseHttpTime, rqModifyParams, rqParam, rqPostParam, rqQueryParam, rqSetParam, rspBodyMap, rspBodyToEnum, setContentLength, setContentType, setHeader, setResponseBody, setResponseCode, setResponseStatus, statusReasonMap)
 import           Snap.Internal.Parsing              (urlDecode)
 import qualified Snap.Types.Headers                 as H
 ------------------------------------------------------------------------------
@@ -1972,11 +1973,11 @@ getQueryParams = getRequest >>= return . rqQueryParams
 --
 -- Just (Cookie {cookieName = "name", cookieValue = "value", ...})
 -- @
-getCookie :: MonadSnap m
+getCookie :: (MonadSnap m, IsCookie a)
           => ByteString
-          -> m (Maybe Cookie)
+          -> m (Maybe a)
 getCookie name = withRequest $
-    return . listToMaybe . filter (\c -> cookieName c == name) . rqCookies
+    return . listToMaybe . filter (\c -> C._cookieName (fromCookie c) == name) . rqCookies
 
 
 ------------------------------------------------------------------------------

src/Snap/Internal/Http/Types.hs

@@ -59,6 +59,7 @@ import           Foreign.Marshal.Alloc      (mallocBytes)
 #endif
 
 ------------------------------------------------------------------------------
+import qualified Snap.Cookie  as C
 import           Snap.Types.Headers         (Headers)
 import qualified Snap.Types.Headers         as H
 
@@ -244,6 +245,19 @@ normalizeMethod m               = m
 type HttpVersion = (Int,Int)
 
 
+------------------------------------------------------------------------------
+-- | Internal type class for converting cookies to and from the most
+-- generic form
+class IsCookie a where
+    fromCookie :: a -> C.Cookie
+    toCookie   :: C.Cookie -> a
+
+
+instance IsCookie C.Cookie where
+    fromCookie = id
+    toCookie = id
+
+
 ------------------------------------------------------------------------------
 -- | A datatype representing an HTTP cookie.
 data Cookie = Cookie {
@@ -270,6 +284,11 @@ data Cookie = Cookie {
 } deriving (Eq, Show)
 
 
+instance IsCookie Cookie where
+     fromCookie (Cookie n v e d p s h) = C.Cookie n v e d p s h Nothing
+     toCookie (C.Cookie n v e d p s h _) = Cookie n v e d p s h
+
+
 ------------------------------------------------------------------------------
 -- | A type alias for the HTTP parameters mapping. Each parameter
 -- key maps to a list of 'ByteString' values; if a parameter is specified
@@ -440,19 +459,7 @@ data Request = Request
       -- @
     , rqVersion       :: {-# UNPACK #-} !HttpVersion
 
-      -- | Returns a list of the cookies that came in from the HTTP request
-      -- headers.
-      --
-      -- Example:
-      --
-      -- @
-      -- ghci> :set -XOverloadedStrings
-      -- ghci> import qualified "Snap.Test" as T
-      -- ghci> import qualified "Data.Map" as M
-      -- ghci> rqCookies \`fmap\` T.buildRequest (T.get "\/foo\/bar" M.empty)
-      -- []
-      -- @
-    , rqCookies       :: [Cookie]
+    , rqCookies_       :: [C.Cookie]
 
       -- | Handlers can be hung on a @URI@ \"entry point\"; this is called the
       -- \"context path\". If a handler is hung on the context path
@@ -587,6 +594,22 @@ data Request = Request
     }
 
 
+-- | Returns a list of the cookies that came in from the HTTP request
+-- headers.
+--
+-- Example:
+--
+-- @
+-- ghci> :set -XOverloadedStrings
+-- ghci> import qualified "Snap.Test" as T
+-- ghci> import qualified "Data.Map" as M
+-- ghci> rqCookies \`fmap\` T.buildRequest (T.get "\/foo\/bar" M.empty)
+-- []
+-- @
+rqCookies :: IsCookie a => Request -> [a]
+rqCookies rq = map toCookie $ rqCookies_ rq
+
+
 ------------------------------------------------------------------------------
 instance Show Request where
   show r = concat [ method, " ", uri, " HTTP/", version, "\n"
@@ -612,7 +635,7 @@ instance Show Request where
                       map (\ (a,b) -> S.unpack a ++ ": " ++ show b)
                       (Map.toAscList $ rqParams r)
       cookies       = showFlds "\ncookies: " "\n         " $
-                      map show (rqCookies r)
+                      map show (rqCookies_ r)
 
       showFlds header delim lst
                     = if not . null $ lst then header ++ (intercalate delim lst)
@@ -672,7 +695,7 @@ rspBodyToEnum (SendFile fp (Just (start, end))) = \out ->
 -- | Represents an HTTP response.
 data Response = Response
     { rspHeaders            :: Headers
-    , rspCookies            :: Map ByteString Cookie
+    , rspCookies            :: Map ByteString C.Cookie
 
       -- | We will need to inspect the content length no matter what, and
       --   looking up \"content-length\" in the headers and parsing the number
@@ -1031,15 +1054,17 @@ setContentType = setHeader "Content-Type"
 --
 -- TODO: Remove duplication. This function is copied from
 -- snap-server/Snap.Internal.Http.Server.Session.
-cookieToBS :: Cookie -> ByteString
-cookieToBS (Cookie k v mbExpTime mbDomain mbPath isSec isHOnly) = cookie
+cookieToBS :: C.Cookie -> ByteString
+cookieToBS (C.Cookie k v mbExpTime mbDomain mbPath isSec isHOnly ss) = cookie
   where
-    cookie = S.concat [k, "=", v, path, exptime, domain, secure, hOnly]
+    cookie = S.concat [k, "=", v, path, exptime, domain, secure, hOnly, sSite]
     path = maybe "" (S.append "; path=") mbPath
     domain = maybe "" (S.append "; domain=") mbDomain
     exptime = maybe "" (S.append "; expires=" . fmt) mbExpTime
     secure = if isSec then "; Secure" else ""
     hOnly = if isHOnly then "; HttpOnly" else ""
+    sSite = maybe "" (\x -> case x of C.Lax -> "; SameSite=Lax"
+                                      C.Strict -> "; SameSite=Strict") ss
 
     -- TODO: 'formatHttpTime' uses "DD MMM YYYY" instead of "DD-MMM-YYYY",
     -- unlike the code in 'Snap.Internal.Http.Server.Session'. Is this form
@@ -1073,12 +1098,14 @@ renderCookies r hdrs
 -- ghci> 'getResponseCookie' \"name\" $ 'addResponseCookie' cookie 'emptyResponse'
 -- Just (Cookie {cookieName = \"name\", cookieValue = \"value\", ...})
 -- @
-addResponseCookie :: Cookie            -- ^ cookie value
+addResponseCookie :: IsCookie a
+                  => a                 -- ^ cookie value
                   -> Response          -- ^ response to modify
                   -> Response
-addResponseCookie ck@(Cookie k _ _ _ _ _ _) r = r { rspCookies = cks' }
+addResponseCookie ck r = r { rspCookies = cks' }
   where
-    cks'= Map.insert k ck $ rspCookies r
+    ck' = fromCookie ck
+    cks'= Map.insert (C._cookieName ck') ck' $ rspCookies r
 {-# INLINE addResponseCookie #-}
 
 
@@ -1092,10 +1119,11 @@ addResponseCookie ck@(Cookie k _ _ _ _ _ _) r = r { rspCookies = cks' }
 -- ghci> 'getResponseCookie' \"cookie-name\" 'emptyResponse'
 -- Nothing
 -- @
-getResponseCookie :: ByteString            -- ^ cookie name
+getResponseCookie :: IsCookie a
+                  => ByteString            -- ^ cookie name
                   -> Response              -- ^ response to query
-                  -> Maybe Cookie
-getResponseCookie cn r = Map.lookup cn $ rspCookies r
+                  -> Maybe a
+getResponseCookie cn r = fmap toCookie $ Map.lookup cn $ rspCookies r
 {-# INLINE getResponseCookie #-}
 
 
@@ -1107,9 +1135,10 @@ getResponseCookie cn r = Map.lookup cn $ rspCookies r
 -- ghci> 'getResponseCookies' 'emptyResponse'
 -- []
 -- @
-getResponseCookies :: Response              -- ^ response to query
-                   -> [Cookie]
-getResponseCookies = Map.elems . rspCookies
+getResponseCookies :: IsCookie a
+                   => Response              -- ^ response to query
+                   -> [a]
+getResponseCookies = map toCookie . Map.elems . rspCookies
 {-# INLINE getResponseCookies #-}
 
 
@@ -1157,8 +1186,9 @@ deleteResponseCookie cn r = r { rspCookies = cks' }
 -- ghci> 'getResponseCookie' \"name\" rsp\'
 -- Just (Cookie {cookieName = \"name\", ...})
 -- @
-modifyResponseCookie :: ByteString          -- ^ cookie name
-                     -> (Cookie -> Cookie)  -- ^ modifier function
+modifyResponseCookie :: IsCookie a
+                     => ByteString          -- ^ cookie name
+                     -> (a -> a)            -- ^ modifier function
                      -> Response            -- ^ response to modify
                      -> Response
 modifyResponseCookie cn f r = maybe r modify $ getResponseCookie cn r

src/Snap/Internal/Test/RequestBuilder.hs

@@ -52,9 +52,10 @@ import           Data.CaseInsensitive       (CI, original)
 import qualified Data.Map                   as Map
 import qualified Data.Vector                as V
 import           Data.Word                  (Word8)
-import           Snap.Core                  (Cookie (Cookie), Method (DELETE, GET, HEAD, POST, PUT), MonadSnap, Params, Request (rqContentLength, rqContextPath, rqCookies, rqHeaders, rqHostName, rqIsSecure, rqMethod, rqParams, rqPathInfo, rqPostParams, rqQueryParams, rqQueryString, rqURI, rqVersion), Response, Snap, deleteHeader, formatHttpTime, getHeader, parseUrlEncoded, printUrlEncoded, runSnap)
+import           Snap.Cookie                (Cookie (..))
+import           Snap.Core                  (Method (DELETE, GET, HEAD, POST, PUT), MonadSnap, Params, Request (rqContentLength, rqContextPath, rqHeaders, rqHostName, rqIsSecure, rqMethod, rqParams, rqPathInfo, rqPostParams, rqQueryParams, rqQueryString, rqURI, rqVersion), Response, Snap, deleteHeader, formatHttpTime, getHeader, parseUrlEncoded, printUrlEncoded, runSnap)
 import           Snap.Internal.Core         (evalSnap, fixupResponse)
-import           Snap.Internal.Http.Types   (Request (Request, rqBody), Response (rspBody, rspContentLength), rspBodyToEnum)
+import           Snap.Internal.Http.Types   (IsCookie (fromCookie), Request (Request, rqBody), Response (rspBody, rspContentLength), rspBodyToEnum, rqCookies_)
 import qualified Snap.Internal.Http.Types   as H
 import qualified Snap.Types.Headers         as H
 import qualified System.IO.Streams          as Streams
@@ -580,18 +581,18 @@ addHeader k v = rModify (H.addHeader k v)
 -- sn="localhost" c=127.0.0.1:60000 s=127.0.0.1:8080 ctx=\/ clen=n\/a
 -- cookies: Cookie {cookieName = "name", cookieValue = "value", ...}
 -- @
-addCookies :: (Monad m) => [Cookie] -> RequestBuilder m ()
+addCookies :: (Monad m, IsCookie a) => [a] -> RequestBuilder m ()
 addCookies cookies = do
-    rModify $ \rq -> rq { rqCookies = rqCookies rq ++ cookies }
-    allCookies <- liftM rqCookies rGet
+    rModify $ \rq -> rq { rqCookies_ = rqCookies_ rq ++ map fromCookie cookies }
+    allCookies <- liftM rqCookies_ rGet
     let cstr = map cookieToBS allCookies
     setHeader "Cookie" $ S.intercalate "; " cstr
 
 
 ------------------------------------------------------------------------------
 -- | Convert 'Cookie' into 'ByteString' for output.
 cookieToBS :: Cookie -> ByteString
-cookieToBS (Cookie k v !_ !_ !_ !_ !_) = cookie
+cookieToBS (Cookie k v !_ !_ !_ !_ !_ !_) = cookie
   where
     cookie  = S.concat [k, "=", v]