State for session

Yesod/Dispatch.hs

@@ -71,6 +71,8 @@ import Web.Routes
 import Control.Arrow (first)
 import System.Random (randomR, newStdGen)
 
+import qualified Data.Map as Map
+
 #if TEST
 import Test.Framework (testGroup, Test)
 import Test.Framework.Providers.QuickCheck2 (testProperty)
@@ -265,10 +267,12 @@ toWaiApp' y segments env = do
     let eurl' = either (const Nothing) Just eurl
     let eh er = runHandler (errorHandler' er) render eurl' id y id
     let ya = runHandler h render eurl' id y id
-    (s, hs, ct, c, sessionFinal) <- unYesodApp ya eh rr types
+    let sessionMap = Map.fromList
+                   $ filter (\(x, _) -> x /= nonceKey) session'
+    (s, hs, ct, c, sessionFinal) <- unYesodApp ya eh rr types sessionMap
     let sessionVal = encodeSession key' exp' host
-                   $ (nonceKey, reqNonce rr)
+                   $ Map.toList
-                   : sessionFinal
+                   $ Map.insert nonceKey (reqNonce rr) sessionFinal
     let hs' = AddCookie (clientSessionDuration y) sessionName
                                                   (bsToChars sessionVal)
             : hs
@@ -337,7 +341,7 @@ parseWaiRequest env session' = do
                 Nothing -> do
                     g <- newStdGen
                     return $ fst $ randomString 10 g
-    return $ Request gets' cookies' session' rbthunk env langs''' nonce
+    return $ Request gets' cookies' rbthunk env langs''' nonce
   where
     randomString len =
         first (map toChar) . sequence' (replicate len (randomR (0, 61)))

Yesod/Handler.hs

@@ -58,6 +58,7 @@ module Yesod.Handler
     , alreadyExpired
     , expiresAt
       -- * Session
+    , lookupSession
     , setSession
     , deleteSession
       -- ** Ultimate destination
@@ -82,7 +83,6 @@ module Yesod.Handler
 import Prelude hiding (catch)
 import Yesod.Request
 import Yesod.Internal
-import Data.List (foldl')
 import Data.Neither
 import Data.Time (UTCTime)
 
@@ -94,6 +94,7 @@ import Control.Monad.IO.Class
 import Control.Monad.Trans.Class
 import Control.Monad.Trans.Writer
 import Control.Monad.Trans.Reader
+import Control.Monad.Trans.State
 
 import System.IO
 import qualified Network.Wai as W
@@ -103,6 +104,7 @@ import Text.Hamlet
 
 import Control.Monad.Invert (MonadInvertIO (..))
 import Control.Monad (liftM)
+import qualified Data.Map as Map
 
 #if TEST
 import Test.Framework (testGroup, Test)
@@ -162,16 +164,18 @@ type GHInner s m =
     ReaderT (HandlerData s m) (
     MEitherT HandlerContents (
     WriterT (Endo [Header]) (
-    WriterT (Endo [(String, Maybe String)]) (
+    StateT SessionMap ( -- session
     IO
     ))))
 
+type SessionMap = Map.Map String String
+
 instance MonadInvertIO (GHandler s m) where
     newtype InvertedIO (GHandler s m) a =
         InvGHandlerIO
             { runInvGHandlerIO :: InvertedIO (GHInner s m) a
             }
-    type InvertedArg (GHandler s m) = (HandlerData s m, ())
+    type InvertedArg (GHandler s m) = (HandlerData s m, (SessionMap, ()))
     invertIO = liftM (fmap InvGHandlerIO) . invertIO . unGHandler
     revertIO f = GHandler $ revertIO $ liftM runInvGHandlerIO . f
 
@@ -185,7 +189,8 @@ newtype YesodApp = YesodApp
     :: (ErrorResponse -> YesodApp)
     -> Request
     -> [ContentType]
-    -> IO (W.Status, [Header], ContentType, Content, [(String, String)])
+    -> SessionMap
+    -> IO (W.Status, [Header], ContentType, Content, SessionMap)
     }
 
 data HandlerContents =
@@ -227,16 +232,6 @@ getCurrentRoute = handlerRoute <$> GHandler ask
 getRouteToMaster :: GHandler sub master (Route sub -> Route master)
 getRouteToMaster = handlerToMaster <$> GHandler ask
 
-modifySession :: [(String, String)] -> (String, Maybe String)
-              -> [(String, String)]
-modifySession orig (k, v) =
-    case v of
-        Nothing -> dropKeys k orig
-        Just v' -> (k, v') : dropKeys k orig
-
-dropKeys :: String -> [(String, x)] -> [(String, x)]
-dropKeys k = filter $ \(x, _) -> x /= k
-
 -- | Function used internally by Yesod in the process of converting a
 -- 'GHandler' into an 'W.Application'. Should not be needed by users.
 runHandler :: HasReps c
@@ -247,7 +242,8 @@ runHandler :: HasReps c
            -> master
            -> (master -> sub)
            -> YesodApp
-runHandler handler mrender sroute tomr ma tosa = YesodApp $ \eh rr cts -> do
+runHandler handler mrender sroute tomr ma tosa =
+  YesodApp $ \eh rr cts initSession -> do
     let toErrorHandler =
             InternalError
           . (show :: Control.Exception.SomeException -> String)
@@ -259,17 +255,16 @@ runHandler handler mrender sroute tomr ma tosa = YesodApp $ \eh rr cts -> do
             , handlerRender = mrender
             , handlerToMaster = tomr
             }
-    ((contents', headers), session') <- E.catch (
+    ((contents', headers), finalSession) <- E.catch (
-        runWriterT
+        flip runStateT initSession
       $ runWriterT
       $ runMEitherT
       $ flip runReaderT hd
       $ unGHandler handler
-        ) (\e -> return ((MLeft $ HCError $ toErrorHandler e, id), id))
+        ) (\e -> return ((MLeft $ HCError $ toErrorHandler e, id), initSession))
     let contents = meither id (HCContent . chooseRep) contents'
-    let finalSession = foldl' modifySession (reqSession rr) $ session' []
     let handleError e = do
-            (_, hs, ct, c, sess) <- unYesodApp (eh e) safeEh rr cts
+            (_, hs, ct, c, sess) <- unYesodApp (eh e) safeEh rr cts finalSession
             let hs' = headers hs
             return (getStatus e, hs', ct, c, sess)
     let sendFile' ct fp =
@@ -288,9 +283,10 @@ runHandler handler mrender sroute tomr ma tosa = YesodApp $ \eh rr cts -> do
             (handleError . toErrorHandler)
 
 safeEh :: ErrorResponse -> YesodApp
-safeEh er = YesodApp $ \_ _ _ -> do
+safeEh er = YesodApp $ \_ _ _ session -> do
     liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er
-    return (W.status500, [], typePlain, toContent "Internal Server Error", [])
+    return (W.status500, [], typePlain, toContent "Internal Server Error",
+            session)
 
 -- | Redirect to the given route.
 redirect :: RedirectType -> Route master -> GHandler sub master a
@@ -334,9 +330,9 @@ setUltDest' = do
         Nothing -> return ()
         Just r -> do
             tm <- getRouteToMaster
-            gets <- reqGetParams <$> getRequest
+            gets' <- reqGetParams <$> getRequest
             render <- getUrlRenderParams
-            setUltDestString $ render (tm r) gets
+            setUltDestString $ render (tm r) gets'
 
 -- | Redirect to the ultimate destination in the user's session. Clear the
 -- value from the session.
@@ -355,9 +351,6 @@ msgKey = "_MSG"
 
 -- | Sets a message in the user's session.
 --
--- The message set here will not be visible within the current request;
--- instead, it will only appear in the next request.
---
 -- See 'getMessage'.
 setMessage :: Html -> GHandler sub master ()
 setMessage = setSession msgKey . lbsToChars . renderHtml
@@ -412,7 +405,8 @@ setCookie a b = addHeader . AddCookie a b
 deleteCookie :: String -> GHandler sub master ()
 deleteCookie = addHeader . DeleteCookie
 
--- | Set the language in the user session. Will show up in 'languages'.
+-- | Set the language in the user session. Will show up in 'languages' on the
+-- next request.
 setLanguage :: String -> GHandler sub master ()
 setLanguage = setSession langKey
 
@@ -448,17 +442,14 @@ expiresAt = setHeader "Expires" . formatRFC1123
 -- The session is handled by the clientsession package: it sets an encrypted
 -- and hashed cookie on the client. This ensures that all data is secure and
 -- not tampered with.
---
--- Please note that the value you set here will not be available via
--- 'getSession' until the /next/ request.
 setSession :: String -- ^ key
            -> String -- ^ value
            -> GHandler sub master ()
-setSession k v = GHandler . lift . lift . lift . tell $ (:) (k, Just v)
+setSession k = GHandler . lift . lift . lift . modify . Map.insert k
 
 -- | Unsets a session variable. See 'setSession'.
 deleteSession :: String -> GHandler sub master ()
-deleteSession k = GHandler . lift . lift . lift . tell $ (:) (k, Nothing)
+deleteSession = GHandler . lift . lift . lift . modify . Map.delete
 
 -- | Internal use only, not to be confused with 'setHeader'.
 addHeader :: Header -> GHandler sub master ()
@@ -486,6 +477,12 @@ localNoCurrent :: GHandler s m a -> GHandler s m a
 localNoCurrent =
     GHandler . local (\hd -> hd { handlerRoute = Nothing }) . unGHandler
 
+-- | Lookup for session data.
+lookupSession :: ParamName -> GHandler s m (Maybe ParamValue)
+lookupSession n = GHandler $ do
+    m <- lift $ lift $ lift get
+    return $ Map.lookup n m
+
 #if TEST
 
 testSuite :: Test

Yesod/Request.hs

@@ -28,13 +28,11 @@ module Yesod.Request
     , lookupGetParam
     , lookupPostParam
     , lookupCookie
-    , lookupSession
     , lookupFile
       -- ** Multi-lookup
     , lookupGetParams
     , lookupPostParams
     , lookupCookies
-    , lookupSessions
     , lookupFiles
       -- * Parameter type synonyms
     , ParamName
@@ -98,8 +96,6 @@ data FileInfo = FileInfo
 data Request = Request
     { reqGetParams :: [(ParamName, ParamValue)]
     , reqCookies :: [(ParamName, ParamValue)]
-      -- | Session data stored in a cookie via the clientsession package.
-    , reqSession :: [(ParamName, ParamValue)]
       -- | The POST parameters and submitted files. This is stored in an IO
       -- thunk, which essentially means it will be computed once at most, but
       -- only if requested. This allows avoidance of the potentially costly
@@ -163,13 +159,3 @@ lookupCookies :: RequestReader m => ParamName -> m [ParamValue]
 lookupCookies pn = do
     rr <- getRequest
     return $ lookup' pn $ reqCookies rr
-
--- | Lookup for session data.
-lookupSession :: RequestReader m => ParamName -> m (Maybe ParamValue)
-lookupSession = liftM listToMaybe . lookupSessions
-
--- | Lookup for session data.
-lookupSessions :: RequestReader m => ParamName -> m [ParamValue]
-lookupSessions pn = do
-    rr <- getRequest
-    return $ lookup' pn $ reqSession rr

Yesod/Widget.hs

@@ -47,6 +47,7 @@ import Yesod.Internal
 
 import Control.Monad.Invert (MonadInvertIO (..))
 import Control.Monad (liftM)
+import qualified Data.Map as Map
 
 -- | A generic widget, allowing specification of both the subsite and master
 -- site datatypes. This is basically a large 'WriterT' stack keeping track of
@@ -73,7 +74,7 @@ instance MonadInvertIO (GWidget s m) where
             { runInvGWidgetIO :: InvertedIO (GWInner s m) a
             }
     type InvertedArg (GWidget s m) =
-        (Int, (HandlerData s m, ()))
+        (Int, (HandlerData s m, (Map.Map String String, ())))
     invertIO = liftM (fmap InvGWidgetIO) . invertIO . unGWidget
     revertIO f = GWidget $ revertIO $ liftM runInvGWidgetIO . f
 

hellowidget.hs

@@ -37,10 +37,10 @@ wrapper h = [$hamlet|
 #wrapper ^h^
 %footer Brought to you by Yesod Widgets™
 |]
-getRootR = defaultLayout $ flip wrapWidget wrapper $ do
+getRootR = defaultLayout $ wrapper $ do
     i <- newIdent
     setTitle $ string "Hello Widgets"
-    addStyle [$cassius|
+    addCassius [$cassius|
 #$i$
     color: red
 |]
@@ -48,7 +48,7 @@ getRootR = defaultLayout $ flip wrapWidget wrapper $ do
     addStylesheetRemote "http://localhost:3000/static/style2.css"
     addScriptRemote "http://ajax.googleapis.com/ajax/libs/jquery/1.4.2/jquery.min.js"
     addScript $ StaticR $ StaticRoute ["script.js"] []
-    addBody [$hamlet|
+    addHamlet [$hamlet|
 %h1#$i$ Welcome to my first widget!!!
 %p
     %a!href=@RootR@ Recursive link.
@@ -58,10 +58,10 @@ getRootR = defaultLayout $ flip wrapWidget wrapper $ do
     %a!href=@CustomFormR@ Custom form arrangement.
 %p.noscript Your script did not load. :(
 |]
-    addHead [$hamlet|%meta!keywords=haskell|]
+    addHtmlHead [$hamlet|%meta!keywords=haskell|]
 
 handleFormR = do
-    (res, form, enctype, hidden) <- runFormPost $ fieldsToTable $ (,,,,,,,,,,)
+    (res, form, enctype, hidden) <- runFormPost $ fieldsToTable $ (,,,,,,,,,)
         <$> stringField (FormFieldSettings "My Field" "Some tooltip info" Nothing Nothing) Nothing
         <*> stringField ("Another field") (Just "some default text")
         <*> intField (FormFieldSettings "A number field" "some nums" Nothing Nothing) (Just 5)
@@ -72,7 +72,6 @@ handleFormR = do
                 , jdsNumberOfMonths = Right (2, 3)
                 } ("A day field") Nothing
         <*> timeField ("A time field") Nothing
-        <*> jqueryDayTimeField ("A day/time field") Nothing
         <*> boolField FormFieldSettings
                 { ffsLabel = "A checkbox"
                 , ffsTooltip = ""
@@ -86,23 +85,23 @@ handleFormR = do
         <*> maybeEmailField ("An e-mail addres") Nothing
         <*> maybeTextareaField "A text area" Nothing
     let mhtml = case res of
-                    FormSuccess (_, _, _, _, _, _, _, _, x, _, _) -> Just x
+                    FormSuccess (_, _, _, _, _, _, _, x, _, _) -> Just x
                     _ -> Nothing
     let txt = case res of
-                    FormSuccess (_, _, _, _, _, _, _, _, _, _, Just x) -> Just x
+                    FormSuccess (_, _, _, _, _, _, _, _, _, Just x) -> Just x
                     _ -> Nothing
     defaultLayout $ do
-        addStyle [$cassius|
+        addCassius [$cassius|
 .tooltip
     color: #666
     font-style: italic
 |]
-        addStyle [$cassius|
+        addCassius [$cassius|
 textarea.html
     width: 300px
     height: 150px
 |]
-        wrapWidget form $ \h -> [$hamlet|
+        addWidget [$hamlet|
 $maybe formFailures.res failures
     %ul.errors
         $forall failures f
@@ -110,7 +109,7 @@ $maybe formFailures.res failures
 %form!method=post!enctype=$enctype$
     $hidden$
     %table
-        ^h^
+        ^form^
         %tr
             %td!colspan=2
                 %input!type=submit
@@ -140,7 +139,7 @@ getCustomFormR = do
             let b = do
                     b1' <- extractBody b1
                     b2' <- extractBody b2
-                    addBody [$hamlet|
+                    addHamlet [$hamlet|
 %p This is a custom layout.
 %h1 Name Follows!
 %p ^b1'^
@@ -150,7 +149,7 @@ getCustomFormR = do
     (_, wform, enctype) <- runFormGet customForm
     defaultLayout $ do
         form <- extractBody wform
-        addBody [$hamlet|
+        addHamlet [$hamlet|
 %form
     ^form^
     %div

yesod.cabal

@@ -48,6 +48,7 @@ library
                    , xss-sanitize              >= 0.2      && < 0.3
                    , data-default              >= 0.2      && < 0.3
                    , failure                   >= 0.1      && < 0.2
+                   , containers                >= 0.2      && < 0.5
     exposed-modules: Yesod
                      Yesod.Content
                      Yesod.Dispatch