allow more than one session message and add statuses

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

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 forgotPasswordRes = ForgotPasswordForm <$> emailRes
-         let widget = do
+        let widget = do
-             [whamlet|
+            [whamlet|
-                 #{extra}
+                #{extra}
-                 ^{fvLabel emailView}
+                ^{fvLabel emailView}
-                 ^{fvInput 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

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
 

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
                     <title>#{pageTitle p}
                     ^{pageHead p}
                 <body>
-                    $maybe msg <- mmsg
+                    $forall (status, msg) <- msgs
-                        <p .message>#{msg}
+                        <p class="message #{status}">#{msg}
                     ^{pageBody p}
             |]
 

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'.
+-- See 'getMessages'.
-setMessage :: MonadHandler m => Html -> m ()
+addMessage :: MonadHandler m
-setMessage = setSession msgKey . T.concat . TL.toChunks . RenderText.renderHtml
+           => 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
+setMessageI = addMessageI ""
-    mr <- getMessageRender
+{-# DEPRECATED setMessageI "Please use addMessageI instead" #-}
-    setMessage $ toHtml $ mr msg
 
--- | Gets the message in the user's session, if available, and then clears the
+-- | Gets just the last message in the user's session,
--- variable.
+-- discards the rest and the status
---
--- See 'setMessage'.
 getMessage :: MonadHandler m => m (Maybe Html)
-getMessage = do
+getMessage = (return . fmap snd . headMay) =<< getMessages
-    mmsg <- liftM (fmap preEscapedToMarkup) $ lookupSession msgKey
+{-# DEPRECATED getMessage "Please use getMessages instead" #-}
-    deleteSession msgKey
-    return mmsg
 
 -- | Bypass remaining handler code and output the given file.
 --