From 1069df2665fce6e95c1c11217f4047192e9a8255 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 26 Oct 2010 08:38:45 +0200 Subject: [PATCH] State for session --- Yesod/Dispatch.hs | 12 ++++++--- Yesod/Handler.hs | 63 ++++++++++++++++++++++------------------------- Yesod/Request.hs | 14 ----------- Yesod/Widget.hs | 3 ++- hellowidget.hs | 27 ++++++++++---------- yesod.cabal | 1 + 6 files changed, 54 insertions(+), 66 deletions(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 5ffe1ab9..ff79c15b 100644 --- a/Yesod/Dispatch.hs +++ b/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) - : sessionFinal + $ Map.toList + $ 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))) diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 3f9146c0..b0e30e34 100644 --- a/Yesod/Handler.hs +++ b/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 ( - runWriterT + ((contents', headers), finalSession) <- E.catch ( + 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 diff --git a/Yesod/Request.hs b/Yesod/Request.hs index f90973c7..d526ff65 100644 --- a/Yesod/Request.hs +++ b/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 diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs index b9cbc69f..037787f5 100644 --- a/Yesod/Widget.hs +++ b/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 diff --git a/hellowidget.hs b/hellowidget.hs index fb408f13..b70e6603 100644 --- a/hellowidget.hs +++ b/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 diff --git a/yesod.cabal b/yesod.cabal index 3cf19cb4..228f7a02 100644 --- a/yesod.cabal +++ b/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