Merge branch 'BL/samesite' of https://github.com/bobjflong/yesod into bobjflong-BL/samesite

stack.yaml

@@ -21,3 +21,4 @@ extra-deps:
 - yaml-0.8.17
 - nonce-1.0.2
 - persistent-2.5
+- cookie-0.4.2

yesod-core/Yesod/Core.hs

@@ -52,6 +52,8 @@ module Yesod.Core
     , envClientSessionBackend
     , clientSessionBackend
     , sslOnlySessions
+    , laxSameSiteSessions
+    , strictSameSiteSessions
     , sslOnlyMiddleware
     , clientSessionDateCacher
     , loadClientSession

yesod-core/Yesod/Core/Class/Yesod.hs

@@ -51,7 +51,8 @@ import qualified Text.Blaze.Html5                   as TBH
 import           Text.Hamlet
 import           Text.Julius
 import qualified Web.ClientSession                  as CS
-import           Web.Cookie                         (SetCookie (..), parseCookies)
+import           Web.Cookie                         (SetCookie (..), parseCookies, sameSiteLax,
+                                                     sameSiteStrict, SameSiteOption)
 import           Yesod.Core.Types
 import           Yesod.Core.Internal.Session
 import           Yesod.Core.Widget
@@ -386,6 +387,34 @@ sslOnlySessions = (fmap . fmap) secureSessionCookies
     setSecureBit cookie = cookie { setCookieSecure = True }
     secureSessionCookies = customizeSessionCookies setSecureBit
 
+-- | Helps defend against CSRF attacks by setting the SameSite attribute on
+-- session cookies to Lax. With the Lax setting, the cookie will be sent with same-site
+-- requests, and with cross-site top-level navigations.
+--
+-- This option is liable to change in future versions of Yesod as the spec evolves.
+-- View more information <https://datatracker.ietf.org/doc/draft-west-first-party-cookies/ here>.
+--
+-- Since 1.4.21
+laxSameSiteSessions :: IO (Maybe SessionBackend) -> IO (Maybe SessionBackend)
+laxSameSiteSessions = sameSiteSession sameSiteLax
+
+-- | Helps defend against CSRF attacks by setting the SameSite attribute on
+-- session cookies to Strict. With the Strict setting, the cookie will only be
+-- sent with same-site requests.
+--
+-- This option is liable to change in future versions of Yesod as the spec evolves.
+-- View more information <https://datatracker.ietf.org/doc/draft-west-first-party-cookies/ here>.
+--
+-- Since 1.4.21
+strictSameSiteSessions :: IO (Maybe SessionBackend) -> IO (Maybe SessionBackend)
+strictSameSiteSessions = sameSiteSession sameSiteStrict
+
+sameSiteSession :: SameSiteOption -> IO (Maybe SessionBackend) -> IO (Maybe SessionBackend)
+sameSiteSession s = (fmap . fmap) secureSessionCookies
+  where
+    sameSite cookie = cookie { setCookieSameSite = Just s }
+    secureSessionCookies = customizeSessionCookies sameSite
+
 -- | Apply a Strict-Transport-Security header with the specified timeout to
 -- all responses so that browsers will rewrite all http links to https
 -- until the timeout expires. For security, the max-age of the STS header

yesod-core/test/YesodCoreTest.hs

@@ -1,5 +1,5 @@
 {-# LANGUAGE CPP                        #-}
-module YesodCoreTest (specs) where 
+module YesodCoreTest (specs) where
 
 import YesodCoreTest.CleanPath
 import YesodCoreTest.Exceptions
@@ -48,4 +48,5 @@ specs = do
       LiteApp.specs
       Ssl.unsecSpec
       Ssl.sslOnlySpec
+      Ssl.sameSiteSpec
       Csrf.csrfSpec

yesod-core/test/YesodCoreTest/Ssl.hs

@@ -1,6 +1,8 @@
 {-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-}
-module YesodCoreTest.Ssl ( sslOnlySpec, unsecSpec ) where
+module YesodCoreTest.Ssl ( sslOnlySpec, unsecSpec, sameSiteSpec ) where
 import qualified YesodCoreTest.StubSslOnly as Ssl
+import qualified YesodCoreTest.StubLaxSameSite as LaxSameSite
+import qualified YesodCoreTest.StubStrictSameSite as StrictSameSite
 import qualified YesodCoreTest.StubUnsecured as Unsecured
 import Yesod.Core
 import Test.Hspec
@@ -62,3 +64,15 @@ unsecSpec = describe "A Yesod application with sslOnly off" $ do
   where
     atHome = homeFixtureFor Unsecured.App
     isNotSecure c = not $ Cookie.setCookieSecure c
+
+sameSiteSpec :: Spec
+sameSiteSpec = describe "A Yesod application" $ do
+    it "can set a Lax SameSite option" $
+        laxHome $ "_SESSION" `cookieShouldSatisfy` isLax
+    it "can set a Strict SameSite option" $
+        strictHome $ "_SESSION" `cookieShouldSatisfy` isStrict
+  where
+    laxHome = homeFixtureFor LaxSameSite.App
+    strictHome = homeFixtureFor StrictSameSite.App
+    isLax = (== Just Cookie.sameSiteLax) . Cookie.setCookieSameSite
+    isStrict = (== Just Cookie.sameSiteStrict) . Cookie.setCookieSameSite

yesod-core/test/YesodCoreTest/StubLaxSameSite.hs

@@ -0,0 +1,23 @@
+{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-}
+module YesodCoreTest.StubLaxSameSite ( App ( App ) ) where
+
+import Yesod.Core
+import qualified Web.ClientSession                  as CS
+
+data App = App
+
+mkYesod "App" [parseRoutes|
+/ HomeR GET
+|]
+
+instance Yesod App where
+    yesodMiddleware = defaultYesodMiddleware . (sslOnlyMiddleware 120)
+    makeSessionBackend _ = laxSameSiteSessions $
+        fmap Just $ defaultClientSessionBackend 120 CS.defaultKeyFile
+
+getHomeR :: Handler Html
+getHomeR = defaultLayout
+    [whamlet|
+        <p>
+            Welcome to my test application.
+    |]

yesod-core/test/YesodCoreTest/StubStrictSameSite.hs

@@ -0,0 +1,23 @@
+{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-}
+module YesodCoreTest.StubStrictSameSite ( App ( App ) ) where
+
+import Yesod.Core
+import qualified Web.ClientSession                  as CS
+
+data App = App
+
+mkYesod "App" [parseRoutes|
+/ HomeR GET
+|]
+
+instance Yesod App where
+    yesodMiddleware = defaultYesodMiddleware . (sslOnlyMiddleware 120)
+    makeSessionBackend _ = strictSameSiteSessions $
+        fmap Just $ defaultClientSessionBackend 120 CS.defaultKeyFile
+
+getHomeR :: Handler Html
+getHomeR = defaultLayout
+    [whamlet|
+        <p>
+            Welcome to my test application.
+    |]

yesod-core/yesod-core.cabal

@@ -42,7 +42,7 @@ library
                    , unordered-containers  >= 0.2
                    , monad-control         >= 0.3      && < 1.1
                    , transformers-base     >= 0.4
-                   , cookie                >= 0.4.1    && < 0.5
+                   , cookie                >= 0.4.2    && < 0.5
                    , http-types            >= 0.7
                    , case-insensitive      >= 0.2
                    , parsec                >= 2        && < 3.2