Add support for setting SameSite attribute in cookies

CHANGELOG.md

@@ -1,3 +1,8 @@
+7.7.0
+=====
+
+ - added support for specifying SameSite attribute
+
 7.6.0
 =====
 

happstack-server.cabal

@@ -1,5 +1,5 @@
 Name:                happstack-server
-Version:             7.6.1
+Version:             7.7.0
 Synopsis:            Web related tools and services.
 Description:         Happstack Server provides an HTTP server and a rich set of functions for routing requests, handling query parameters, generating responses, working with cookies, serving files, and more. For in-depth documentation see the Happstack Crash Course <http://happstack.com/docs/crashcourse/index.html>
 License:             BSD3

src/Happstack/Server/Cookie.hs

@@ -3,6 +3,7 @@
 module Happstack.Server.Cookie
     ( Cookie(..)
     , CookieLife(..)
+    , SameSite(..)
     , mkCookie
     , addCookie
     , addCookies
@@ -12,7 +13,7 @@ module Happstack.Server.Cookie
 
 import Control.Monad.Trans              (MonadIO(..))
 import Happstack.Server.Internal.Monads (FilterMonad, composeFilter)
-import Happstack.Server.Internal.Cookie (Cookie(..), CookieLife(..), calcLife, mkCookie, mkCookieHeader)
+import Happstack.Server.Internal.Cookie (Cookie(..), CookieLife(..), SameSite(..), calcLife, mkCookie, mkCookieHeader)
 import Happstack.Server.Types           (Response, addHeader)
 
 -- | Add the 'Cookie' to 'Response'.

src/Happstack/Server/Internal/Cookie.hs

@@ -4,6 +4,7 @@
 module Happstack.Server.Internal.Cookie
     ( Cookie(..)
     , CookieLife(..)
+    , SameSite(..)
     , calcLife
     , mkCookie
     , mkCookieHeader
@@ -44,6 +45,7 @@ data Cookie = Cookie
     , cookieValue   :: String
     , secure        :: Bool
     , httpOnly      :: Bool
+    , sameSite      :: SameSite
     } deriving(Show,Eq,Read,Typeable,Data)
 
 -- | Specify the lifetime of a cookie.
@@ -60,6 +62,31 @@ data CookieLife
     | Expired         -- ^ cookie already expired
       deriving (Eq, Ord, Read, Show, Typeable)
 
+-- | Options for specifying third party cookie behaviour.
+--
+-- Note that most or all web clients require the cookie to be secure if "none" is
+-- specified.
+data SameSite
+    = SameSiteLax
+    -- ^ The cookie is sent in first party contexts as well as linked requests initiated
+    -- from other contexts.
+    | SameSiteStrict
+    -- ^ The cookie is sent in first party contexts only.
+    | SameSiteNone
+    -- ^ The cookie is sent in first as well as third party contexts if the cookie is
+    -- secure.
+    | SameSiteNoValue
+    -- ^ The default; used if you do not wish a SameSite attribute present at all.
+      deriving (Eq, Ord, Typeable, Data, Show, Read)
+
+displaySameSite :: SameSite -> String
+displaySameSite ss =
+  case ss of
+    SameSiteLax     -> "SameSite=Lax"
+    SameSiteStrict  -> "SameSite=Strict"
+    SameSiteNone    -> "SameSite=None"
+    SameSiteNoValue -> ""
+
 -- convert 'CookieLife' to the argument needed for calling 'mkCookieHeader'
 calcLife :: CookieLife -> IO (Maybe (Int, UTCTime))
 calcLife Session = return Nothing
@@ -74,13 +101,14 @@ calcLife Expired =
 
 
 -- | Creates a cookie with a default version of 1, empty domain, a
--- path of "/", secure == False and httpOnly == False
+-- path of "/", secure == False, httpOnly == False and
+-- sameSite == SameSiteNoValue
 --
 -- see also: 'addCookie'
 mkCookie :: String  -- ^ cookie name
          -> String  -- ^ cookie value
          -> Cookie
-mkCookie key val = Cookie "1" "/" "" key val False False
+mkCookie key val = Cookie "1" "/" "" key val False False SameSiteNoValue
 
 -- | Set a Cookie in the Result.
 -- The values are escaped as per RFC 2109, but some browsers may
@@ -117,8 +145,8 @@ mkCookieHeader mLife cookie =
          (cookieName cookie++"="++s cookieValue):[ (k++v) | (k,v) <- l, "" /= v ]
       ++ (if secure   cookie then ["Secure"]   else [])
       ++ (if httpOnly cookie then ["HttpOnly"] else [])
-
-
+      ++ (if sameSite cookie /= SameSiteNoValue
+          then [displaySameSite . sameSite $ cookie] else [])
 
 -- | Not an supported api.  Takes a cookie header and returns
 -- either a String error message or an array of parsed cookies
@@ -142,7 +170,7 @@ cookiesParser = cookies
             val<-value
             path<-option "" $ try (cookieSep >> cookie_path)
             domain<-option "" $ try (cookieSep >> cookie_domain)
-            return $ Cookie ver path domain (low name) val False False
+            return $ Cookie ver path domain (low name) val False False SameSiteNoValue
           cookie_version = cookie_special "$Version"
           cookie_path = cookie_special "$Path"
           cookie_domain = cookie_special "$Domain"

tests/Happstack/Server/Tests.hs

@@ -41,24 +41,24 @@ cookieParserTest =
     "cookieParserTest" ~:
     [parseCookies "$Version=1;Cookie1=value1;$Path=\"/testpath\";$Domain=example.com;cookie2=value2"
         @?= (Right [
-            Cookie "1" "/testpath" "example.com" "cookie1" "value1" False False
-          , Cookie "1" "" "" "cookie2" "value2" False False
+            Cookie "1" "/testpath" "example.com" "cookie1" "value1" False False SameSiteNoValue
+          , Cookie "1" "" "" "cookie2" "value2" False False SameSiteNoValue
           ])
     ,parseCookies "  \t $Version = \"1\" ; cookie1 = \"randomcrap!@#%^&*()-_+={}[]:;'<>,.?/\\|\" , $Path=/  "
         @?= (Right [
-            Cookie "1" "/" "" "cookie1" "randomcrap!@#%^&*()-_+={}[]:;'<>,.?/|" False False
+            Cookie "1" "/" "" "cookie1" "randomcrap!@#%^&*()-_+={}[]:;'<>,.?/|" False False SameSiteNoValue
           ])
     ,parseCookies " cookie1 = value1  "
         @?= (Right [
-            Cookie "" "" "" "cookie1" "value1" False False
+            Cookie "" "" "" "cookie1" "value1" False False SameSiteNoValue
           ])
     ,parseCookies " $Version=\"1\";buggygooglecookie = valuewith=whereitshouldnotbe  "
         @?= (Right [
-            Cookie "1" "" "" "buggygooglecookie" "valuewith=whereitshouldnotbe" False False
+            Cookie "1" "" "" "buggygooglecookie" "valuewith=whereitshouldnotbe" False False SameSiteNoValue
           ])
     , parseCookies "foo=\"\\\"bar\\\"\""
         @?= (Right [
-              Cookie "" "" ""  "foo" "\"bar\"" False False
+              Cookie "" "" ""  "foo" "\"bar\"" False False SameSiteNoValue
              ])
     ]