Proper handling of impure exceptions within HandlerError values

yesod-core/ChangeLog.md

@@ -1,3 +1,7 @@
+## 1.4.22
+
+* Proper handling of impure exceptions within `HandlerError` values
+
 ## 1.4.21
 
 * Add support for `Encoding` from `aeson-0.11` [#1241](https://github.com/yesodweb/yesod/pull/1241)

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

@@ -15,8 +15,7 @@ import Yesod.Core.Internal.Response
 import           Blaze.ByteString.Builder     (toByteString)
 import           Control.Exception            (fromException, evaluate)
 import qualified Control.Exception            as E
-import           Control.Exception.Lifted     (catch)
+import           Control.Monad                (mplus, (<=<))
-import           Control.Monad                (mplus)
 import           Control.Monad.IO.Class       (MonadIO)
 import           Control.Monad.IO.Class       (liftIO)
 import           Control.Monad.Logger         (LogLevel (LevelError), LogSource,
@@ -38,9 +37,6 @@ import           Language.Haskell.TH.Syntax   (Loc, qLocation)
 import qualified Network.HTTP.Types           as H
 import           Network.Wai
 import           Network.Wai.Internal
-#if !MIN_VERSION_base(4, 6, 0)
-import           Prelude                      hiding (catch)
-#endif
 import           System.Log.FastLogger        (LogStr, toLogStr)
 import           Yesod.Core.Content
 import           Yesod.Core.Class.Yesod
@@ -62,6 +58,36 @@ newtype WrappedBS = WrappedBS { unWrappedBS :: S8.ByteString }
 instance NFData WrappedBS
 #endif
 
+-- | Catch all synchronous exceptions, ignoring asynchronous
+-- exceptions.
+--
+-- Ideally we'd use this from a different library
+catchSync :: IO a -> (E.SomeException -> IO a) -> IO a
+catchSync thing after = thing `E.catch` \e ->
+    if isAsyncException e
+        then E.throwIO e
+        else after e
+
+-- | Determine if an exception is asynchronous
+--
+-- Also worth being upstream
+isAsyncException :: E.SomeException -> Bool
+isAsyncException e =
+    case fromException e of
+        Just E.SomeAsyncException{} -> True
+        Nothing -> False
+
+-- | Convert an exception into an ErrorResponse
+toErrorHandler :: E.SomeException -> IO ErrorResponse
+toErrorHandler e0 = flip catchSync errFromShow $
+    case fromException e0 of
+        Just (HCError x) -> evaluate $!! x
+        _
+            | isAsyncException e0 -> E.throwIO e0
+            | otherwise -> errFromShow e0
+    where
+    errFromShow x = return $! InternalError $! T.pack $! show x
+
 -- | Function used internally by Yesod in the process of converting a
 -- 'HandlerT' into an 'Application'. Should not be needed by users.
 runHandler :: ToTypedContent c
@@ -69,10 +95,6 @@ runHandler :: ToTypedContent c
            -> HandlerT site IO c
            -> YesodApp
 runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState -> do
-    let toErrorHandler e =
-            case fromException e of
-                Just (HCError x) -> x
-                _ -> InternalError $ T.pack $ show e
     istate <- liftIO $ I.newIORef GHState
         { ghsSession = reqSession yreq
         , ghsRBC = Nothing
@@ -88,41 +110,44 @@ runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState -
             , handlerToParent = const ()
             , handlerResource = resState
             }
-    contents' <- catch (fmap Right $ unHandlerT handler hd)
+    contents' <- catchSync (fmap Right $ unHandlerT handler hd)
-        (\e -> return $ Left $ maybe (HCError $ toErrorHandler e) id
+        (\e -> do
-                      $ fromException e)
+            eh <- toErrorHandler e
+            return $ Left $ maybe (HCError eh) id $ fromException e)
     state <- liftIO $ I.readIORef istate
 
     (finalSession, mcontents1) <- (do
         finalSession <- returnDeepSessionMap (ghsSession state)
-        return (finalSession, Nothing)) `E.catch` \e -> return
+        return (finalSession, Nothing)) `catchSync` \e -> return
-            (Map.empty, Just $! HCError $! InternalError $! T.pack $! show (e :: E.SomeException))
+            (Map.empty, Just $! HCError $! InternalError $! T.pack $! show e)
 
     (headers, mcontents2) <- (do
         headers <- return $!! appEndo (ghsHeaders state) []
-        return (headers, Nothing)) `E.catch` \e -> return
+        return (headers, Nothing)) `catchSync` \e -> return
-            ([], Just $! HCError $! InternalError $! T.pack $! show (e :: E.SomeException))
+            ([], Just $! HCError $! InternalError $! T.pack $! show e)
 
     let contents =
             case mcontents1 `mplus` mcontents2 of
                 Just x -> x
                 Nothing -> either id (HCContent defaultStatus . toTypedContent) contents'
-    let handleError e = flip runInternalState resState $ do
+    let handleError e0 = do
-            yar <- rheOnError e yreq
+            e <- (evaluate $!! e0) `catchSync` \e -> return $! InternalError $! T.pack $! show e
-                { reqSession = finalSession
+            flip runInternalState resState $ do
-                }
+                yar <- rheOnError e yreq
-            case yar of
+                    { reqSession = finalSession
-                YRPlain status' hs ct c sess ->
+                    }
-                    let hs' = headers ++ hs
+                case yar of
-                        status
+                    YRPlain status' hs ct c sess ->
-                            | status' == defaultStatus = getStatus e
+                        let hs' = headers ++ hs
-                            | otherwise = status'
+                            status
-                     in return $ YRPlain status hs' ct c sess
+                                | status' == defaultStatus = getStatus e
-                YRWai _ -> return yar
+                                | otherwise = status'
-                YRWaiApp _ -> return yar
+                        in return $ YRPlain status hs' ct c sess
+                    YRWai _ -> return yar
+                    YRWaiApp _ -> return yar
     let sendFile' ct fp p =
             return $ YRPlain H.status200 headers ct (ContentFile fp p) finalSession
-    contents1 <- evaluate contents `E.catch` \e -> return
+    contents1 <- evaluate contents `catchSync` \e -> return
         (HCError $! InternalError $! T.pack $! show (e :: E.SomeException))
     case contents1 of
         HCContent status (TypedContent ct c) -> do
@@ -141,9 +166,9 @@ runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState -
             return $ YRPlain
                 status hs typePlain emptyContent
                 finalSession
-        HCSendFile ct fp p -> catch
+        HCSendFile ct fp p -> catchSync
             (sendFile' ct fp p)
-            (handleError . toErrorHandler)
+            (handleError <=< toErrorHandler)
         HCCreated loc -> do
             let hs = Header "Location" (encodeUtf8 loc) : headers
             return $ YRPlain

yesod-core/Yesod/Core/Types.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE DeriveDataTypeable         #-}
+{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE FlexibleInstances          #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
@@ -41,6 +42,7 @@ import qualified Data.Text                          as T
 import qualified Data.Text.Lazy.Builder             as TBuilder
 import           Data.Time                          (UTCTime)
 import           Data.Typeable                      (Typeable)
+import           GHC.Generics                       (Generic)
 import           Language.Haskell.TH.Syntax         (Loc)
 import qualified Network.HTTP.Types                 as H
 import           Network.Wai                        (FilePart,
@@ -314,7 +316,8 @@ data ErrorResponse =
     | NotAuthenticated
     | PermissionDenied Text
     | BadMethod H.Method
-    deriving (Show, Eq, Typeable)
+    deriving (Show, Eq, Typeable, Generic)
+instance NFData ErrorResponse
 
 ----- header stuff
 -- | Headers to be added to a 'Result'.

yesod-core/test/YesodCoreTest/Exceptions.hs

@@ -6,6 +6,8 @@ module YesodCoreTest.Exceptions (exceptionsTest, Widget) where
 import Test.Hspec
 
 import Yesod.Core
+import Yesod.Core.Types (HandlerContents (HCError))
+import Control.Exception (throwIO)
 import Network.Wai
 import Network.Wai.Test
 import Network.HTTP.Types (status301)
@@ -14,11 +16,15 @@ data Y = Y
 mkYesod "Y" [parseRoutes|
 / RootR GET
 /redirect RedirR GET
+/impure ImpureR GET
 |]
 
 instance Yesod Y where
     approot = ApprootStatic "http://test"
-    errorHandler (InternalError e) = return $ toTypedContent e
+    errorHandler (InternalError e) = do
+        _ <- return $! e
+        addHeader "ERROR" "HANDLER"
+        return $ toTypedContent e
     errorHandler x = defaultErrorHandler x
 
 getRootR :: Handler ()
@@ -29,10 +35,14 @@ getRedirR = do
     addHeader "foo" "bar"
     redirectWith status301 RootR
 
+getImpureR :: Handler ()
+getImpureR = liftIO $ throwIO $ HCError $ InternalError $ error "impure!"
+
 exceptionsTest :: Spec
 exceptionsTest = describe "Test.Exceptions" $ do
       it "500" case500
       it "redirect keeps headers" caseRedirect
+      it "deals with impure InternalError values" caseImpure
 
 runner :: Session () -> IO ()
 runner f = toWaiApp Y >>= runSession f
@@ -48,3 +58,10 @@ caseRedirect = runner $ do
     res <- request defaultRequest { pathInfo = ["redirect"] }
     assertStatus 301 res
     assertHeader "foo" "bar" res
+
+caseImpure :: IO ()
+caseImpure = runner $ do
+    res <- request defaultRequest { pathInfo = ["impure"] }
+    assertStatus 500 res
+    assertBodyContains "impure!" res
+    assertHeader "ERROR" "HANDLER" res

yesod-core/yesod-core.cabal

@@ -1,5 +1,5 @@
 name:            yesod-core
-version:         1.4.21
+version:         1.4.22
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -22,7 +22,7 @@ extra-source-files:
   README.md
 
 library
-    build-depends:   base                  >= 4.3      && < 5
+    build-depends:   base                  >= 4.6      && < 5
                    , time                  >= 1.1.4
                    , wai                   >= 3.0
                    , wai-extra             >= 3.0.7
@@ -63,7 +63,7 @@ library
                    , unix-compat
                    , conduit-extra
                    , exceptions            >= 0.6
-                   , deepseq
+                   , deepseq               >= 1.4
                    , mwc-random
                    , primitive
                    , word8