From a3d9a13abea346eb36712d0c1141aee411a4bb3e Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 22 Jun 2016 18:24:18 +0300 Subject: [PATCH] Proper handling of impure exceptions within HandlerError values --- yesod-core/ChangeLog.md | 4 + yesod-core/Yesod/Core/Internal/Run.hs | 89 +++++++++++++-------- yesod-core/Yesod/Core/Types.hs | 5 +- yesod-core/test/YesodCoreTest/Exceptions.hs | 19 ++++- yesod-core/yesod-core.cabal | 6 +- 5 files changed, 86 insertions(+), 37 deletions(-) diff --git a/yesod-core/ChangeLog.md b/yesod-core/ChangeLog.md index 74109fb1..9e6d4f05 100644 --- a/yesod-core/ChangeLog.md +++ b/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) diff --git a/yesod-core/Yesod/Core/Internal/Run.hs b/yesod-core/Yesod/Core/Internal/Run.hs index e80d3d62..bdc2f2eb 100644 --- a/yesod-core/Yesod/Core/Internal/Run.hs +++ b/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) - (\e -> return $ Left $ maybe (HCError $ toErrorHandler e) id - $ fromException e) + contents' <- catchSync (fmap Right $ unHandlerT handler hd) + (\e -> do + 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 - (Map.empty, Just $! HCError $! InternalError $! T.pack $! show (e :: E.SomeException)) + return (finalSession, Nothing)) `catchSync` \e -> return + (Map.empty, Just $! HCError $! InternalError $! T.pack $! show e) (headers, mcontents2) <- (do headers <- return $!! appEndo (ghsHeaders state) [] - return (headers, Nothing)) `E.catch` \e -> return - ([], Just $! HCError $! InternalError $! T.pack $! show (e :: E.SomeException)) + return (headers, Nothing)) `catchSync` \e -> return + ([], 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 - yar <- rheOnError e yreq - { reqSession = finalSession - } - case yar of - YRPlain status' hs ct c sess -> - let hs' = headers ++ hs - status - | status' == defaultStatus = getStatus e - | otherwise = status' - in return $ YRPlain status hs' ct c sess - YRWai _ -> return yar - YRWaiApp _ -> return yar + let handleError e0 = do + e <- (evaluate $!! e0) `catchSync` \e -> return $! InternalError $! T.pack $! show e + flip runInternalState resState $ do + yar <- rheOnError e yreq + { reqSession = finalSession + } + case yar of + YRPlain status' hs ct c sess -> + let hs' = headers ++ hs + status + | status' == defaultStatus = getStatus e + | otherwise = status' + 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 diff --git a/yesod-core/Yesod/Core/Types.hs b/yesod-core/Yesod/Core/Types.hs index d8a2b2e0..5ab13339 100644 --- a/yesod-core/Yesod/Core/Types.hs +++ b/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'. diff --git a/yesod-core/test/YesodCoreTest/Exceptions.hs b/yesod-core/test/YesodCoreTest/Exceptions.hs index 8134dd9d..026510e2 100644 --- a/yesod-core/test/YesodCoreTest/Exceptions.hs +++ b/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 diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index 33c5fb9b..7f674576 100644 --- a/yesod-core/yesod-core.cabal +++ b/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 @@ -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