diff --git a/Yesod/Hamlet.hs b/Yesod/Hamlet.hs index e8947155..f11bd3ba 100644 --- a/Yesod/Hamlet.hs +++ b/Yesod/Hamlet.hs @@ -45,7 +45,7 @@ data PageContent url = PageContent -- Yesod 'Response'. hamletToContent :: Hamlet (Routes master) IO () -> GHandler sub master Content hamletToContent h = do - render <- getUrlRenderMaster + render <- getUrlRender return $ ContentEnum $ go render where go render iter seed = do diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index d29821b0..f4921e7a 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -26,20 +26,23 @@ module Yesod.Handler , GHandler -- ** Read information from handler , getYesod - , getYesodMaster + , getYesodSub , getUrlRender - , getUrlRenderMaster , getRoute , getRouteToMaster -- * Special responses + -- ** Redirecting , RedirectType (..) , redirect + , redirectParams , redirectString - , sendFile + -- ** Errors , notFound , badMethod , permissionDenied , invalidArgs + -- ** Sending static files + , sendFile -- * Setting headers , addCookie , deleteCookie @@ -59,6 +62,7 @@ import Yesod.Internal import Web.Mime import Web.Routes.Quasi (Routes) import Data.List (foldl') +import Web.Encodings (encodeUrlPairs) import Control.Exception hiding (Handler, catch) import qualified Control.Exception as E @@ -153,23 +157,17 @@ instance RequestReader (GHandler sub master) where getData :: GHandler sub master (HandlerData sub master) getData = Handler $ \r -> return ([], [], HCContent r) --- | Get the application argument. -getYesod :: GHandler sub master sub -getYesod = handlerSub <$> getData +-- | Get the sub application argument. +getYesodSub :: GHandler sub master sub +getYesodSub = handlerSub <$> getData -- | Get the master site appliation argument. -getYesodMaster :: GHandler sub master master -getYesodMaster = handlerMaster <$> getData +getYesod :: GHandler sub master master +getYesod = handlerMaster <$> getData -- | Get the URL rendering function. -getUrlRender :: GHandler sub master (Routes sub -> String) -getUrlRender = do - d <- getData - return $ handlerRender d . handlerToMaster d - --- | Get the URL rendering function for the master site. -getUrlRenderMaster :: GHandler sub master (Routes master -> String) -getUrlRenderMaster = handlerRender <$> getData +getUrlRender :: GHandler sub master (Routes master -> String) +getUrlRender = handlerRender <$> getData -- | Get the route requested by the user. If this is a 404 response- where the -- user requested an invalid route- this function will return 'Nothing'. @@ -243,9 +241,16 @@ safeEh er = YesodApp $ \_ _ _ -> do -- | Redirect to the given route. redirect :: RedirectType -> Routes master -> GHandler sub master a redirect rt url = do - r <- getUrlRenderMaster + r <- getUrlRender redirectString rt $ r url +-- | Redirects to the given route with the associated query-string parameters. +redirectParams :: RedirectType -> Routes master -> [(String, String)] + -> GHandler sub master a +redirectParams rt url params = do + r <- getUrlRender + redirectString rt $ r url ++ '?' : encodeUrlPairs params + -- | Redirect to the given URL. redirectString :: RedirectType -> String -> GHandler sub master a redirectString rt url = Handler $ \_ -> return ([], [], HCRedirect rt url) diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 09eed898..763201c5 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -108,11 +108,12 @@ getOpenIdForward = do [x] -> return x _ -> invalidArgs [("openid", show ExpectedSingleParam)] render <- getUrlRender - let complete = render OpenIdComplete + toMaster <- getRouteToMaster + let complete = render $ toMaster OpenIdComplete res <- runAttemptT $ OpenId.getForwardUrl oid complete - let errurl err = render OpenIdR ++ "?message=" ++ encodeUrl (show err) attempt - (\err -> redirectString RedirectTemporary $ errurl err) + (\err -> redirectParams RedirectTemporary (toMaster OpenIdR) + [("message", show err)]) (redirectString RedirectTemporary) res @@ -121,19 +122,20 @@ getOpenIdComplete = do rr <- getRequest let gets' = reqGetParams rr res <- runAttemptT $ OpenId.authenticate gets' - render <- getUrlRender - renderm <- getUrlRenderMaster + renderm <- getUrlRender + toMaster <- getRouteToMaster + let render = renderm . toMaster let errurl err = render OpenIdR ++ "?message=" ++ encodeUrl (show err) let onFailure err = redirectString RedirectTemporary $ errurl err let onSuccess (OpenId.Identifier ident) = do - y <- getYesodMaster + y <- getYesod setSession identKey ident redirectToDest RedirectTemporary $ renderm $ defaultDest y attempt onFailure onSuccess res handleRpxnowR :: YesodAuth master => GHandler Auth master () handleRpxnowR = do - ay <- getYesodMaster + ay <- getYesod apiKey <- case rpxnowApiKey ay of Just x -> return x Nothing -> notFound @@ -142,11 +144,11 @@ handleRpxnowR = do let token = case getParams rr "token" ++ pp "token" of [] -> failure MissingToken (x:_) -> x - render <- getUrlRenderMaster + renderm <- getUrlRender let dest = case pp "dest" of [] -> case getParams rr "dest" of - [] -> render $ defaultDest ay - ("":_) -> render $ defaultDest ay + [] -> renderm $ defaultDest ay + ("":_) -> renderm $ defaultDest ay (('#':rest):_) -> rest (s:_) -> s (d:_) -> d @@ -189,9 +191,9 @@ getCheck = do getLogout :: YesodAuth master => GHandler Auth master () getLogout = do - y <- getYesodMaster + y <- getYesod clearSession identKey - render <- getUrlRenderMaster + render <- getUrlRender redirectToDest RedirectTemporary $ render $ defaultDest y -- | Gets the identifier for a user if available. @@ -215,7 +217,7 @@ authIdentifier = maybeIdentifier >>= maybe redirectLogin return -- appropriately. redirectLogin :: YesodAuth master => GHandler sub master a redirectLogin = do - y <- getYesodMaster + y <- getYesod let r = case defaultLoginType y of OpenId -> OpenIdR Rpxnow -> RpxnowR -- FIXME this doesn't actually show a login page? @@ -228,9 +230,10 @@ redirectSetDest :: RedirectType -> GHandler sub master a redirectSetDest rt dest = do ur <- getUrlRender + tm <- getRouteToMaster curr <- getRoute let curr' = case curr of - Just x -> ur x + Just x -> ur $ tm x Nothing -> "/" -- should never happen anyway addCookie destCookieTimeout destCookieName curr' redirect rt dest diff --git a/Yesod/Helpers/EmailAuth.hs b/Yesod/Helpers/EmailAuth.hs index 0474ff85..46c64066 100644 --- a/Yesod/Helpers/EmailAuth.hs +++ b/Yesod/Helpers/EmailAuth.hs @@ -80,7 +80,7 @@ getRegisterR = do postRegisterR :: YesodEmailAuth master => GHandler EmailAuth master RepHtml postRegisterR = do email <- runFormPost $ checkEmail $ required $ input "email" - y <- getYesodMaster + y <- getYesod creds <- liftIO $ getCreds y email (lid, verKey) <- case creds of @@ -90,7 +90,8 @@ postRegisterR = do return (lid, key) Just (lid, _, _, key) -> return (lid, key) render <- getUrlRender - let verUrl = render $ VerifyR lid verKey + tm <- getRouteToMaster + let verUrl = render $ tm $ VerifyR lid verKey liftIO $ sendVerifyEmail y email verKey verUrl applyLayout "Confirmation e-mail sent" $ [$hamlet| %p A confirmation e-mail has been sent to $cs.email$. @@ -102,7 +103,7 @@ checkEmail = notEmpty -- FIXME getVerifyR :: YesodEmailAuth master => Integer -> String -> GHandler EmailAuth master RepHtml getVerifyR lid key = do - y <- getYesodMaster + y <- getYesod realKey <- liftIO $ getVerifyKey y lid memail <- liftIO $ getEmail y lid case (realKey == Just key, memail) of @@ -157,7 +158,7 @@ postLoginR = do (email, pass) <- runFormPost $ (,) <$> checkEmail (required $ input "email") <*> required (input "password") - y <- getYesodMaster + y <- getYesod creds <- liftIO $ getCreds y email let mlid = case creds of @@ -216,7 +217,7 @@ postPasswordR = do setMessage "You must be logged in to set a password" redirect RedirectTemporary $ toMaster LoginR salted <- liftIO $ saltPass new - y <- getYesodMaster + y <- getYesod liftIO $ setPassword y lid salted setMessage "Password updated" redirect RedirectTemporary $ toMaster LoginR @@ -226,7 +227,7 @@ getLogoutR = do clearSession identKey clearSession displayNameKey clearSession emailAuthIdKey - y <- getYesodMaster + y <- getYesod redirect RedirectTemporary $ onSuccessfulLogout y saltLength :: Int @@ -257,7 +258,7 @@ setLoginSession email lid = do setSession identKey email setSession displayNameKey email setSession emailAuthIdKey $ show lid - y <- getYesodMaster + y <- getYesod liftIO $ onEmailAuthLogin y email lid isLoggedIn :: GHandler sub master (Maybe Integer) diff --git a/Yesod/Helpers/Sitemap.hs b/Yesod/Helpers/Sitemap.hs index 9116dd0c..3c150abc 100644 --- a/Yesod/Helpers/Sitemap.hs +++ b/Yesod/Helpers/Sitemap.hs @@ -67,5 +67,5 @@ sitemap = fmap RepXml . hamletToContent . template robots :: Routes sub -- ^ sitemap url -> GHandler sub master RepPlain robots smurl = do - r <- getUrlRender - return $ RepPlain $ cs $ "Sitemap: " ++ r smurl + tm <- getRouteToMaster + RepPlain `fmap` hamletToContent [$hamlet|Sitemap: @tm.smurl@|] diff --git a/Yesod/Helpers/Static.hs b/Yesod/Helpers/Static.hs index c8b24dd5..1e133f5f 100644 --- a/Yesod/Helpers/Static.hs +++ b/Yesod/Helpers/Static.hs @@ -77,7 +77,7 @@ getStatic fl fp' = do getStaticRoute :: [String] -> GHandler Static master [(ContentType, Content)] getStaticRoute fp = do - Static fl <- getYesod + Static fl <- getYesodSub getStatic fl fp toStaticRoute :: [String] -> StaticRoutes