diff --git a/yesod-auth/Yesod/Auth.hs b/yesod-auth/Yesod/Auth.hs index db9e7331..86de266f 100644 --- a/yesod-auth/Yesod/Auth.hs +++ b/yesod-auth/Yesod/Auth.hs @@ -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 diff --git a/yesod-auth/Yesod/Auth/Email.hs b/yesod-auth/Yesod/Auth/Email.hs index 2e0edd4b..88bba70f 100644 --- a/yesod-auth/Yesod/Auth/Email.hs +++ b/yesod-auth/Yesod/Auth/Email.hs @@ -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 diff --git a/yesod-auth/Yesod/Auth/GoogleEmail2.hs b/yesod-auth/Yesod/Auth/GoogleEmail2.hs index d7097f95..82a80a77 100644 --- a/yesod-auth/Yesod/Auth/GoogleEmail2.hs +++ b/yesod-auth/Yesod/Auth/GoogleEmail2.hs @@ -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 diff --git a/yesod-core/Yesod/Core/Class/Yesod.hs b/yesod-core/Yesod/Core/Class/Yesod.hs index b8ee2abe..5147fed7 100644 --- a/yesod-core/Yesod/Core/Class/Yesod.hs +++ b/yesod-core/Yesod/Core/Class/Yesod.hs @@ -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 #{pageTitle p} ^{pageHead p} <body> - $maybe msg <- mmsg - <p .message>#{msg} + $forall (status, msg) <- msgs + <p class="message #{status}">#{msg} ^{pageBody p} |] diff --git a/yesod-core/Yesod/Core/Handler.hs b/yesod-core/Yesod/Core/Handler.hs index 7f908c80..d9c0e173 100644 --- a/yesod-core/Yesod/Core/Handler.hs +++ b/yesod-core/Yesod/Core/Handler.hs @@ -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. --