Make new session code optional, keep old API

yesod-core/Yesod/Core.hs

@@ -35,6 +35,8 @@ module Yesod.Core
     , SessionBackend (..)
     , defaultClientSessionBackend
     , clientSessionBackend
+    , clientSessionBackend2
+    , clientSessionDateCacher
     , loadClientSession
     , Header(..)
     , BackendSession

yesod-core/Yesod/Internal/Core.hs

@@ -25,6 +25,9 @@ module Yesod.Internal.Core
     , defaultClientSessionBackend
     , clientSessionBackend
     , loadClientSession
+    , clientSessionBackend2
+    , loadClientSession2
+    , clientSessionDateCacher
     , BackendSession
       -- * jsLoader
     , ScriptLoadPosition (..)
@@ -44,6 +47,7 @@ import Yesod.Handler hiding (lift, getExpires)
 import Control.Monad.Logger (logErrorS)
 
 import Yesod.Routes.Class
+import Data.Time (UTCTime, addUTCTime, getCurrentTime)
 
 import Data.Word (Word64)
 import Control.Arrow ((***))
@@ -435,9 +439,10 @@ defaultYesodRunner logger handler' master sub murl toMasterRoute msb req
             [("Content-Type", "text/plain")]
             "Request body too large to be processed."
   | otherwise = do
-    let dontSaveSession _ = return []
-    (session, saveSession) <- liftIO $
-        maybe (return ([], dontSaveSession)) (\sb -> sbLoadSession sb master req) msb
+    let dontSaveSession _ _ = return []
+    now <- liftIO getCurrentTime -- FIXME remove in next major version bump
+    (session, saveSession) <- liftIO $ do
+        maybe (return ([], dontSaveSession)) (\sb -> sbLoadSession sb master req now) msb
     rr <- liftIO $ parseWaiRequest req session (isJust msb) len
     let h = {-# SCC "h" #-} do
           case murl of
@@ -467,7 +472,7 @@ defaultYesodRunner logger handler' master sub murl toMasterRoute msb req
                     newSess
                     (\n -> Map.insert tokenKey (TE.encodeUtf8 n) newSess)
                     (reqToken rr)
-            sessionHeaders <- liftIO (saveSession nsToken)
+            sessionHeaders <- liftIO (saveSession nsToken now)
             return $ ("Content-Type", ct) : map headerToPair sessionHeaders
         _ -> return []
     return $ yarToResponse yar extraHeaders
@@ -758,25 +763,67 @@ defaultClientSessionBackend = do
   key <- CS.getKey CS.defaultKeyFile
   let timeout = fromIntegral (120 * 60 :: Int) -- 120 minutes
   (getCachedDate, _closeDateCacher) <- clientSessionDateCacher timeout
-  return $ clientSessionBackend key getCachedDate
+  return $ clientSessionBackend2 key getCachedDate
+
 
 clientSessionBackend :: Yesod master
                      => CS.Key  -- ^ The encryption key
-                     -> IO ClientSessionDateCache -- ^ See 'clientSessionDateCacher'
+                     -> Int -- ^ Inactive session valitity in minutes
                      -> SessionBackend master
-clientSessionBackend key getCachedDate =
-  SessionBackend {
-    sbLoadSession = loadClientSession key getCachedDate "_SESSION"
-  }
+clientSessionBackend key timeout = SessionBackend
+    { sbLoadSession = loadClientSession key timeout "_SESSION"
+    }
+{-# DEPRECATED clientSessionBackend "Please use clientSessionBackend2, which is more efficient." #-}
 
 loadClientSession :: Yesod master
+                  => CS.Key
+                  -> Int -- ^ timeout
+                  -> S8.ByteString -- ^ session name
+                  -> master
+                  -> W.Request
+                  -> UTCTime
+                  -> IO (BackendSession, SaveSession)
+loadClientSession key timeout sessionName master req now = return (sess, save)
+  where
+    sess = fromMaybe [] $ do
+      raw <- lookup "Cookie" $ W.requestHeaders req
+      val <- lookup sessionName $ parseCookies raw
+      let host = "" -- fixme, properly lock sessions to client address
+      decodeClientSessionOld key now host val
+    save sess' now' = do
+      -- We should never cache the IV!  Be careful!
+      iv <- liftIO CS.randomIV
+      return [AddCookie def
+          { setCookieName = sessionName
+          , setCookieValue = sessionVal iv
+          , setCookiePath = Just (cookiePath master)
+          , setCookieExpires = Just expires
+          , setCookieDomain = cookieDomain master
+          , setCookieHttpOnly = True
+          }]
+        where
+          host = "" -- fixme, properly lock sessions to client address
+          expires = fromIntegral (timeout * 60) `addUTCTime` now'
+          sessionVal iv = encodeClientSessionOld key iv expires host sess'
+{-# DEPRECATED loadClientSession "Please use loadClientSession2, which is more efficient." #-}
+
+clientSessionBackend2 :: Yesod master
+                     => CS.Key  -- ^ The encryption key
+                     -> IO ClientSessionDateCache -- ^ See 'clientSessionDateCacher'
+                     -> SessionBackend master
+clientSessionBackend2 key getCachedDate =
+  SessionBackend {
+    sbLoadSession = \master req -> const $ loadClientSession2 key getCachedDate "_SESSION" master req
+  }
+
+loadClientSession2 :: Yesod master
                   => CS.Key
                   -> IO ClientSessionDateCache -- ^ See 'clientSessionDateCacher'
                   -> S8.ByteString -- ^ session name
                   -> master
                   -> W.Request
                   -> IO (BackendSession, SaveSession)
-loadClientSession key getCachedDate sessionName master req = load
+loadClientSession2 key getCachedDate sessionName master req = load
   where
     load = do
       date <- getCachedDate
@@ -786,7 +833,7 @@ loadClientSession key getCachedDate sessionName master req = load
       val <- lookup sessionName $ parseCookies raw
       let host = "" -- fixme, properly lock sessions to client address
       decodeClientSession key date host val
-    save date sess' = do
+    save date sess' _ = do
       -- We should never cache the IV!  Be careful!
       iv <- liftIO CS.randomIV
       return [AddCookie def

yesod-core/Yesod/Internal/Session.hs

@@ -1,10 +1,13 @@
 module Yesod.Internal.Session
     ( encodeClientSession
+    , encodeClientSessionOld
     , decodeClientSession
+    , decodeClientSessionOld
     , clientSessionDateCacher
     , ClientSessionDateCache(..)
     , BackendSession
     , SaveSession
+    , SaveSessionOld
     , SessionBackend(..)
     ) where
 
@@ -27,11 +30,17 @@ import qualified Network.Wai as W
 type BackendSession = [(Text, S8.ByteString)]
 
 type SaveSession = BackendSession    -- ^ The session contents after running the handler
+                -> UTCTime -- FIXME remove this in the next major version bump
+                -> IO [Header]
+
+type SaveSessionOld = BackendSession    -- ^ The session contents after running the handler
+                -> UTCTime
                 -> IO [Header]
 
 newtype SessionBackend master = SessionBackend
     { sbLoadSession :: master
                     -> W.Request
+                    -> UTCTime -- FIXME remove this in the next major version bump
                     -> IO (BackendSession, SaveSession) -- ^ Return the session data and a function to save the session
     }
 
@@ -128,3 +137,25 @@ posixDayLength_int64 = 86400
 
 diffTimeScale :: DiffTime
 diffTimeScale = 1e12
+
+encodeClientSessionOld :: CS.Key
+                    -> CS.IV
+                    -> UTCTime -- ^ expire time
+                    -> ByteString -- ^ remote host
+                    -> [(Text, ByteString)] -- ^ session
+                    -> ByteString -- ^ cookie value
+encodeClientSessionOld key iv expire rhost session' =
+    CS.encrypt key iv $ encode $ SessionCookie (Left expire) rhost session'
+
+decodeClientSessionOld :: CS.Key
+                    -> UTCTime -- ^ current time
+                    -> ByteString -- ^ remote host field
+                    -> ByteString -- ^ cookie value
+                    -> Maybe [(Text, ByteString)]
+decodeClientSessionOld key now rhost encrypted = do
+    decrypted <- CS.decrypt key encrypted
+    SessionCookie (Left expire) rhost' session' <-
+        either (const Nothing) Just $ decode decrypted
+    guard $ expire > now
+    guard $ rhost' == rhost
+    return session'

yesod-core/yesod-core.cabal

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