allow more than one session message and add statuses
This commit is contained in:
Murray
parent
e7c6d06d3d
commit
a15070709d
@ -189,9 +189,9 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
|
||||
authHttpManager :: master -> Manager
|
||||
|
||||
-- | Called on a successful login. By default, calls
|
||||
-- @setMessageI NowLoggedIn@.
|
||||
-- @addMessageI "success" NowLoggedIn@.
|
||||
onLogin :: HandlerT master IO ()
|
||||
onLogin = setMessageI Msg.NowLoggedIn
|
||||
onLogin = addMessageI "success" Msg.NowLoggedIn
|
||||
|
||||
-- | Called on logout. By default, does nothing
|
||||
onLogout :: HandlerT master IO ()
|
||||
@ -214,10 +214,10 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
|
||||
maybeAuthId = defaultMaybeAuthId
|
||||
|
||||
-- | Called on login error for HTTP requests. By default, calls
|
||||
-- @setMessage@ and redirects to @dest@.
|
||||
-- @addMessage@ with "error" as status and redirects to @dest@.
|
||||
onErrorHtml :: (MonadResourceBase m) => Route master -> Text -> HandlerT master m Html
|
||||
onErrorHtml dest msg = do
|
||||
setMessage $ toHtml msg
|
||||
addMessage "error" $ toHtml msg
|
||||
fmap asHtml $ redirect dest
|
||||
|
||||
-- | runHttpRequest gives you a chance to handle an HttpException and retry
|
||||
|
||||
@ -437,17 +437,17 @@ defaultForgotPasswordHandler = do
|
||||
|]
|
||||
where
|
||||
forgotPasswordForm extra = do
|
||||
(emailRes, emailView) <- mreq emailField emailSettings Nothing
|
||||
(emailRes, emailView) <- mreq emailField emailSettings Nothing
|
||||
|
||||
let forgotPasswordRes = ForgotPasswordForm <$> emailRes
|
||||
let widget = do
|
||||
[whamlet|
|
||||
#{extra}
|
||||
^{fvLabel emailView}
|
||||
^{fvInput emailView}
|
||||
|]
|
||||
let forgotPasswordRes = ForgotPasswordForm <$> emailRes
|
||||
let widget = do
|
||||
[whamlet|
|
||||
#{extra}
|
||||
^{fvLabel emailView}
|
||||
^{fvInput emailView}
|
||||
|]
|
||||
return (forgotPasswordRes, widget)
|
||||
|
||||
return (forgotPasswordRes, widget)
|
||||
emailSettings =
|
||||
FieldSettings {
|
||||
fsLabel = SomeMessage Msg.ProvideIdentifier,
|
||||
@ -479,7 +479,7 @@ getVerifyR lid key = do
|
||||
let msgAv = Msg.AddressVerified
|
||||
selectRep $ do
|
||||
provideRep $ do
|
||||
lift $ setMessageI msgAv
|
||||
lift $ addMessageI "success" msgAv
|
||||
fmap asHtml $ redirect setpassR
|
||||
provideJsonMessage $ mr msgAv
|
||||
_ -> invalidKey mr
|
||||
@ -650,7 +650,7 @@ postPasswordR = do
|
||||
y <- lift $ do
|
||||
setPassword aid salted
|
||||
deleteSession loginLinkKey
|
||||
setMessageI msgOk
|
||||
addMessageI "success" msgOk
|
||||
getYesod
|
||||
|
||||
mr <- lift getMessageRender
|
||||
|
||||
@ -59,7 +59,7 @@ import Yesod.Core (HandlerSite, HandlerT, MonadHandler,
|
||||
lift, liftIO, lookupGetParam,
|
||||
lookupSession, notFound, redirect,
|
||||
setSession, whamlet, (.:),
|
||||
setMessage, getYesod, authRoute,
|
||||
addMessage, getYesod, authRoute,
|
||||
toHtml)
|
||||
|
||||
|
||||
@ -200,7 +200,7 @@ authPlugin storeToken clientID clientSecret =
|
||||
case err of
|
||||
"access_denied" -> "Access denied"
|
||||
_ -> "Unknown error occurred: " `T.append` err
|
||||
setMessage $ toHtml msg
|
||||
addMessage "error" $ toHtml msg
|
||||
lift $ redirect $ logoutDest master
|
||||
Just c -> return c
|
||||
|
||||
|
||||
@ -87,7 +87,7 @@ class RenderRoute site => Yesod site where
|
||||
defaultLayout :: WidgetT site IO () -> HandlerT site IO Html
|
||||
defaultLayout w = do
|
||||
p <- widgetToPageContent w
|
||||
mmsg <- getMessage
|
||||
msgs <- getMessages
|
||||
withUrlRenderer [hamlet|
|
||||
$newline never
|
||||
$doctype 5
|
||||
@ -96,8 +96,8 @@ class RenderRoute site => Yesod site where
|
||||
<title>#{pageTitle p}
|
||||
^{pageHead p}
|
||||
<body>
|
||||
$maybe msg <- mmsg
|
||||
<p .message>#{msg}
|
||||
$forall (status, msg) <- msgs
|
||||
<p class="message #{status}">#{msg}
|
||||
^{pageBody p}
|
||||
|]
|
||||
|
||||
|
||||
@ -136,6 +136,9 @@ module Yesod.Core.Handler
|
||||
, redirectUltDest
|
||||
, clearUltDest
|
||||
-- ** Messages
|
||||
, addMessage
|
||||
, addMessageI
|
||||
, getMessages
|
||||
, setMessage
|
||||
, setMessageI
|
||||
, getMessage
|
||||
@ -205,7 +208,7 @@ import qualified Data.Text as T
|
||||
import Data.Text.Encoding (decodeUtf8With, encodeUtf8)
|
||||
import Data.Text.Encoding.Error (lenientDecode)
|
||||
import qualified Data.Text.Lazy as TL
|
||||
import qualified Text.Blaze.Html.Renderer.Text as RenderText
|
||||
import Text.Blaze.Html.Renderer.Utf8 (renderHtml)
|
||||
import Text.Hamlet (Html, HtmlUrl, hamlet)
|
||||
|
||||
import qualified Data.ByteString as S
|
||||
@ -223,7 +226,7 @@ import Text.Shakespeare.I18N (RenderMessage (..))
|
||||
import Web.Cookie (SetCookie (..))
|
||||
import Yesod.Core.Content (ToTypedContent (..), simpleContentType, contentTypeTypes, HasContentType (..), ToContent (..), ToFlushBuilder (..))
|
||||
import Yesod.Core.Internal.Util (formatRFC1123)
|
||||
import Text.Blaze.Html (preEscapedToMarkup, toHtml)
|
||||
import Text.Blaze.Html (preEscapedToHtml, toHtml)
|
||||
|
||||
import qualified Data.IORef.Lifted as I
|
||||
import Data.Maybe (listToMaybe, mapMaybe)
|
||||
@ -521,30 +524,63 @@ clearUltDest = deleteSession ultDestKey
|
||||
msgKey :: Text
|
||||
msgKey = "_MSG"
|
||||
|
||||
-- | Sets a message in the user's session.
|
||||
-- | Adds a status and message in the user's session.
|
||||
--
|
||||
-- See 'getMessage'.
|
||||
setMessage :: MonadHandler m => Html -> m ()
|
||||
setMessage = setSession msgKey . T.concat . TL.toChunks . RenderText.renderHtml
|
||||
-- See 'getMessages'.
|
||||
addMessage :: MonadHandler m
|
||||
=> Text -- ^ status
|
||||
-> Html -- ^ message
|
||||
-> m ()
|
||||
addMessage status msg = do
|
||||
val <- lookupSessionBS msgKey
|
||||
setSessionBS msgKey $ addMsg val
|
||||
where
|
||||
addMsg = maybe msg' (S.append msg' . S.cons W8._nul)
|
||||
msg' = S.append
|
||||
(encodeUtf8 status)
|
||||
(W8._nul `S.cons` (L.toStrict $ renderHtml msg))
|
||||
|
||||
-- | Sets a message in the user's session.
|
||||
-- | Adds a message in the user's session but uses RenderMessage to allow for i18n
|
||||
--
|
||||
-- See 'getMessage'.
|
||||
-- See 'getMessages'.
|
||||
addMessageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg)
|
||||
=> Text -> msg -> m ()
|
||||
addMessageI status msg = do
|
||||
mr <- getMessageRender
|
||||
addMessage status $ toHtml $ mr msg
|
||||
|
||||
-- | Gets all messages in the user's session, and then clears the variable.
|
||||
--
|
||||
-- See 'addMessage'.
|
||||
getMessages :: MonadHandler m => m [(Text, Html)]
|
||||
getMessages = do
|
||||
bs <- lookupSessionBS msgKey
|
||||
let ms = maybe [] enlist bs
|
||||
deleteSession msgKey
|
||||
return ms
|
||||
where
|
||||
enlist = pairup . S.split W8._nul
|
||||
pairup [] = []
|
||||
pairup [x] = []
|
||||
pairup (s:v:xs) = (decode s, preEscapedToHtml (decode v)) : pairup xs
|
||||
decode = decodeUtf8With lenientDecode
|
||||
|
||||
-- | Calls 'addMessage' with an empty status
|
||||
setMessage :: MonadHandler m => Html -> m ()
|
||||
setMessage = addMessage ""
|
||||
{-# DEPRECATED setMessage "Please use addMessage instead" #-}
|
||||
|
||||
-- | Calls 'addMessageI' with an empty status
|
||||
setMessageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg)
|
||||
=> msg -> m ()
|
||||
setMessageI msg = do
|
||||
mr <- getMessageRender
|
||||
setMessage $ toHtml $ mr msg
|
||||
setMessageI = addMessageI ""
|
||||
{-# DEPRECATED setMessageI "Please use addMessageI instead" #-}
|
||||
|
||||
-- | Gets the message in the user's session, if available, and then clears the
|
||||
-- variable.
|
||||
--
|
||||
-- See 'setMessage'.
|
||||
-- | Gets just the last message in the user's session,
|
||||
-- discards the rest and the status
|
||||
getMessage :: MonadHandler m => m (Maybe Html)
|
||||
getMessage = do
|
||||
mmsg <- liftM (fmap preEscapedToMarkup) $ lookupSession msgKey
|
||||
deleteSession msgKey
|
||||
return mmsg
|
||||
getMessage = (return . fmap snd . headMay) =<< getMessages
|
||||
{-# DEPRECATED getMessage "Please use getMessages instead" #-}
|
||||
|
||||
-- | Bypass remaining handler code and output the given file.
|
||||
--
|
||||
|
||||
Loading…
Reference in New Issue
Block a user