State for session
This commit is contained in:
Michael Snoyman
parent
05b4d3e9ce
commit
1069df2665
@ -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)))
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user