yesod-core: New 'customizeSessionCookies' helper function.

yesod-core/Yesod/Core.hs

@@ -41,6 +41,7 @@ module Yesod.Core
     , logOtherS
       -- * Sessions
     , SessionBackend (..)
+    , customizeSessionCookies
     , defaultClientSessionBackend
     , clientSessionBackend
     , clientSessionDateCacher

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

@@ -12,7 +12,7 @@ import           Yesod.Routes.Class
 
 import           Blaze.ByteString.Builder           (Builder)
 import           Blaze.ByteString.Builder.Char.Utf8 (fromText)
-import           Control.Arrow                      ((***))
+import           Control.Arrow                      ((***), second)
 import           Control.Monad                      (forM, when, void)
 import           Control.Monad.IO.Class             (MonadIO (liftIO))
 import           Control.Monad.Logger               (LogLevel (LevelInfo, LevelOther),
@@ -235,7 +235,10 @@ class RenderRoute site => Yesod site where
     jsLoader :: site -> ScriptLoadPosition site
     jsLoader _ = BottomOfBody
 
-    -- | Create a session backend. Returning `Nothing' disables sessions.
+    -- | Create a session backend. Returning 'Nothing' disables
+    -- sessions. If you'd like to change the way that the session
+    -- cookies are created, take a look at
+    -- 'customizeSessionCookies'.
     --
     -- Default: Uses clientsession with a 2 hour timeout.
     makeSessionBackend :: site -> IO (Maybe SessionBackend)
@@ -532,6 +535,33 @@ formatLogMessage getdate loc src level msg = do
         , LB ")\n"
         ]
 
+
+-- | Customize the cookies used by the session backend.  You may
+-- use this function on your definition of 'makeSessionBackend'.
+--
+-- For example, you could set the cookie domain so that it
+-- would work across many subdomains:
+--
+-- @
+-- makeSessionBackend = fmap (customizeSessionCookie addDomain) ...
+--   where
+--     addDomain cookie = cookie { 'setCookieDomain' = Just \".example.com\" }
+-- @
+--
+-- Default: Do not customize anything ('id').
+customizeSessionCookies :: (SetCookie -> SetCookie) -> (SessionBackend -> SessionBackend)
+customizeSessionCookies customizeCookie backend = backend'
+  where
+    customizeHeader (AddCookie cookie) = AddCookie (customizeCookie cookie)
+    customizeHeader other              = other
+    customizeSaveSession = (fmap . fmap . fmap) customizeHeader
+    backend' =
+      backend {
+        sbLoadSession = \req ->
+          second customizeSaveSession `fmap` sbLoadSession backend req
+      }
+
+
 defaultClientSessionBackend :: Int -- ^ minutes
                             -> FilePath -- ^ key file
                             -> IO SessionBackend

yesod-core/yesod-core.cabal

@@ -1,5 +1,5 @@
 name:            yesod-core
-version:         1.2.0.2
+version:         1.2.0.3
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>