haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Make session storage configurable

Browse Source
This commit is contained in:
Luite Stegeman 2012-02-10 19:22:31 +01:00
parent 6b4f181b49
commit b5b27f2b15
9 changed files with 164 additions and 114 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
yesod-core/Yesod/Core.hs
View File

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

9
yesod-core/Yesod/Dispatch.hs
View File

@ -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

14
yesod-core/Yesod/Handler.hs
View File

@ -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

169
yesod-core/Yesod/Internal/Core.hs
View File

@ -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

18
yesod-core/Yesod/Internal/Request.hs
View File

@ -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) [] =

30
yesod-core/Yesod/Internal/Session.hs
View File

@ -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

18
yesod-core/test/YesodCoreTest/InternalRequest.hs
View File

@ -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]

7
yesod/scaffold/Foundation.hs.cg
View File

@ -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

7
yesod/scaffold/tiny/Foundation.hs.cg
View File

@ -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