Ultimate dest and messages

Yesod/Handler.hs

@@ -50,6 +50,14 @@ module Yesod.Handler
       -- * Session
     , setSession
     , clearSession
+      -- ** Ultimate destination
+    , setUltDest
+    , setUltDestString
+    , setUltDest'
+    , redirectUltDest
+      -- ** Messages
+    , setMessage
+    , getMessage
       -- * Internal Yesod
     , runHandler
     , YesodApp (..)
@@ -83,6 +91,9 @@ import qualified Data.ByteString.Lazy as BL
 import qualified Network.Wai as W
 
 import Data.Convertible.Text (cs)
+import Text.Hamlet
+import Data.Text (Text)
+import Web.Encodings (encodeHtml)
 
 data HandlerData sub master = HandlerData
     { handlerRequest :: Request
@@ -255,6 +266,67 @@ redirectParams rt url params = do
 redirectString :: RedirectType -> String -> GHandler sub master a
 redirectString rt url = Handler $ \_ -> return ([], [], HCRedirect rt url)
 
+ultDestKey :: String
+ultDestKey = "_ULT"
+
+-- | Sets the ultimate destination variable to the given route.
+--
+-- An ultimate destination is stored in the user session and can be loaded
+-- later by 'redirectUltDest'.
+setUltDest :: Routes master -> GHandler sub master ()
+setUltDest dest = do
+    render <- getUrlRender
+    setUltDestString $ render dest
+
+-- | Same as 'setUltDest', but use the given string.
+setUltDestString :: String -> GHandler sub master ()
+setUltDestString = setSession ultDestKey
+
+-- | Same as 'setUltDest', but uses the current page.
+--
+-- If this is a 404 handler, there is no current page, and then this call does
+-- nothing.
+setUltDest' :: GHandler sub master ()
+setUltDest' = do
+    route <- getRoute
+    tm <- getRouteToMaster
+    maybe (return ()) setUltDest $ tm <$> route
+
+-- | Redirect to the ultimate destination in the user's session. Clear the
+-- value from the session.
+--
+-- The ultimate destination is set with 'setUltDest'.
+redirectUltDest :: RedirectType
+                -> Routes master -- ^ default destination if nothing in session
+                -> GHandler sub master ()
+redirectUltDest rt def = do
+    mdest <- lookupSession ultDestKey
+    clearSession ultDestKey
+    maybe (redirect rt def) (redirectString rt) mdest
+
+msgKey :: String
+msgKey = "_MSG"
+
+-- | Sets a message in the user's session.
+--
+-- See 'getMessage'.
+setMessage :: HtmlContent -> GHandler sub master ()
+setMessage = setSession msgKey . cs . htmlContentToText
+
+-- | Gets the message in the user's session, if available, and then clears the
+-- variable.
+--
+-- See 'setMessage'.
+getMessage :: GHandler sub master (Maybe HtmlContent)
+getMessage = do
+    clearSession msgKey
+    (fmap $ fmap $ Encoded . cs) $ lookupSession msgKey
+
+-- | FIXME move this definition into hamlet
+htmlContentToText :: HtmlContent -> Text
+htmlContentToText (Encoded t) = t
+htmlContentToText (Unencoded t) = encodeHtml t
+
 -- | Bypass remaining handler code and output the given file.
 --
 -- For some backends, this is more efficient than reading in the file to

Yesod/Helpers/EmailAuth.hs

@@ -116,18 +116,6 @@ getVerifyR lid key = do
 %p I'm sorry, but that was an invalid verification key.
         |]
 
-messageKey :: String
-messageKey = "MESSAGE"
-
-getMessage :: GHandler sub master (Maybe HtmlContent)
-getMessage = do
-    s <- session
-    clearSession messageKey
-    return $ listToMaybe $ map (Encoded . cs) $ s messageKey
-
-setMessage :: String -> GHandler sub master ()
-setMessage = setSession messageKey . cs
-
 getLoginR :: Yesod master => GHandler EmailAuth master RepHtml
 getLoginR = do
     toMaster <- getRouteToMaster
@@ -170,7 +158,7 @@ postLoginR = do
             setLoginSession email lid
             redirect RedirectTemporary $ onSuccessfulLogin y
         Nothing -> do
-            setMessage "Invalid email/password combination"
+            setMessage $ cs "Invalid email/password combination"
             toMaster <- getRouteToMaster
             redirect RedirectTemporary $ toMaster LoginR
 
@@ -179,7 +167,7 @@ getPasswordR = do
     l <- isJust <$> isLoggedIn
     toMaster <- getRouteToMaster
     unless l $ do
-        setMessage "You must be logged in to set a password"
+        setMessage $ cs "You must be logged in to set a password"
         redirect RedirectTemporary $ toMaster LoginR
     msg <- getMessage
     applyLayout "Set password" (return ()) [$hamlet|
@@ -208,18 +196,18 @@ postPasswordR = do
         <*> notEmpty (required $ input "confirm")
     toMaster <- getRouteToMaster
     when (new /= confirm) $ do
-        setMessage "Passwords did not match, please try again"
+        setMessage $ cs "Passwords did not match, please try again"
         redirect RedirectTemporary $ toMaster PasswordR
     mlid <- isLoggedIn
     lid <- case mlid of
             Just lid -> return lid
             Nothing -> do
-                setMessage "You must be logged in to set a password"
+                setMessage $ cs "You must be logged in to set a password"
                 redirect RedirectTemporary $ toMaster LoginR
     salted <- liftIO $ saltPass new
     y <- getYesod
     liftIO $ setPassword y lid salted
-    setMessage "Password updated"
+    setMessage $ cs "Password updated"
     redirect RedirectTemporary $ toMaster LoginR
 
 getLogoutR :: YesodEmailAuth master => GHandler EmailAuth master RepHtml

Yesod/Request.hs

@@ -28,6 +28,7 @@ module Yesod.Request
     , postParams
     , cookies
     , session
+    , lookupSession
       -- * Parameter type synonyms
     , ParamName
     , ParamValue
@@ -113,3 +114,9 @@ session :: RequestReader m => m (ParamName -> [ParamValue])
 session = do
     rr <- getRequest
     return $ multiLookup $ reqSession rr
+
+-- | Lookup for session data.
+lookupSession :: RequestReader m => ParamName -> m (Maybe ParamValue)
+lookupSession pn = do
+    rr <- getRequest
+    return $ lookup pn $ reqSession rr