BackendSession => SessionMap

yesod-core/Yesod/Core.hs

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

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.

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

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

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

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