Better error handling and auth checking

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)

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
+            yar <- rheOnError e yreq
-                { reqOnError = safeEh
+                { reqSession = finalSession
-                , 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
+    yreq <- liftIO $ parseWaiRequest req session (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
     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
+        rhe = rheSafe
-        { reqOnError = runHandler rhe . localNoCurrent . errorHandler
+            { 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 []

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

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 "")

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
+        } (singleton "_LANG" "en-SESSION") False 10000 g
-
-onError :: ErrorResponse -> YesodApp
-onError _ = error "Yesod.InternalRequest.onError"
 
 internalRequestTest :: Spec
 internalRequestTest = describe "Test.InternalRequestTest" $ do

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