Merge pull request #1772 from SupercedeTech/make-exception-catching-configurable

Make catching exceptions configurable.

yesod-core/ChangeLog.md

@@ -1,5 +1,9 @@
 # ChangeLog for yesod-core
 
+## 1.6.24.0
+
+* Make catching exceptions configurable and set the default back to rethrowing async exceptions. [#1772](https://github.com/yesodweb/yesod/pull/1772).
+
 ## 1.6.23.1
 
 * Fix typo in creation of the description `<meta>` tag in `defaultLayout`. [#1766](https://github.com/yesodweb/yesod/pull/1766)

yesod-core/src/Yesod/Core/Class/Yesod.hs

@@ -1,7 +1,9 @@
-{-# LANGUAGE FlexibleContexts  #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE QuasiQuotes       #-}
-{-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE FlexibleContexts    #-}
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE QuasiQuotes         #-}
+{-# LANGUAGE TemplateHaskell     #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
 module Yesod.Core.Class.Yesod where
 
 import           Yesod.Core.Content
@@ -52,8 +54,10 @@ import           Yesod.Core.Types
 import           Yesod.Core.Internal.Session
 import           Yesod.Core.Widget
 import Data.CaseInsensitive (CI)
+import qualified Network.Wai.Handler.Warp as Warp
 import qualified Network.Wai.Request
 import Data.IORef
+import UnliftIO (SomeException, catch, MonadUnliftIO)
 
 -- | Define settings for a Yesod applications. All methods have intelligent
 -- defaults, and therefore no implementation is required.
@@ -70,6 +74,16 @@ class RenderRoute site => Yesod site where
     approot :: Approot site
     approot = guessApproot
 
+    -- | @since 1.6.24.0
+    --  allows the user to specify how exceptions are cought.
+    --  by default all async exceptions are thrown and synchronous
+    --  exceptions render a 500 page.
+    -- To catch all exceptions (even async) to render a 500 page, 
+    -- set this to 'UnliftIO.Exception.catchSyncOrAsync'. Beware
+    -- this may have negative effects with functions like 'timeout'.
+    catchHandlerExceptions :: MonadUnliftIO m => site -> m a -> (SomeException -> m a) -> m a
+    catchHandlerExceptions _ = catch
+
     -- | Output error response pages.
     --
     -- Default value: 'defaultErrorHandler'.

yesod-core/src/Yesod/Core/Internal/Run.hs

@@ -1,10 +1,11 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PatternGuards     #-}
-{-# LANGUAGE RankNTypes        #-}
-{-# LANGUAGE RecordWildCards   #-}
-{-# LANGUAGE TemplateHaskell   #-}
-{-# LANGUAGE TupleSections     #-}
-{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE PatternGuards       #-}
+{-# LANGUAGE RankNTypes          #-}
+{-# LANGUAGE RecordWildCards     #-}
+{-# LANGUAGE TemplateHaskell     #-}
+{-# LANGUAGE TupleSections       #-}
+{-# LANGUAGE FlexibleContexts    #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 module Yesod.Core.Internal.Run
   ( toErrorHandler
   , errFromShow
@@ -54,28 +55,7 @@ import           Yesod.Routes.Class           (Route, renderRoute)
 import           Control.DeepSeq              (($!!), NFData)
 import           UnliftIO.Exception
 import           UnliftIO(MonadUnliftIO, withRunInIO)
-
--- | like `catch` but doesn't check for async exceptions,
---   thereby catching them too.
---   This is desirable for letting yesod generate a 500 error page
---   rather then warp.
---
---   Normally this is VERY dubious. you need to rethrow.
---   recovrery from async isn't allowed.
---   see async section: https://www.fpcomplete.com/blog/2018/04/async-exception-handling-haskell/
-unsafeAsyncCatch
-  :: (MonadUnliftIO m, Exception e)
-  => m a -- ^ action
-  -> (e -> m a) -- ^ handler
-  -> m a
-unsafeAsyncCatch f g = withRunInIO $ \run -> run f `EUnsafe.catch` \e -> do
-    run (g e)
-
-unsafeAsyncCatchAny :: (MonadUnliftIO m)
-  => m a -- ^ action
-  -> (SomeException -> m a) -- ^ handler
-  -> m a
-unsafeAsyncCatchAny = unsafeAsyncCatch
+import           Data.Proxy(Proxy(..))
 
 -- | Convert a synchronous exception into an ErrorResponse
 toErrorHandler :: SomeException -> IO ErrorResponse
@@ -108,7 +88,7 @@ basicRunHandler rhe handler yreq resState = do
 
     -- Run the handler itself, capturing any runtime exceptions and
     -- converting them into a @HandlerContents@
-    contents' <- unsafeAsyncCatch
+    contents' <- rheCatchHandlerExceptions rhe
         (do
             res <- unHandlerFor handler (hd istate)
             tc <- evaluate (toTypedContent res)
@@ -212,10 +192,11 @@ handleContents handleError' finalSession headers contents =
 --
 -- Note that this also catches async exceptions.
 evalFallback :: (Monoid w, NFData w)
-             => HandlerContents
+             => (forall a. IO a -> (SomeException -> IO a) -> IO a)
+             -> HandlerContents
              -> w
              -> IO (w, HandlerContents)
-evalFallback contents val = unsafeAsyncCatchAny
+evalFallback catcher contents val = catcher
     (fmap (, contents) (evaluate $!! val))
     (fmap ((mempty, ) . HCError) . toErrorHandler)
 
@@ -231,8 +212,8 @@ runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState -
 
     -- Evaluate the unfortunately-lazy session and headers,
     -- propagating exceptions into the contents
-    (finalSession, contents1) <- evalFallback contents0 (ghsSession state)
-    (headers, contents2) <- evalFallback contents1 (appEndo (ghsHeaders state) [])
+    (finalSession, contents1) <- evalFallback rheCatchHandlerExceptions contents0 (ghsSession state)
+    (headers, contents2) <- evalFallback rheCatchHandlerExceptions contents1 (appEndo (ghsHeaders state) [])
     contents3 <- (evaluate contents2) `catchAny` (fmap HCError . toErrorHandler)
 
     -- Convert the HandlerContents into the final YesodResponse
@@ -275,7 +256,7 @@ safeEh log' er req = do
 -- @HandlerFor@ is completely ignored, including changes to the
 -- session, cookies or headers.  We only return you the
 -- @HandlerFor@'s return value.
-runFakeHandler :: (Yesod site, MonadIO m) =>
+runFakeHandler :: forall site m a . (Yesod site, MonadIO m) =>
                   SessionMap
                -> (site -> Logger)
                -> site
@@ -296,6 +277,7 @@ runFakeHandler fakeSessionMap logger site handler = liftIO $ do
             , rheLog = messageLoggerSource site $ logger site
             , rheOnError = errHandler
             , rheMaxExpires = maxExpires
+            , rheCatchHandlerExceptions = catchHandlerExceptions site
             }
         handler'
       errHandler err req = do
@@ -337,7 +319,7 @@ runFakeHandler fakeSessionMap logger site handler = liftIO $ do
   _ <- runResourceT $ yapp fakeRequest
   I.readIORef ret
 
-yesodRunner :: (ToTypedContent res, Yesod site)
+yesodRunner :: forall res site . (ToTypedContent res, Yesod site)
             => HandlerFor site res
             -> YesodRunnerEnv site
             -> Maybe (Route site)
@@ -372,6 +354,7 @@ yesodRunner handler' YesodRunnerEnv {..} route req sendResponse = do
               , rheLog = log'
               , rheOnError = safeEh log'
               , rheMaxExpires = maxExpires
+              , rheCatchHandlerExceptions = catchHandlerExceptions yreSite
               }
           rhe = rheSafe
               { rheOnError = runHandler rheSafe . errorHandler

yesod-core/src/Yesod/Core/Types.hs

@@ -8,6 +8,7 @@
 {-# LANGUAGE TypeFamilies               #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE RankNTypes #-}
 module Yesod.Core.Types where
 
 import Data.Aeson (ToJSON)
@@ -55,7 +56,7 @@ import           Control.Monad.Reader               (MonadReader (..))
 import Control.DeepSeq (NFData (rnf))
 import Yesod.Core.TypeCache (TypeMap, KeyedTypeMap)
 import Control.Monad.Logger (MonadLoggerIO (..))
-import UnliftIO (MonadUnliftIO (..))
+import UnliftIO (MonadUnliftIO (..), SomeException)
 
 -- Sessions
 type SessionMap = Map Text ByteString
@@ -182,6 +183,11 @@ data RunHandlerEnv child site = RunHandlerEnv
       --
       -- Since 1.2.0
     , rheMaxExpires :: !Text
+
+      -- | @since 1.6.24.0
+      --   catch function for rendering 500 pages on exceptions.
+      --   by default this is catch from unliftio (rethrows all async exceptions).
+    , rheCatchHandlerExceptions :: !(forall a m . MonadUnliftIO m =>  m a -> (SomeException -> m a) -> m a)
     }
 
 data HandlerData child site = HandlerData

yesod-core/test/YesodCoreTest/ErrorHandling.hs

@@ -1,12 +1,15 @@
 {-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE LambdaCase #-}
+
 module YesodCoreTest.ErrorHandling
     ( errorHandlingTest
     , Widget
     , resourcesApp
     ) where
 
+import  Data.Typeable(cast)
 import qualified System.Mem as Mem
 import qualified Control.Concurrent.Async as Async
 import Control.Concurrent as Conc
@@ -16,16 +19,19 @@ import Network.Wai
 import Network.Wai.Test
 import qualified Data.ByteString.Lazy as L
 import qualified Data.ByteString.Char8 as S8
-import Control.Exception (SomeException, try)
+import Control.Exception (SomeException, try, AsyncException(..))
 import           UnliftIO.Exception(finally)
 import Network.HTTP.Types (Status, mkStatus)
 import Data.ByteString.Builder (Builder, toLazyByteString)
 import Data.Monoid (mconcat)
 import Data.Text (Text, pack)
 import Control.Monad (forM_)
+import qualified Network.Wai.Handler.Warp as Warp
+import qualified YesodCoreTest.ErrorHandling.CustomApp as Custom
 import Control.Monad.Trans.State (StateT (..))
 import Control.Monad.Trans.Reader (ReaderT (..))
 import qualified UnliftIO.Exception as E
+import System.Timeout(timeout)
 
 data App = App
 
@@ -52,7 +58,8 @@ mkYesod "App" [parseRoutes|
 /only-plain-text OnlyPlainTextR GET
 
 /thread-killed ThreadKilledR GET
-/async-session AsyncSessionR GET
+/connection-closed-by-peer ConnectionClosedPeerR GET
+/sleep-sec SleepASecR GET
 |]
 
 overrideStatus :: Status
@@ -125,15 +132,16 @@ getThreadKilledR = do
   x <- liftIO Conc.myThreadId
   liftIO $ Async.withAsync (Conc.killThread x) Async.wait
   pure "unreachablle"
+getSleepASecR :: Handler Html
+getSleepASecR = do
+  liftIO $ Conc.threadDelay 1000000
+  pure "slept a second"
 
-getAsyncSessionR :: Handler Html
-getAsyncSessionR = do
-  setSession "jap" $ foldMap (pack . show) [0..999999999999999999999999] -- it's going to take a while to figure this one out
+getConnectionClosedPeerR :: Handler Html
+getConnectionClosedPeerR = do
   x <- liftIO Conc.myThreadId
-  liftIO $ forkIO $ do
-     liftIO $ Conc.threadDelay 100000
-     Conc.killThread x
-  pure "reachable"
+  liftIO $ Async.withAsync (E.throwTo x Warp.ConnectionClosedByPeer) Async.wait
+  pure "unreachablle"
 
 getErrorR :: Int -> Handler ()
 getErrorR 1 = setSession undefined "foo"
@@ -178,8 +186,10 @@ errorHandlingTest = describe "Test.ErrorHandling" $ do
       it "accept CSS, permission denied -> 403" caseCssPermissionDenied
       it "accept image, non-existent path -> 404" caseImageNotFound
       it "accept video, bad method -> 405" caseVideoBadMethod
-      it "thread killed = 500" caseThreadKilled500
-      it "async session exception = 500" asyncSessionKilled500
+      it "default config exception rethrows connection closed" caseDefaultConnectionCloseRethrows
+      it "custom config rethrows an exception" caseCustomExceptionRethrows
+      it "thread killed rethrow" caseThreadKilledRethrow
+      it "can timeout a runner" canTimeoutARunner
 
 runner :: Session a -> IO a
 runner f = toWaiApp App >>= runSession f
@@ -318,14 +328,49 @@ caseVideoBadMethod = runner $ do
             }
     assertStatus 405 res
 
-caseThreadKilled500 :: IO ()
-caseThreadKilled500 = runner $ do
-  res <- request defaultRequest { pathInfo = ["thread-killed"] }
-  assertStatus 500 res
-  assertBodyContains "Internal Server Error" res
+fromExceptionUnwrap :: E.Exception e => SomeException -> Maybe e
+fromExceptionUnwrap se
+  | Just (E.AsyncExceptionWrapper e) <- E.fromException se = cast e
+  | Just (E.SyncExceptionWrapper e) <- E.fromException se = cast e
+  | otherwise = E.fromException se
 
-asyncSessionKilled500 :: IO ()
-asyncSessionKilled500 = runner $ do
-  res <- request defaultRequest { pathInfo = ["async-session"] }
-  assertStatus 500 res
-  assertBodyContains "Internal Server Error" res
+
+caseThreadKilledRethrow :: IO ()
+caseThreadKilledRethrow =
+  shouldThrow testcode $ \e -> case fromExceptionUnwrap e of
+                                (Just ThreadKilled) -> True
+                                _ -> False
+  where
+  testcode = runner $ do
+                res <- request defaultRequest { pathInfo = ["thread-killed"] }
+                assertStatus 500 res
+                assertBodyContains "Internal Server Error" res
+
+caseDefaultConnectionCloseRethrows :: IO ()
+caseDefaultConnectionCloseRethrows =
+  shouldThrow testcode $ \e -> case fromExceptionUnwrap e of
+                                  Just Warp.ConnectionClosedByPeer -> True
+                                  _ -> False
+
+  where
+  testcode = runner $ do
+      _res <- request defaultRequest { pathInfo = ["connection-closed-by-peer"] }
+      pure ()
+
+caseCustomExceptionRethrows :: IO ()
+caseCustomExceptionRethrows =
+  shouldThrow testcode $ \case Custom.MkMyException -> True
+  where
+    testcode = customAppRunner $ do
+      _res <- request defaultRequest { pathInfo = ["throw-custom-exception"] }
+      pure ()
+    customAppRunner f = toWaiApp Custom.CustomApp >>= runSession f
+
+
+canTimeoutARunner :: IO ()
+canTimeoutARunner = do
+  res <- timeout 1000 $ runner $ do
+    res <- request defaultRequest { pathInfo = ["sleep-sec"] }
+    assertStatus 200 res -- if 500, it's catching the timeout exception
+    pure () -- it should've timeout by now, either being 500 or Nothing
+  res `shouldBe` Nothing -- make sure that pure statement didn't happen.

yesod-core/test/YesodCoreTest/ErrorHandling/CustomApp.hs

@@ -0,0 +1,41 @@
+{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE DeriveAnyClass #-}
+
+-- | a custom app that throws an exception
+module YesodCoreTest.ErrorHandling.CustomApp
+    (CustomApp(..)
+    , MyException(..)
+
+    -- * unused
+    , Widget
+    , resourcesCustomApp
+    ) where
+
+
+import Yesod.Core.Types
+import Yesod.Core
+import qualified UnliftIO.Exception as E
+
+data CustomApp = CustomApp
+
+mkYesod "CustomApp" [parseRoutes|
+/throw-custom-exception CustomHomeR GET
+|]
+
+getCustomHomeR :: Handler Html
+getCustomHomeR =
+  E.throwIO MkMyException
+
+data MyException = MkMyException
+ deriving (Show, E.Exception)
+
+instance Yesod CustomApp where
+  -- something we couldn't do before, rethrow custom exceptions
+  catchHandlerExceptions _ action handler =
+    action `E.catch` \exception -> do
+      case E.fromException exception of
+        Just MkMyException -> E.throwIO MkMyException
+        Nothing -> handler exception

yesod-core/yesod-core.cabal

@@ -1,5 +1,5 @@
 name:            yesod-core
-version:         1.6.23.1
+version:         1.6.24.0
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -146,6 +146,7 @@ test-suite tests
                    YesodCoreTest.Header
                    YesodCoreTest.Csrf
                    YesodCoreTest.ErrorHandling
+                   YesodCoreTest.ErrorHandling.CustomApp
                    YesodCoreTest.Exceptions
                    YesodCoreTest.InternalRequest
                    YesodCoreTest.JsLoader