diff --git a/yesod-core/Yesod/Core/Class.hs b/yesod-core/Yesod/Core/Class.hs index 3a657772..67ea88be 100644 --- a/yesod-core/Yesod/Core/Class.hs +++ b/yesod-core/Yesod/Core/Class.hs @@ -291,13 +291,32 @@ $doctype 5 -- | A Yesod middleware, which will wrap every handler function. This -- allows you to run code before and after a normal handler. -- - -- Default: Adds the response header \"Vary: Accept, Accept-Language\". + -- Default: Adds the response header \"Vary: Accept, Accept-Language\" and + -- performs authorization checks. -- -- Since: 1.1.6 yesodMiddleware :: GHandler sub a res -> GHandler sub a res yesodMiddleware handler = do setHeader "Vary" "Accept, Accept-Language" - handler + route <- getCurrentRoute + toMaster <- getRouteToMaster + case fmap toMaster route of + Nothing -> handler + Just url -> do + isWrite <- isWriteRequest url + ar <- isAuthorized url isWrite + case ar of + Authorized -> return () + AuthenticationRequired -> do + master <- getYesod + case authRoute master of + Nothing -> + permissionDenied "Authentication required" + Just url' -> do + setUltDestCurrent + redirect url' + Unauthorized s' -> permissionDenied s' + handler -- | Convert a widget to a 'PageContent'. widgetToPageContent :: (Eq (Route master), Yesod master) diff --git a/yesod-core/Yesod/Core/Run.hs b/yesod-core/Yesod/Core/Run.hs index a95588f6..c85de213 100644 --- a/yesod-core/Yesod/Core/Run.hs +++ b/yesod-core/Yesod/Core/Run.hs @@ -39,7 +39,6 @@ import Web.Cookie (renderSetCookie) import Yesod.Content import Yesod.Core.Class import Yesod.Core.Types -import Yesod.Handler import Yesod.Internal (tokenKey) import Yesod.Internal.Request (parseWaiRequest, tooLargeResponse) @@ -118,9 +117,8 @@ runHandler rhe@RunHandlerEnv {..} handler yreq = do let headers = ghsHeaders state let contents = either id (HCContent H.status200 . chooseRep) contents' let handleError e = do - yar <- eh e yreq - { reqOnError = safeEh - , reqSession = finalSession + yar <- rheOnError e yreq + { reqSession = finalSession } case yar of YRPlain _ hs ct c sess -> @@ -160,7 +158,6 @@ runHandler rhe@RunHandlerEnv {..} handler yreq = do finalSession HCWai r -> return $ YRWai r where - eh = reqOnError yreq cts = reqAccept yreq initSession = reqSession yreq @@ -229,6 +226,7 @@ runFakeHandler fakeSessionMap logger master handler = liftIO $ do , rheSub = master , rheUpload = fileUpload master , rheLog = messageLoggerSource master $ logger master + , rheOnError = errHandler } handler' errHandler err req = do @@ -263,7 +261,6 @@ runFakeHandler fakeSessionMap logger master handler = liftIO $ do , reqWaiRequest = fakeWaiRequest , reqLangs = [] , reqToken = Just "NaN" -- not a nonce =) - , reqOnError = errHandler , reqAccept = [] , reqSession = fakeSessionMap } @@ -279,30 +276,16 @@ defaultYesodRunner YesodRunnerEnv {..} handler' req | KnownLength len <- requestBodyLength req, maxLen < len = return tooLargeResponse | otherwise = do let dontSaveSession _ = return [] - let onError _ = error "FIXME: Yesod.Internal.Core.defaultYesodRunner.onError" (session, saveSession) <- liftIO $ do maybe (return (Map.empty, dontSaveSession)) (\sb -> sbLoadSession sb yreMaster req) yreSessionBackend - rr <- liftIO $ parseWaiRequest req session onError (isJust yreSessionBackend) maxLen <$> newStdGen - let h = {-# SCC "h" #-} do - case yreRoute of - Nothing -> handler - Just url -> do - isWrite <- isWriteRequest $ yreToMaster url - ar <- isAuthorized (yreToMaster url) isWrite - case ar of - Authorized -> return () - AuthenticationRequired -> - case authRoute yreMaster of - Nothing -> - permissionDenied "Authentication required" - Just url' -> do - setUltDestCurrent - redirect url' - Unauthorized s' -> permissionDenied s' - handler + yreq <- liftIO $ parseWaiRequest req session (isJust yreSessionBackend) maxLen <$> newStdGen let ra = resolveApproot yreMaster req let log' = messageLoggerSource yreMaster yreLogger - rhe = RunHandlerEnv + -- We set up two environments: the first one has a "safe" error handler + -- which will never throw an exception. The second one uses the + -- user-provided errorHandler function. If that errorHandler function + -- errors out, it will use the safeEh below to recover. + rheSafe = RunHandlerEnv { rheRender = yesodRender yreMaster ra , rheRoute = yreRoute , rheToMaster = yreToMaster @@ -310,16 +293,18 @@ defaultYesodRunner YesodRunnerEnv {..} handler' req , rheSub = yreSub , rheUpload = fileUpload yreMaster , rheLog = log' + , rheOnError = safeEh } - yar <- runHandler rhe h rr - { reqOnError = runHandler rhe . localNoCurrent . errorHandler - } + rhe = rheSafe + { rheOnError = runHandler rheSafe . localNoCurrent . errorHandler + } + yar <- runHandler rhe handler yreq extraHeaders <- case yar of (YRPlain _ _ ct _ newSess) -> do let nsToken = maybe newSess (\n -> Map.insert tokenKey (encodeUtf8 n) newSess) - (reqToken rr) + (reqToken yreq) sessionHeaders <- liftIO (saveSession nsToken) return $ ("Content-Type", ct) : map headerToPair sessionHeaders _ -> return [] diff --git a/yesod-core/Yesod/Core/Types.hs b/yesod-core/Yesod/Core/Types.hs index 0ba8f6cb..e731a1e7 100644 --- a/yesod-core/Yesod/Core/Types.hs +++ b/yesod-core/Yesod/Core/Types.hs @@ -105,10 +105,6 @@ data YesodRequest = YesodRequest -- ^ An ordered list of the accepted content types. -- -- Since 1.2.0 - , reqOnError :: !(ErrorResponse -> YesodApp) - -- ^ How to respond when an error is thrown internally. - -- - -- Since 1.2.0 } -- | An augmented WAI 'W.Response'. This can either be a standard @Response@, @@ -177,6 +173,10 @@ data RunHandlerEnv sub master = RunHandlerEnv , rheSub :: !sub , rheUpload :: !(RequestBodyLength -> FileUpload) , rheLog :: !(Loc -> LogSource -> LogLevel -> LogStr -> IO ()) + , rheOnError :: !(ErrorResponse -> YesodApp) + -- ^ How to respond when an error is thrown internally. + -- + -- Since 1.2.0 } data HandlerData sub master = HandlerData diff --git a/yesod-core/Yesod/Internal/Request.hs b/yesod-core/Yesod/Internal/Request.hs index 21dc06da..e687b098 100644 --- a/yesod-core/Yesod/Internal/Request.hs +++ b/yesod-core/Yesod/Internal/Request.hs @@ -70,12 +70,11 @@ tooLargeResponse = W.responseLBS parseWaiRequest :: RandomGen g => W.Request -> SessionMap - -> (ErrorResponse -> YesodApp) -> Bool -> Word64 -- ^ max body size -> g -> YesodRequest -parseWaiRequest env session onError useToken maxBodySize gen = +parseWaiRequest env session useToken maxBodySize gen = YesodRequest { reqGetParams = gets , reqCookies = cookies @@ -86,7 +85,6 @@ parseWaiRequest env session onError useToken maxBodySize gen = then Map.delete tokenKey session else session , reqAccept = httpAccept env - , reqOnError = onError } where gets = map (second $ fromMaybe "") diff --git a/yesod-core/test/YesodCoreTest/InternalRequest.hs b/yesod-core/test/YesodCoreTest/InternalRequest.hs index d9437da6..e31162c0 100644 --- a/yesod-core/test/YesodCoreTest/InternalRequest.hs +++ b/yesod-core/test/YesodCoreTest/InternalRequest.hs @@ -11,7 +11,6 @@ import Yesod.Request (YesodRequest (..)) import Test.Hspec import Data.Monoid (mempty) import Data.Map (singleton) -import Yesod.Core.Types (YesodApp, ErrorResponse) randomStringSpecs :: Spec randomStringSpecs = describe "Yesod.Internal.Request.randomString" $ do @@ -41,19 +40,19 @@ tokenSpecs = describe "Yesod.Internal.Request.parseWaiRequest (reqToken)" $ do noDisabledToken :: Bool noDisabledToken = reqToken r == Nothing where - r = parseWaiRequest defaultRequest mempty onError False 1000 g + r = parseWaiRequest defaultRequest mempty False 1000 g ignoreDisabledToken :: Bool ignoreDisabledToken = reqToken r == Nothing where - r = parseWaiRequest defaultRequest (singleton "_TOKEN" "old") onError False 1000 g + r = parseWaiRequest defaultRequest (singleton "_TOKEN" "old") False 1000 g useOldToken :: Bool useOldToken = reqToken r == Just "old" where - r = parseWaiRequest defaultRequest (singleton "_TOKEN" "old") onError True 1000 g + r = parseWaiRequest defaultRequest (singleton "_TOKEN" "old") True 1000 g generateToken :: Bool generateToken = reqToken r /= Nothing where - r = parseWaiRequest defaultRequest (singleton "_TOKEN" "old") onError True 1000 g + r = parseWaiRequest defaultRequest (singleton "_TOKEN" "old") True 1000 g langSpecs :: Spec @@ -67,21 +66,21 @@ langSpecs = describe "Yesod.Internal.Request.parseWaiRequest (reqLangs)" $ do respectAcceptLangs :: Bool respectAcceptLangs = reqLangs r == ["en-US", "es", "en"] where r = parseWaiRequest defaultRequest - { requestHeaders = [("Accept-Language", "en-US, es")] } mempty onError False 1000 g + { requestHeaders = [("Accept-Language", "en-US, es")] } mempty False 1000 g respectSessionLang :: Bool respectSessionLang = reqLangs r == ["en"] where - r = parseWaiRequest defaultRequest (singleton "_LANG" "en") onError False 1000 g + r = parseWaiRequest defaultRequest (singleton "_LANG" "en") False 1000 g respectCookieLang :: Bool respectCookieLang = reqLangs r == ["en"] where r = parseWaiRequest defaultRequest { requestHeaders = [("Cookie", "_LANG=en")] - } mempty onError False 1000 g + } mempty False 1000 g respectQueryLang :: Bool respectQueryLang = reqLangs r == ["en-US", "en"] where - r = parseWaiRequest defaultRequest { queryString = [("_LANG", Just "en-US")] } mempty onError False 1000 g + r = parseWaiRequest defaultRequest { queryString = [("_LANG", Just "en-US")] } mempty False 1000 g prioritizeLangs :: Bool prioritizeLangs = reqLangs r == ["en-QUERY", "en-COOKIE", "en-SESSION", "en", "es"] where @@ -90,10 +89,7 @@ prioritizeLangs = reqLangs r == ["en-QUERY", "en-COOKIE", "en-SESSION", "en", "e , ("Cookie", "_LANG=en-COOKIE") ] , queryString = [("_LANG", Just "en-QUERY")] - } (singleton "_LANG" "en-SESSION") onError False 10000 g - -onError :: ErrorResponse -> YesodApp -onError _ = error "Yesod.InternalRequest.onError" + } (singleton "_LANG" "en-SESSION") False 10000 g internalRequestTest :: Spec internalRequestTest = describe "Test.InternalRequestTest" $ do diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index e24337fe..1dca3862 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -97,7 +97,6 @@ library Yesod.Request Yesod.Widget Yesod.Internal.TestApi - Yesod.Core.Types other-modules: Yesod.Internal Yesod.Internal.Cache Yesod.Internal.Core @@ -107,6 +106,7 @@ library Yesod.Core.Trans.Class Yesod.Core.Run Yesod.Core.Class + Yesod.Core.Types Paths_yesod_core ghc-options: -Wall