From 4f1a6b461e61e870c0246a1ad602f4397beb72da Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 10 Mar 2013 11:13:19 +0200 Subject: [PATCH] BackendSession => SessionMap --- yesod-core/Yesod/Core.hs | 1 - yesod-core/Yesod/Core/Types.hs | 15 +++++++------- yesod-core/Yesod/Internal/Core.hs | 11 +++++----- yesod-core/Yesod/Internal/Request.hs | 9 +++++---- yesod-core/Yesod/Internal/Session.hs | 6 ++---- .../test/YesodCoreTest/InternalRequest.hs | 20 ++++++++++--------- 6 files changed, 30 insertions(+), 32 deletions(-) diff --git a/yesod-core/Yesod/Core.hs b/yesod-core/Yesod/Core.hs index 4f3dfa2f..a5a51fb6 100644 --- a/yesod-core/Yesod/Core.hs +++ b/yesod-core/Yesod/Core.hs @@ -38,7 +38,6 @@ module Yesod.Core , clientSessionDateCacher , loadClientSession , Header(..) - , BackendSession -- * JS loaders , loadJsYepnope , ScriptLoadPosition (..) diff --git a/yesod-core/Yesod/Core/Types.hs b/yesod-core/Yesod/Core/Types.hs index 49c57f13..dbae7210 100644 --- a/yesod-core/Yesod/Core/Types.hs +++ b/yesod-core/Yesod/Core/Types.hs @@ -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. diff --git a/yesod-core/Yesod/Internal/Core.hs b/yesod-core/Yesod/Internal/Core.hs index f0b9764c..8fa83280 100644 --- a/yesod-core/Yesod/Internal/Core.hs +++ b/yesod-core/Yesod/Internal/Core.hs @@ -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 diff --git a/yesod-core/Yesod/Internal/Request.hs b/yesod-core/Yesod/Internal/Request.hs index 74539a48..96805318 100644 --- a/yesod-core/Yesod/Internal/Request.hs +++ b/yesod-core/Yesod/Internal/Request.hs @@ -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) [] = diff --git a/yesod-core/Yesod/Internal/Session.hs b/yesod-core/Yesod/Internal/Session.hs index 0dc0de9e..5d1c3cb2 100644 --- a/yesod-core/Yesod/Internal/Session.hs +++ b/yesod-core/Yesod/Internal/Session.hs @@ -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' <- diff --git a/yesod-core/test/YesodCoreTest/InternalRequest.hs b/yesod-core/test/YesodCoreTest/InternalRequest.hs index 5344aa38..65827d39 100644 --- a/yesod-core/test/YesodCoreTest/InternalRequest.hs +++ b/yesod-core/test/YesodCoreTest/InternalRequest.hs @@ -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