From c3f236ce9cd1f9761fb544714e17c58ec919ffb6 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 10 May 2010 16:33:05 +0300 Subject: [PATCH] Ultimate dest and messages --- Yesod/Handler.hs | 72 ++++++++++++++++++++++++++++++++++++++ Yesod/Helpers/EmailAuth.hs | 22 +++--------- Yesod/Request.hs | 7 ++++ 3 files changed, 84 insertions(+), 17 deletions(-) diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index f4921e7a..a9fb2325 100644 --- a/Yesod/Handler.hs +++ b/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 diff --git a/Yesod/Helpers/EmailAuth.hs b/Yesod/Helpers/EmailAuth.hs index dcbbde1c..d0ec8825 100644 --- a/Yesod/Helpers/EmailAuth.hs +++ b/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 diff --git a/Yesod/Request.hs b/Yesod/Request.hs index 5d4feb18..3a96a633 100644 --- a/Yesod/Request.hs +++ b/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