Make session storage configurable

yesod-core/Yesod/Core.hs

@@ -27,6 +27,12 @@ module Yesod.Core
     , logWarn
     , logError
     , logOther
+      -- * Sessions
+    , SessionBackend (..)
+    , defaultClientSessionBackend
+    , clientSessionBackend
+    , saveClientSession
+    , loadClientSession
       -- * Misc
     , yesodVersion
     , yesodRender

yesod-core/Yesod/Dispatch.hs

@@ -38,7 +38,6 @@ import Network.Wai.Middleware.Autohead
 
 import Data.ByteString.Lazy.Char8 ()
 
-import Web.ClientSession
 import Data.Text (Text)
 import Data.Text.Encoding (decodeUtf8With)
 import Data.Text.Encoding.Error (lenientDecode)
@@ -156,20 +155,20 @@ toWaiApp y = gzip (gzipSettings y) . autohead <$> toWaiAppPlain y
 toWaiAppPlain :: ( Yesod master
                  , YesodDispatch master master
                  ) => master -> IO W.Application
-toWaiAppPlain a = toWaiApp' a <$> encryptKey a
+toWaiAppPlain a = toWaiApp' a <$> makeSessionBackend a
 
 
 toWaiApp' :: ( Yesod master
              , YesodDispatch master master
              )
           => master
-          -> Maybe Key
+          -> Maybe (SessionBackend master)
           -> W.Application
-toWaiApp' y key' env =
+toWaiApp' y sb env =
     case cleanPath y $ W.pathInfo env of
         Left pieces -> sendRedirect y pieces env
         Right pieces ->
-            yesodDispatch y y id app404 handler405 method pieces key' env
+            yesodDispatch y y id app404 handler405 method pieces sb env
   where
     app404 = yesodRunner notFound y y Nothing id
     handler405 route = yesodRunner badMethod y y (Just route) id

yesod-core/Yesod/Handler.hs

@@ -772,14 +772,9 @@ handlerToYAR y s toMasterRoute render errorHandler rr murl sessionMap h =
     types = httpAccept $ reqWaiRequest rr
     errorHandler' = localNoCurrent . errorHandler
 
-type HeaderRenderer = [Header]
+yarToResponse :: YesodAppResult -> [(CI H.Ascii, H.Ascii)] -> W.Response
-                   -> ContentType
+yarToResponse (YARWai a) _ = a
-                   -> SessionMap
+yarToResponse (YARPlain s hs _ c _) extraHeaders =
-                   -> [(CI H.Ascii, H.Ascii)]
-
-yarToResponse :: HeaderRenderer -> YesodAppResult -> W.Response
-yarToResponse _ (YARWai a) = a
-yarToResponse renderHeaders (YARPlain s hs ct c sessionFinal) =
     case c of
         ContentBuilder b mlen ->
             let hs' = maybe finalHeaders finalHeaders' mlen
@@ -787,11 +782,10 @@ yarToResponse renderHeaders (YARPlain s hs ct c sessionFinal) =
         ContentFile fp p -> W.ResponseFile s finalHeaders fp p
         ContentSource body -> W.ResponseSource s finalHeaders body
   where
-    finalHeaders = renderHeaders hs ct sessionFinal
+    finalHeaders = extraHeaders ++ map headerToPair hs
     finalHeaders' len = ("Content-Length", S8.pack $ show len)
                       : finalHeaders
 
-
 httpAccept :: W.Request -> [ContentType]
 httpAccept = parseHttpAccept
            . fromMaybe mempty

yesod-core/Yesod/Internal/Core.hs

@@ -25,6 +25,12 @@ module Yesod.Internal.Core
     , formatLogMessage
     , fileLocationToString
     , messageLoggerHandler
+      -- * Sessions
+    , SessionBackend (..)
+    , defaultClientSessionBackend
+    , clientSessionBackend
+    , saveClientSession
+    , loadClientSession
       -- * Misc
     , yesodVersion
     , yesodRender
@@ -37,6 +43,7 @@ import Yesod.Handler hiding (lift, getExpires)
 
 import Yesod.Routes.Class
 
+import Control.Applicative ((<$>))
 import Control.Arrow ((***))
 import Control.Monad (forM)
 import Yesod.Widget
@@ -45,7 +52,6 @@ import qualified Network.Wai as W
 import Yesod.Internal
 import Yesod.Internal.Session
 import Yesod.Internal.Request
-import Web.ClientSession (getKey, defaultKeyFile)
 import qualified Web.ClientSession as CS
 import qualified Data.ByteString.Char8 as S8
 import qualified Data.ByteString.Lazy as L
@@ -56,7 +62,7 @@ import Text.Blaze ((!), customAttribute, textTag, toValue, unsafeLazyByteString)
 import qualified Text.Blaze.Html5 as TBH
 import Data.Text.Lazy.Builder (toLazyText)
 import Data.Text.Lazy.Encoding (encodeUtf8)
-import Data.Maybe (fromMaybe)
+import Data.Maybe (fromMaybe, isJust)
 import Control.Monad.IO.Class (MonadIO (liftIO))
 import Web.Cookie (parseCookies)
 import qualified Data.Map as Map
@@ -106,11 +112,11 @@ class YesodDispatch sub master where
         => master
         -> sub
         -> (Route sub -> Route master)
-        -> (Maybe CS.Key -> W.Application) -- ^ 404 handler
+        -> (Maybe (SessionBackend master) -> W.Application) -- ^ 404 handler
-        -> (Route sub -> Maybe CS.Key -> W.Application) -- ^ 405 handler
+        -> (Route sub -> Maybe (SessionBackend master) -> W.Application) -- ^ 405 handler
         -> Text -- ^ request method
         -> [Text] -- ^ pieces
-        -> Maybe CS.Key
+        -> Maybe (SessionBackend master)
         -> W.Application
 
     yesodRunner :: Yesod master
@@ -119,7 +125,7 @@ class YesodDispatch sub master where
                 -> sub
                 -> Maybe (Route sub)
                 -> (Route sub -> Route master)
-                -> Maybe CS.Key
+                -> Maybe (SessionBackend master)
                 -> W.Application
     yesodRunner = defaultYesodRunner
 
@@ -154,16 +160,6 @@ class RenderRoute a => Yesod a where
     approot :: Approot a
     approot = ApprootRelative
 
-    -- | The encryption key to be used for encrypting client sessions.
-    -- Returning 'Nothing' disables sessions.
-    encryptKey :: a -> IO (Maybe CS.Key)
-    encryptKey _ = fmap Just $ getKey defaultKeyFile
-
-    -- | Number of minutes before a client session times out. Defaults to
-    -- 120 (2 hours).
-    clientSessionDuration :: a -> Int
-    clientSessionDuration = const 120
-
     -- | Output error response pages.
     errorHandler :: ErrorResponse -> GHandler sub a ChooseRep
     errorHandler = defaultErrorHandler
@@ -318,6 +314,25 @@ class RenderRoute a => Yesod a where
     yepnopeJs :: a -> Maybe (Either Text (Route a))
     yepnopeJs _ = Nothing
 
+    -- | Create a session backend
+    makeSessionBackend :: a -> IO (Maybe (SessionBackend a))
+    makeSessionBackend _ = Just <$> defaultClientSessionBackend
+
+type Session = [(Text, S8.ByteString)]
+
+data SessionBackend master = SessionBackend
+    { sbSaveSession :: master
+                    -> W.Request
+                    -> UTCTime -- ^ The current time
+                    -> Session -- ^ The old session (before running handler)
+                    -> Session -- ^ The final session
+                    -> IO [Header]
+    , sbLoadSession :: master
+                    -> W.Request
+                    -> UTCTime -- ^ The current time
+                    -> IO Session
+    }
+
 messageLoggerHandler :: Yesod m
                      => Loc -> LogLevel -> Text -> GHandler s m ()
 messageLoggerHandler loc level msg = do
@@ -366,7 +381,7 @@ defaultYesodRunner :: Yesod master
                    -> sub
                    -> Maybe (Route sub)
                    -> (Route sub -> Route master)
-                   -> Maybe CS.Key
+                   -> Maybe (SessionBackend master)
                    -> W.Application
 defaultYesodRunner _ master _ murl toMaster _ req
     | maximumContentLength master (fmap toMaster murl) < len =
@@ -380,20 +395,11 @@ defaultYesodRunner _ master _ murl toMaster _ req
         case reads $ S8.unpack s of
             [] -> Nothing
             (x, _):_ -> Just x
-defaultYesodRunner handler master sub murl toMasterRoute mkey req = do
+defaultYesodRunner handler master sub murl toMasterRoute msb req = do
-    now <- {-# SCC "getCurrentTime" #-} liftIO getCurrentTime
+    now <- liftIO getCurrentTime
-    let getExpires m = {-# SCC "getExpires" #-} fromIntegral (m * 60) `addUTCTime` now
+    session <- liftIO $
-    let exp' = {-# SCC "exp'" #-} getExpires $ clientSessionDuration master
+        maybe (return []) (\sb -> sbLoadSession sb master req now) msb
-    --let rh = {-# SCC "rh" #-} takeWhile (/= ':') $ show $ W.remoteHost req
+    rr <- liftIO $ parseWaiRequest req session (isJust msb)
-    let host = "" -- FIXME if sessionIpAddress master then S8.pack rh else ""
-    let session' = {-# SCC "session'" #-}
-            case mkey of
-                Nothing -> []
-                Just key -> fromMaybe [] $ do
-                    raw <- lookup "Cookie" $ W.requestHeaders req
-                    val <- lookup sessionName $ parseCookies raw
-                    decodeSession key now host val
-    rr <- liftIO $ parseWaiRequest req session' mkey
     let h = {-# SCC "h" #-} do
           case murl of
             Nothing -> handler
@@ -411,39 +417,23 @@ defaultYesodRunner handler master sub murl toMasterRoute mkey req = do
                                 redirect url'
                     Unauthorized s' -> permissionDenied s'
                 handler
-    let sessionMap = Map.fromList
+    let sessionMap = Map.fromList . filter ((/=) nonceKey . fst) $ session
-                   $ filter (\(x, _) -> x /= nonceKey) session'
     let ra = resolveApproot master req
-    yar <- handlerToYAR master sub toMasterRoute (yesodRender master ra) errorHandler rr murl sessionMap h
+    yar <- handlerToYAR master sub toMasterRoute
-    let mnonce = reqNonce rr
+        (yesodRender master ra) errorHandler rr murl sessionMap h
-    -- FIXME should we be caching this IV value and reusing it for efficiency?
+    extraHeaders <- case yar of
-    iv <- {-# SCC "iv" #-} maybe (return $ error "Should not be used") (const $ liftIO CS.randomIV) mkey
+        (YARPlain _ _ ct _ newSess) -> do
-    return $ yarToResponse (hr iv mnonce getExpires host exp') yar
+            let nsNonce = Map.toList $ maybe
-  where
+                    newSess
-    hr iv mnonce getExpires host exp' hs ct sm =
+                    (\n -> Map.insert nonceKey (TE.encodeUtf8 n) newSess)
-        hs'''
+                    (reqNonce rr)
-      where
+            sessionHeaders <- liftIO $ maybe
-        sessionVal =
+                (return [])
-            case (mkey, mnonce) of
+                (\sb -> sbSaveSession sb master req now session nsNonce)
-                (Just key, Just nonce)
+                msb
-                    -> encodeSession key iv exp' host
+            return $ ("Content-Type", ct) : map headerToPair sessionHeaders
-                     $ Map.toList
+        _ -> return []
-                     $ Map.insert nonceKey (TE.encodeUtf8 nonce) sm
+    return $ yarToResponse yar extraHeaders
-                _ -> mempty
-        hs' =
-            case mkey of
-                Nothing -> hs
-                Just _ -> AddCookie def
-                            { setCookieName = sessionName
-                            , setCookieValue = sessionVal
-                            , setCookiePath = Just (cookiePath master)
-                            , setCookieExpires = Just $ getExpires (clientSessionDuration master)
-                            , setCookieDomain = Nothing
-                            , setCookieHttpOnly = True
-                            }
-                          : hs
-        hs'' = map headerToPair hs'
-        hs''' = ("Content-Type", ct) : hs''
 
 data AuthResult = Authorized | AuthenticationRequired | Unauthorized Text
     deriving (Eq, Show, Read)
@@ -672,3 +662,56 @@ resolveApproot master req =
         ApprootStatic t -> t
         ApprootMaster f -> f master
         ApprootRequest f -> f master req
+
+defaultClientSessionBackend :: Yesod master => IO (SessionBackend master)
+defaultClientSessionBackend = do
+  key <- CS.getKey CS.defaultKeyFile
+  let timeout = 120 -- 120 minutes
+  return $ clientSessionBackend key timeout
+
+clientSessionBackend :: Yesod master 
+                     => CS.Key  -- ^ The encryption key
+                     -> Int -- ^ Inactive session valitity in minutes
+                     -> SessionBackend master
+clientSessionBackend key timeout = SessionBackend
+    { sbSaveSession = saveClientSession key timeout
+    , sbLoadSession = loadClientSession key
+    }
+
+loadClientSession :: Yesod master
+                  => CS.Key
+                  -> master
+                  -> W.Request
+                  -> UTCTime
+                  -> IO Session
+loadClientSession key _ req now = return . fromMaybe [] $ do
+    raw <- lookup "Cookie" $ W.requestHeaders req
+    val <- lookup sessionName $ parseCookies raw
+    let host = "" -- fixme, properly lock sessions to client address
+    decodeClientSession key now host val
+
+saveClientSession :: Yesod master
+                  => CS.Key
+                  -> Int
+                  -> master
+                  -> W.Request
+                  -> UTCTime
+                  -> Session
+                  -> Session
+                  -> IO [Header]
+saveClientSession key timeout master _ now _ sess = do
+    -- fixme should we be caching this?
+    iv <- liftIO $ CS.randomIV
+    return [AddCookie def 
+        { setCookieName = sessionName
+        , setCookieValue = sessionVal iv
+        , setCookiePath = Just (cookiePath master)
+        , setCookieExpires = Just expires
+        , setCookieDomain = Nothing
+        , setCookieHttpOnly = True
+        }]
+  where
+    host = "" -- fixme, properly lock sessions to client address
+    expires = fromIntegral (timeout * 60) `addUTCTime` now
+    sessionVal iv = encodeClientSession key iv expires host sess
+

yesod-core/Yesod/Internal/Request.hs

@@ -42,17 +42,19 @@ data Request = Request
 
 parseWaiRequest :: W.Request
                 -> [(Text, ByteString)] -- ^ session
-                -> Maybe a
+                -> Bool
                 -> IO Request
-parseWaiRequest env session' key' = parseWaiRequest' env session' key' <$> newStdGen
+parseWaiRequest env session' useNonce =
+    parseWaiRequest' env session' useNonce <$> newStdGen
 
 parseWaiRequest' :: RandomGen g
                  => W.Request
                  -> [(Text, ByteString)] -- ^ session
-                 -> Maybe a
+                 -> Bool
                  -> g
                  -> Request
-parseWaiRequest' env session' key' gen = Request gets'' cookies' env langs'' nonce
+parseWaiRequest' env session' useNonce gen = 
+    Request gets'' cookies' env langs'' nonce
   where
     gets' = queryToQueryText $ W.queryString env
     gets'' = map (second $ fromMaybe "") gets'
@@ -77,10 +79,10 @@ parseWaiRequest' env session' key' gen = Request gets'' cookies' env langs'' non
     -- nonceKey present in the session is ignored). If sessions
     -- are enabled and a session has no nonceKey a new one is
     -- generated.
-    nonce = case (key', lookup nonceKey session') of
+    nonce = case (useNonce, lookup nonceKey session') of
-                (Nothing, _) -> Nothing
+                (False, _)  -> Nothing
-                (_, Just x)  -> Just $ decodeUtf8With lenientDecode x
+                (_, Just x) -> Just $ decodeUtf8With lenientDecode x
-                _            -> Just $ pack $ randomString 10 gen
+                _           -> Just $ pack $ randomString 10 gen
 
 addTwoLetters :: ([Text] -> [Text], Set.Set Text) -> [Text] -> [Text]
 addTwoLetters (toAdd, exist) [] =

yesod-core/Yesod/Internal/Session.hs

@@ -1,6 +1,6 @@
 module Yesod.Internal.Session
-    ( encodeSession
+    ( encodeClientSession
-    , decodeSession
+    , decodeClientSession
     ) where
 
 import qualified Web.ClientSession as CS
@@ -12,21 +12,21 @@ import Data.Text (Text, pack, unpack)
 import Control.Arrow (first)
 import Control.Applicative ((<$>))
 
-encodeSession :: CS.Key
+encodeClientSession :: CS.Key
-              -> CS.IV
+                    -> CS.IV
-              -> UTCTime -- ^ expire time
+                    -> UTCTime -- ^ expire time
-              -> ByteString -- ^ remote host
+                    -> ByteString -- ^ remote host
-              -> [(Text, ByteString)] -- ^ session
+                    -> [(Text, ByteString)] -- ^ session
-              -> ByteString -- ^ cookie value
+                    -> ByteString -- ^ cookie value
-encodeSession key iv expire rhost session' =
+encodeClientSession key iv expire rhost session' =
     CS.encrypt key iv $ encode $ SessionCookie expire rhost session'
 
-decodeSession :: CS.Key
+decodeClientSession :: CS.Key
-              -> UTCTime -- ^ current time
+                    -> UTCTime -- ^ current time
-              -> ByteString -- ^ remote host field
+                    -> ByteString -- ^ remote host field
-              -> ByteString -- ^ cookie value
+                    -> ByteString -- ^ cookie value
-              -> Maybe [(Text, ByteString)]
+                    -> Maybe [(Text, ByteString)]
-decodeSession key now rhost encrypted = do
+decodeClientSession key now rhost encrypted = do
     decrypted <- CS.decrypt key encrypted
     SessionCookie expire rhost' session' <-
         either (const Nothing) Just $ decode decrypted

yesod-core/test/YesodCoreTest/InternalRequest.hs

@@ -40,19 +40,19 @@ nonceSpecs = describe "Yesod.Internal.Request.parseWaiRequest (reqNonce)"
 
 noDisabledNonce :: Bool
 noDisabledNonce = reqNonce r == Nothing where
-  r = parseWaiRequest' defaultRequest [] Nothing g
+  r = parseWaiRequest' defaultRequest [] False g
 
 ignoreDisabledNonce :: Bool
 ignoreDisabledNonce = reqNonce r == Nothing where
-  r = parseWaiRequest' defaultRequest [("_NONCE", "old")] Nothing g
+  r = parseWaiRequest' defaultRequest [("_NONCE", "old")] False g
 
 useOldNonce :: Bool
 useOldNonce = reqNonce r == Just "old" where
-  r = parseWaiRequest' defaultRequest [("_NONCE", "old")] (Just undefined) g
+  r = parseWaiRequest' defaultRequest [("_NONCE", "old")] True g
 
 generateNonce :: Bool
 generateNonce = reqNonce r /= Nothing where
-  r = parseWaiRequest' defaultRequest [("_NONCE", "old")] (Just undefined) g
+  r = parseWaiRequest' defaultRequest [("_NONCE", "old")] True g
 
 
 langSpecs :: [Spec]
@@ -67,21 +67,21 @@ langSpecs = describe "Yesod.Internal.Request.parseWaiRequest (reqLangs)"
 respectAcceptLangs :: Bool
 respectAcceptLangs = reqLangs r == ["en-US", "es", "en"] where
   r = parseWaiRequest' defaultRequest
-        { requestHeaders = [("Accept-Language", "en-US, es")] } [] Nothing g
+        { requestHeaders = [("Accept-Language", "en-US, es")] } [] False g
 
 respectSessionLang :: Bool
 respectSessionLang = reqLangs r == ["en"] where
-  r = parseWaiRequest' defaultRequest [("_LANG", "en")] Nothing g
+  r = parseWaiRequest' defaultRequest [("_LANG", "en")] False g
 
 respectCookieLang :: Bool
 respectCookieLang = reqLangs r == ["en"] where
   r = parseWaiRequest' defaultRequest
         { requestHeaders = [("Cookie", "_LANG=en")]
-        } [] Nothing g
+        } [] False g
 
 respectQueryLang :: Bool
 respectQueryLang = reqLangs r == ["en-US", "en"] where
-  r = parseWaiRequest' defaultRequest { queryString = [("_LANG", Just "en-US")] } [] Nothing g
+  r = parseWaiRequest' defaultRequest { queryString = [("_LANG", Just "en-US")] } [] False g
 
 prioritizeLangs :: Bool
 prioritizeLangs = reqLangs r == ["en-QUERY", "en-COOKIE", "en-SESSION", "en", "es"] where
@@ -90,7 +90,7 @@ prioritizeLangs = reqLangs r == ["en-QUERY", "en-COOKIE", "en-SESSION", "en", "e
                            , ("Cookie", "_LANG=en-COOKIE")
                            ]
         , queryString = [("_LANG", Just "en-QUERY")]
-        } [("_LANG", "en-SESSION")] Nothing g
+        } [("_LANG", "en-SESSION")] False g
 
 
 internalRequestTest :: [Spec]

yesod/scaffold/Foundation.hs.cg

@@ -85,8 +85,11 @@ type Form x = Html -> MForm ~sitearg~ ~sitearg~ (FormResult x, Widget)
 instance Yesod ~sitearg~ where
     approot = ApprootMaster $ appRoot . settings
 
-    -- Place the session key file in the config folder
+    -- Store session data on the client in encrypted cookies,
-    encryptKey _ = fmap Just $ getKey "config/client_session_key.aes"
+    -- place the encryption key file in the config folder
+    makeSessionBackend _ = do
+        key <- getKey "config/client_session_key.aes"
+        return . Just $ clientSessionBackend key 120
 
     defaultLayout widget = do
         master <- getYesod

yesod/scaffold/tiny/Foundation.hs.cg

@@ -62,8 +62,11 @@ mkYesodData "~sitearg~" $(parseRoutesFile "config/routes")
 instance Yesod ~sitearg~ where
     approot = ApprootMaster $ appRoot . settings
 
-    -- Place the session key file in the config folder
+    -- Store session data on the client in encrypted cookies,
-    encryptKey _ = fmap Just $ getKey "config/client_session_key.aes"
+    -- place the encryption key file in the config folder
+    makeSessionBackend _ = do
+        key <- getKey "config/client_session_key.aes"
+        return . Just $ clientSessionBackend key 120
 
     defaultLayout widget = do
         master <- getYesod