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

BackendSession => SessionMap

Browse Source
This commit is contained in:
Michael Snoyman 2013-03-10 11:13:19 +02:00
parent 98613278d4
commit 4f1a6b461e
6 changed files with 30 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -38,7 +38,6 @@ module Yesod.Core
, clientSessionDateCacher
, loadClientSession
, Header(..)
, BackendSession
-- * JS loaders
, loadJsYepnope
, ScriptLoadPosition (..)

15
yesod-core/Yesod/Core/Types.hs
View File

@ -27,6 +27,7 @@ import Data.Conduit (Flush, MonadThrow (..),
import Data.IntMap (IntMap)
import Data.IORef (IORef)
import Data.Map (Map, unionWith)
import qualified Data.Map as Map
import Data.Monoid (Any, Endo (..), Last (..),
Monoid (..))
import Data.Serialize (Serialize (..),
@ -53,30 +54,30 @@ import Yesod.Core.Trans.Class (MonadLift (..))
import Yesod.Routes.Class (RenderRoute (..))
-- Sessions
type BackendSession = [(Text, ByteString)]
type SessionMap = Map Text ByteString
type SaveSession = BackendSession -- ^ The session contents after running the handler
type SaveSession = SessionMap -- ^ The session contents after running the handler
-> IO [Header]
newtype SessionBackend master = SessionBackend
{ sbLoadSession :: master
-> W.Request
-> IO (BackendSession, SaveSession) -- ^ Return the session data and a function to save the session
-> IO (SessionMap, SaveSession) -- ^ Return the session data and a function to save the session
}
data SessionCookie = SessionCookie (Either UTCTime ByteString) ByteString [(Text, ByteString)]
data SessionCookie = SessionCookie (Either UTCTime ByteString) ByteString SessionMap
deriving (Show, Read)
instance Serialize SessionCookie where
put (SessionCookie a b c) = do
either putTime putByteString a
put b
put (map (first T.unpack) c)
put (map (first T.unpack) $ Map.toList c)
get = do
a <- getTime
b <- get
c <- map (first T.pack) <$> get
return $ SessionCookie (Left a) b c
return $ SessionCookie (Left a) b (Map.fromList c)
data ClientSessionDateCache =
ClientSessionDateCache {
@ -174,8 +175,6 @@ data GHState = GHState
, ghsHeaders :: Endo [Header]
}
type SessionMap = Map Text ByteString
-- | An extension of the basic WAI 'W.Application' datatype to provide extra
-- features needed by Yesod. Users should never need to use this directly, as
-- the 'GHandler' monad and template haskell code should hide it away.

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

@ -28,7 +28,6 @@ module Yesod.Internal.Core
, clientSessionBackend
, loadClientSession
, clientSessionDateCacher
, BackendSession
-- * jsLoader
, ScriptLoadPosition (..)
, BottomOfHeadAsync
@ -424,7 +423,7 @@ defaultYesodRunner logger handler' master sub murl toMasterRoute msb req
| otherwise = do
let dontSaveSession _ = return []
(session, saveSession) <- liftIO $ do
maybe (return ([], dontSaveSession)) (\sb -> sbLoadSession sb master req) msb
maybe (return (Map.empty, dontSaveSession)) (\sb -> sbLoadSession sb master req) msb
rr <- liftIO $ parseWaiRequest req session (isJust msb) maxLen
let h = {-# SCC "h" #-} do
case murl of
@ -443,14 +442,14 @@ defaultYesodRunner logger handler' master sub murl toMasterRoute msb req
redirect url'
Unauthorized s' -> permissionDenied s'
handler
let sessionMap = Map.fromList . filter ((/=) tokenKey . fst) $ session
let sessionMap = Map.filterWithKey (\k _v -> k /= tokenKey) $ session
let ra = resolveApproot master req
let log' = messageLoggerSource master logger
yar <- handlerToYAR master sub (fileUpload master) log' toMasterRoute
(yesodRender master ra) errorHandler rr murl sessionMap h
extraHeaders <- case yar of
(YARPlain _ _ ct _ newSess) -> do
let nsToken = Map.toList $ maybe
let nsToken = maybe
newSess
(\n -> Map.insert tokenKey (TE.encodeUtf8 n) newSess)
(reqToken rr)
@ -745,13 +744,13 @@ loadClientSession :: Yesod master
-> S8.ByteString -- ^ session name
-> master
-> W.Request
-> IO (BackendSession, SaveSession)
-> IO (SessionMap, SaveSession)
loadClientSession key getCachedDate sessionName master req = load
where
load = do
date <- getCachedDate
return (sess date, save date)
sess date = fromMaybe [] $ do
sess date = fromMaybe Map.empty $ do
raw <- lookup "Cookie" $ W.requestHeaders req
val <- lookup sessionName $ parseCookies raw
let host = "" -- fixme, properly lock sessions to client address

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

@ -44,9 +44,10 @@ import Data.Word (Word64)
import Control.Monad.IO.Class (liftIO)
import Control.Exception (throwIO)
import Yesod.Core.Types
import qualified Data.Map as Map
parseWaiRequest :: W.Request
-> [(Text, ByteString)] -- ^ session
-> SessionMap
-> Bool
-> Word64 -- ^ maximum allowed body size
-> IO Request
@ -80,7 +81,7 @@ tooLargeResponse = W.responseLBS
parseWaiRequest' :: RandomGen g
=> W.Request
-> [(Text, ByteString)] -- ^ session
-> SessionMap
-> Bool
-> Word64 -- ^ max body size
-> g
@ -95,7 +96,7 @@ parseWaiRequest' env session' useToken maxBodySize gen =
acceptLang = lookup "Accept-Language" $ W.requestHeaders env
langs = map (pack . S8.unpack) $ maybe [] NWP.parseHttpAccept acceptLang
lookupText k = fmap (decodeUtf8With lenientDecode) . lookup k
lookupText k = fmap (decodeUtf8With lenientDecode) . Map.lookup k
-- The language preferences are prioritized as follows:
langs' = catMaybes [ join $ lookup langKey gets' -- Query _LANG
@ -116,7 +117,7 @@ parseWaiRequest' env session' useToken maxBodySize gen =
else Just $ maybe
(pack $ randomString 10 gen)
(decodeUtf8With lenientDecode)
(lookup tokenKey session')
(Map.lookup tokenKey session')
addTwoLetters :: ([Text] -> [Text], Set.Set Text) -> [Text] -> [Text]
addTwoLetters (toAdd, exist) [] =

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

@ -3,7 +3,6 @@ module Yesod.Internal.Session
, decodeClientSession
, clientSessionDateCacher
, ClientSessionDateCache(..)
, BackendSession
, SaveSession
, SessionBackend(..)
) where
@ -14,7 +13,6 @@ import Data.Time
import Data.ByteString (ByteString)
import Control.Concurrent (forkIO, killThread, threadDelay)
import Control.Monad (forever, guard)
import Data.Text (Text)
import Yesod.Core.Types
import Yesod.Core.Time
import qualified Data.IORef as I
@ -23,7 +21,7 @@ encodeClientSession :: CS.Key
-> CS.IV
-> ClientSessionDateCache -- ^ expire time
-> ByteString -- ^ remote host
-> [(Text, ByteString)] -- ^ session
-> SessionMap -- ^ session
-> ByteString -- ^ cookie value
encodeClientSession key iv date rhost session' =
CS.encrypt key iv $ encode $ SessionCookie expires rhost session'
@ -33,7 +31,7 @@ decodeClientSession :: CS.Key
-> ClientSessionDateCache -- ^ current time
-> ByteString -- ^ remote host field
-> ByteString -- ^ cookie value
-> Maybe [(Text, ByteString)]
-> Maybe SessionMap
decodeClientSession key date rhost encrypted = do
decrypted <- CS.decrypt key encrypted
SessionCookie (Left expire) rhost' session' <-

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

@ -9,6 +9,8 @@ import Network.Wai.Test
import Yesod.Internal.TestApi (randomString, parseWaiRequest')
import Yesod.Request (Request (..))
import Test.Hspec
import Data.Monoid (mempty)
import Data.Map (singleton)
randomStringSpecs :: Spec
randomStringSpecs = describe "Yesod.Internal.Request.randomString" $ do
@ -38,19 +40,19 @@ tokenSpecs = describe "Yesod.Internal.Request.parseWaiRequest (reqToken)" $ do
noDisabledToken :: Bool
noDisabledToken = reqToken r == Nothing where
r = parseWaiRequest' defaultRequest [] False 1000 g
r = parseWaiRequest' defaultRequest mempty False 1000 g
ignoreDisabledToken :: Bool
ignoreDisabledToken = reqToken r == Nothing where
r = parseWaiRequest' defaultRequest [("_TOKEN", "old")] False 1000 g
r = parseWaiRequest' defaultRequest (singleton "_TOKEN" "old") False 1000 g
useOldToken :: Bool
useOldToken = reqToken r == Just "old" where
r = parseWaiRequest' defaultRequest [("_TOKEN", "old")] True 1000 g
r = parseWaiRequest' defaultRequest (singleton "_TOKEN" "old") True 1000 g
generateToken :: Bool
generateToken = reqToken r /= Nothing where
r = parseWaiRequest' defaultRequest [("_TOKEN", "old")] True 1000 g
r = parseWaiRequest' defaultRequest (singleton "_TOKEN" "old") True 1000 g
langSpecs :: Spec
@ -64,21 +66,21 @@ langSpecs = describe "Yesod.Internal.Request.parseWaiRequest (reqLangs)" $ do
respectAcceptLangs :: Bool
respectAcceptLangs = reqLangs r == ["en-US", "es", "en"] where
r = parseWaiRequest' defaultRequest
{ requestHeaders = [("Accept-Language", "en-US, es")] } [] False 1000 g
{ requestHeaders = [("Accept-Language", "en-US, es")] } mempty False 1000 g
respectSessionLang :: Bool
respectSessionLang = reqLangs r == ["en"] where
r = parseWaiRequest' defaultRequest [("_LANG", "en")] False 1000 g
r = parseWaiRequest' defaultRequest (singleton "_LANG" "en") False 1000 g
respectCookieLang :: Bool
respectCookieLang = reqLangs r == ["en"] where
r = parseWaiRequest' defaultRequest
{ requestHeaders = [("Cookie", "_LANG=en")]
} [] False 1000 g
} mempty False 1000 g
respectQueryLang :: Bool
respectQueryLang = reqLangs r == ["en-US", "en"] where
r = parseWaiRequest' defaultRequest { queryString = [("_LANG", Just "en-US")] } [] False 1000 g
r = parseWaiRequest' defaultRequest { queryString = [("_LANG", Just "en-US")] } mempty False 1000 g
prioritizeLangs :: Bool
prioritizeLangs = reqLangs r == ["en-QUERY", "en-COOKIE", "en-SESSION", "en", "es"] where
@ -87,7 +89,7 @@ prioritizeLangs = reqLangs r == ["en-QUERY", "en-COOKIE", "en-SESSION", "en", "e
, ("Cookie", "_LANG=en-COOKIE")
]
, queryString = [("_LANG", Just "en-QUERY")]
} [("_LANG", "en-SESSION")] False 10000 g
} (singleton "_LANG" "en-SESSION") False 10000 g
internalRequestTest :: Spec