enableClientSessions

Yesod/Dispatch.hs

@@ -27,10 +27,10 @@ module Yesod.Dispatch
     ) where
 
 #if TEST
-import Yesod.Yesod hiding (testSuite)
+import Yesod.Yesod hiding (testSuite, Key)
 import Yesod.Handler hiding (testSuite)
 #else
-import Yesod.Yesod
+import Yesod.Yesod hiding (Key)
 import Yesod.Handler
 #endif
 
@@ -236,27 +236,33 @@ sessionName = "_SESSION"
 -- | Convert the given argument into a WAI application, executable with any WAI
 -- handler. You can use 'basicHandler' if you wish.
 toWaiApp :: (Yesod y, YesodSite y) => y -> IO W.Application
-toWaiApp a =
+toWaiApp a = do
+    key' <- if enableClientSessions a
+                then Just `fmap` encryptKey a
+                else return Nothing
     return $ gzip
            $ jsonp
            $ cleanPathFunc (splitPath a) (B.pack $ approot a)
-           $ toWaiApp' a
+           $ toWaiApp' a key'
 
 toWaiApp' :: (Yesod y, YesodSite y)
           => y
+          -> Maybe Key
           -> [String]
           -> W.Request
           -> IO W.Response
-toWaiApp' y segments env = do
+toWaiApp' y key' segments env = do
-    key' <- encryptKey y
     now <- getCurrentTime
     let getExpires m = fromIntegral (m * 60) `addUTCTime` now
     let exp' = getExpires $ clientSessionDuration y
     let host = if sessionIpAddress y then W.remoteHost env else ""
-    let session' = fromMaybe [] $ do
+    let session' =
-            raw <- lookup "Cookie" $ W.requestHeaders env
+            case key' of
-            val <- lookup (B.pack sessionName) $ parseCookies raw
+                Nothing -> []
-            decodeSession key' now host val
+                Just key'' -> fromMaybe [] $ do
+                    raw <- lookup "Cookie" $ W.requestHeaders env
+                    val <- lookup (B.pack sessionName) $ parseCookies raw
+                    decodeSession key'' now host val
     let site = getSite
         method = B.unpack $ W.requestMethod env
         types = httpAccept env
@@ -295,12 +301,21 @@ toWaiApp' y segments env = do
     let sessionMap = Map.fromList
                    $ filter (\(x, _) -> x /= nonceKey) session'
     (s, hs, ct, c, sessionFinal) <- unYesodApp ya eh rr types sessionMap
-    let sessionVal = encodeSession key' exp' host
+    let sessionVal =
+            case key' of
+                Nothing -> B.empty
+                Just key'' ->
+                     encodeSession key'' exp' host
                    $ Map.toList
                    $ Map.insert nonceKey (reqNonce rr) sessionFinal
-    let hs' = AddCookie (clientSessionDuration y) sessionName
+    let hs' =
-                                                  (bsToChars sessionVal)
+            case key' of
-            : hs
+                Nothing -> hs
+                Just _ -> AddCookie
+                            (clientSessionDuration y)
+                            sessionName
+                            (bsToChars sessionVal)
+                          : hs
         hs'' = map (headerToPair getExpires) hs'
         hs''' = ("Content-Type", charsToBs ct) : hs''
     return $ W.Response s hs''' c

Yesod/Yesod.hs

@@ -109,6 +109,13 @@ class Eq (Route a) => Yesod a where
     encryptKey :: a -> IO CS.Key
     encryptKey _ = getKey defaultKeyFile
 
+    -- | Whether or not to use client sessions.
+    --
+    -- FIXME: A better API would be to have 'encryptKey' return a Maybe, but
+    -- that would be a breaking change. Please include in Yesod 0.7.
+    enableClientSessions :: a -> Bool
+    enableClientSessions _ = True
+
     -- | Number of minutes before a client session times out. Defaults to
     -- 120 (2 hours).
     clientSessionDuration :: a -> Int

yesod.cabal

@@ -1,5 +1,5 @@
 name:            yesod
-version:         0.6.7
+version:         0.6.8
 license:         BSD3
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>