diff --git a/yesod-core/Yesod/Core.hs b/yesod-core/Yesod/Core.hs index 740bb1dc..015bc4d7 100644 --- a/yesod-core/Yesod/Core.hs +++ b/yesod-core/Yesod/Core.hs @@ -27,6 +27,12 @@ module Yesod.Core , logWarn , logError , logOther + -- * Sessions + , SessionBackend (..) + , defaultClientSessionBackend + , clientSessionBackend + , saveClientSession + , loadClientSession -- * Misc , yesodVersion , yesodRender diff --git a/yesod-core/Yesod/Dispatch.hs b/yesod-core/Yesod/Dispatch.hs index 38af2a16..b008210b 100644 --- a/yesod-core/Yesod/Dispatch.hs +++ b/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 diff --git a/yesod-core/Yesod/Handler.hs b/yesod-core/Yesod/Handler.hs index 32e46e4c..0ebfaf10 100644 --- a/yesod-core/Yesod/Handler.hs +++ b/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] - -> ContentType - -> SessionMap - -> [(CI H.Ascii, H.Ascii)] - -yarToResponse :: HeaderRenderer -> YesodAppResult -> W.Response -yarToResponse _ (YARWai a) = a -yarToResponse renderHeaders (YARPlain s hs ct c sessionFinal) = +yarToResponse :: YesodAppResult -> [(CI H.Ascii, H.Ascii)] -> W.Response +yarToResponse (YARWai a) _ = a +yarToResponse (YARPlain s hs _ c _) extraHeaders = 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 diff --git a/yesod-core/Yesod/Internal/Core.hs b/yesod-core/Yesod/Internal/Core.hs index 9f1d6403..338045e8 100644 --- a/yesod-core/Yesod/Internal/Core.hs +++ b/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 - -> (Route sub -> Maybe CS.Key -> W.Application) -- ^ 405 handler + -> (Maybe (SessionBackend master) -> W.Application) -- ^ 404 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 - now <- {-# SCC "getCurrentTime" #-} liftIO getCurrentTime - let getExpires m = {-# SCC "getExpires" #-} fromIntegral (m * 60) `addUTCTime` now - let exp' = {-# SCC "exp'" #-} getExpires $ clientSessionDuration master - --let rh = {-# SCC "rh" #-} takeWhile (/= ':') $ show $ W.remoteHost req - 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 +defaultYesodRunner handler master sub murl toMasterRoute msb req = do + now <- liftIO getCurrentTime + session <- liftIO $ + maybe (return []) (\sb -> sbLoadSession sb master req now) msb + rr <- liftIO $ parseWaiRequest req session (isJust msb) 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 - $ filter (\(x, _) -> x /= nonceKey) session' + let sessionMap = Map.fromList . filter ((/=) nonceKey . fst) $ session let ra = resolveApproot master req - yar <- handlerToYAR master sub toMasterRoute (yesodRender master ra) errorHandler rr murl sessionMap h - let mnonce = reqNonce rr - -- FIXME should we be caching this IV value and reusing it for efficiency? - iv <- {-# SCC "iv" #-} maybe (return $ error "Should not be used") (const $ liftIO CS.randomIV) mkey - return $ yarToResponse (hr iv mnonce getExpires host exp') yar - where - hr iv mnonce getExpires host exp' hs ct sm = - hs''' - where - sessionVal = - case (mkey, mnonce) of - (Just key, Just nonce) - -> encodeSession key iv exp' host - $ Map.toList - $ Map.insert nonceKey (TE.encodeUtf8 nonce) sm - _ -> 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'' + yar <- handlerToYAR master sub toMasterRoute + (yesodRender master ra) errorHandler rr murl sessionMap h + extraHeaders <- case yar of + (YARPlain _ _ ct _ newSess) -> do + let nsNonce = Map.toList $ maybe + newSess + (\n -> Map.insert nonceKey (TE.encodeUtf8 n) newSess) + (reqNonce rr) + sessionHeaders <- liftIO $ maybe + (return []) + (\sb -> sbSaveSession sb master req now session nsNonce) + msb + return $ ("Content-Type", ct) : map headerToPair sessionHeaders + _ -> return [] + return $ yarToResponse yar extraHeaders 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 + diff --git a/yesod-core/Yesod/Internal/Request.hs b/yesod-core/Yesod/Internal/Request.hs index 063db67f..e477e900 100644 --- a/yesod-core/Yesod/Internal/Request.hs +++ b/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 - (Nothing, _) -> Nothing - (_, Just x) -> Just $ decodeUtf8With lenientDecode x - _ -> Just $ pack $ randomString 10 gen + nonce = case (useNonce, lookup nonceKey session') of + (False, _) -> Nothing + (_, Just x) -> Just $ decodeUtf8With lenientDecode x + _ -> Just $ pack $ randomString 10 gen addTwoLetters :: ([Text] -> [Text], Set.Set Text) -> [Text] -> [Text] addTwoLetters (toAdd, exist) [] = diff --git a/yesod-core/Yesod/Internal/Session.hs b/yesod-core/Yesod/Internal/Session.hs index 76fcef95..320f7b86 100644 --- a/yesod-core/Yesod/Internal/Session.hs +++ b/yesod-core/Yesod/Internal/Session.hs @@ -1,6 +1,6 @@ module Yesod.Internal.Session - ( encodeSession - , decodeSession + ( encodeClientSession + , 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 - -> CS.IV - -> UTCTime -- ^ expire time - -> ByteString -- ^ remote host - -> [(Text, ByteString)] -- ^ session - -> ByteString -- ^ cookie value -encodeSession key iv expire rhost session' = +encodeClientSession :: CS.Key + -> CS.IV + -> UTCTime -- ^ expire time + -> ByteString -- ^ remote host + -> [(Text, ByteString)] -- ^ session + -> ByteString -- ^ cookie value +encodeClientSession key iv expire rhost session' = CS.encrypt key iv $ encode $ SessionCookie expire rhost session' -decodeSession :: CS.Key - -> UTCTime -- ^ current time - -> ByteString -- ^ remote host field - -> ByteString -- ^ cookie value - -> Maybe [(Text, ByteString)] -decodeSession key now rhost encrypted = do +decodeClientSession :: CS.Key + -> UTCTime -- ^ current time + -> ByteString -- ^ remote host field + -> ByteString -- ^ cookie value + -> Maybe [(Text, ByteString)] +decodeClientSession key now rhost encrypted = do decrypted <- CS.decrypt key encrypted SessionCookie expire rhost' session' <- either (const Nothing) Just $ decode decrypted diff --git a/yesod-core/test/YesodCoreTest/InternalRequest.hs b/yesod-core/test/YesodCoreTest/InternalRequest.hs index b8c1a4db..b2696e9f 100644 --- a/yesod-core/test/YesodCoreTest/InternalRequest.hs +++ b/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] diff --git a/yesod/scaffold/Foundation.hs.cg b/yesod/scaffold/Foundation.hs.cg index 14e5b821..fc420fbf 100644 --- a/yesod/scaffold/Foundation.hs.cg +++ b/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 - encryptKey _ = fmap Just $ getKey "config/client_session_key.aes" + -- Store session data on the client in encrypted cookies, + -- 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 diff --git a/yesod/scaffold/tiny/Foundation.hs.cg b/yesod/scaffold/tiny/Foundation.hs.cg index f67df47e..2b3dd091 100644 --- a/yesod/scaffold/tiny/Foundation.hs.cg +++ b/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 - encryptKey _ = fmap Just $ getKey "config/client_session_key.aes" + -- Store session data on the client in encrypted cookies, + -- 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