diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,11 @@ +## 1.4.20 + +* `addMessage`, `addMessageI`, and `getMessages` functions + +## 1.4.19.1 + +* Allow lines of dashes in route files [#1182](https://github.com/yesodweb/yesod/pull/1182) + ## 1.4.19 * Auth logout not working with defaultCsrfMiddleware [#1151](https://github.com/yesodweb/yesod/issues/1151) diff --git a/Yesod/Core/Class/Yesod.hs b/Yesod/Core/Class/Yesod.hs --- a/Yesod/Core/Class/Yesod.hs +++ b/Yesod/Core/Class/Yesod.hs @@ -87,7 +87,7 @@ 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 @@ #{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/Handler.hs b/Yesod/Core/Handler.hs --- a/Yesod/Core/Handler.hs +++ b/Yesod/Core/Handler.hs @@ -136,6 +136,9 @@ , redirectUltDest , clearUltDest -- ** Messages + , addMessage + , addMessageI + , getMessages , setMessage , setMessageI , getMessage @@ -205,7 +208,7 @@ 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 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,31 +524,67 @@ 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'. +-- +-- @since 1.4.20 +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'. -setMessageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) - => msg -> m () -setMessageI msg = do +-- See 'getMessages'. +-- +-- @since 1.4.20 +addMessageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) + => Text -> msg -> m () +addMessageI status msg = do mr <- getMessageRender - setMessage $ toHtml $ mr msg + addMessage status $ toHtml $ mr msg --- | Gets the message in the user's session, if available, and then clears the --- variable. +-- | Gets all messages in the user's session, and then clears the variable. -- --- See 'setMessage'. -getMessage :: MonadHandler m => m (Maybe Html) -getMessage = do - mmsg <- liftM (fmap preEscapedToMarkup) $ lookupSession msgKey +-- See 'addMessage'. +-- +-- @since 1.4.20 +getMessages :: MonadHandler m => m [(Text, Html)] +getMessages = do + bs <- lookupSessionBS msgKey + let ms = maybe [] enlist bs deleteSession msgKey - return mmsg + 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 "" + +-- | Calls 'addMessageI' with an empty status +setMessageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) + => msg -> m () +setMessageI = addMessageI "" + +-- | Gets just the last message in the user's session, +-- discards the rest and the status +getMessage :: MonadHandler m => m (Maybe Html) +getMessage = (return . fmap snd . headMay) =<< getMessages + -- | Bypass remaining handler code and output the given file. -- -- For some backends, this is more efficient than reading in the file to @@ -580,6 +619,8 @@ -- | Bypass remaining handler code and output the given JSON with the given -- status code. +-- +-- Since 1.4.18 sendStatusJSON :: (MonadHandler m, ToJSON c) => H.Status -> c -> m a sendStatusJSON s v = sendResponseStatus s (toJSON v) diff --git a/Yesod/Core/Internal/Session.hs b/Yesod/Core/Internal/Session.hs --- a/Yesod/Core/Internal/Session.hs +++ b/Yesod/Core/Internal/Session.hs @@ -55,7 +55,7 @@ -- to preserve the type. clientSessionDateCacher :: - NominalDiffTime -- ^ Inactive session valitity. + NominalDiffTime -- ^ Inactive session validity. -> IO (IO ClientSessionDateCache, IO ()) clientSessionDateCacher validity = do getClientSessionDateCache <- mkAutoUpdate defaultUpdateSettings diff --git a/Yesod/Routes/Parse.hs b/Yesod/Routes/Parse.hs --- a/Yesod/Routes/Parse.hs +++ b/Yesod/Routes/Parse.hs @@ -18,7 +18,7 @@ import qualified System.IO as SIO import Yesod.Routes.TH import Yesod.Routes.Overlap (findOverlapNames) -import Data.List (foldl') +import Data.List (foldl', isPrefixOf) import Data.Maybe (mapMaybe) import qualified Data.Set as Set @@ -86,7 +86,7 @@ spaces = takeWhile (== ' ') thisLine (others, remainder) = parse indent otherLines' (this, otherLines') = - case takeWhile (/= "--") $ words thisLine of + case takeWhile (not . isPrefixOf "--") $ words thisLine of (pattern:rest0) | Just (constr:rest) <- stripColonLast rest0 , Just attrs <- mapM parseAttr rest -> diff --git a/test/Hierarchy.hs b/test/Hierarchy.hs --- a/test/Hierarchy.hs +++ b/test/Hierarchy.hs @@ -78,6 +78,8 @@ let resources = [parseRoutes| / HomeR GET +---------------------------------------- + /!#Int BackwardsR GET /admin/#Int AdminR: diff --git a/yesod-core.cabal b/yesod-core.cabal --- a/yesod-core.cabal +++ b/yesod-core.cabal @@ -1,5 +1,5 @@ name: yesod-core -version: 1.4.19 +version: 1.4.20 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>