yesod-core 1.4.21 → 1.4.22
raw patch · 5 files changed
+197/−97 lines, 5 filesdep +deepseq-genericsdep ~basedep ~deepseq
Dependencies added: deepseq-generics
Dependency ranges changed: base, deepseq
Files
- ChangeLog.md +4/−0
- Yesod/Core/Internal/Run.hs +165/−92
- Yesod/Core/Types.hs +6/−1
- test/YesodCoreTest/Exceptions.hs +18/−1
- yesod-core.cabal +4/−3
ChangeLog.md view
@@ -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/Internal/Run.hs view
@@ -4,43 +4,36 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-} {-# LANGUAGE FlexibleContexts #-} module Yesod.Core.Internal.Run where #if __GLASGOW_HASKELL__ < 710-import Data.Monoid (mempty)+import Data.Monoid (Monoid, mempty) #endif 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.IO.Class (MonadIO)-import Control.Monad.IO.Class (liftIO)+import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Logger (LogLevel (LevelError), LogSource, liftLoc)-import Control.Monad.Trans.Resource (runResourceT, withInternalState, runInternalState)+import Control.Monad.Trans.Resource (runResourceT, withInternalState, runInternalState, InternalState) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import qualified Data.IORef as I import qualified Data.Map as Map-import Data.Maybe (isJust)-import Data.Maybe (fromMaybe)+import Data.Maybe (isJust, fromMaybe) import Data.Monoid (appEndo) import Data.Text (Text) import qualified Data.Text as T-import Data.Text.Encoding (encodeUtf8)-import Data.Text.Encoding (decodeUtf8With)+import Data.Text.Encoding (encodeUtf8, decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode) 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@@ -49,31 +42,73 @@ tooLargeResponse) import Yesod.Core.Internal.Util (getCurrentMaxExpiresRFC1123) import Yesod.Routes.Class (Route, renderRoute)-import Control.DeepSeq (($!!))+import Control.DeepSeq (($!!), NFData) -returnDeepSessionMap :: Monad m => SessionMap -> m SessionMap-#if MIN_VERSION_bytestring(0, 10, 0)-returnDeepSessionMap sm = return $!! sm-#else-returnDeepSessionMap sm = fmap unWrappedBS `liftM` (return $!! fmap WrappedBS sm)+-- | 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 --- | Work around missing NFData instance for bytestring 0.9.-newtype WrappedBS = WrappedBS { unWrappedBS :: S8.ByteString }-instance NFData WrappedBS-#endif+-- | 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 --- | Function used internally by Yesod in the process of converting a--- 'HandlerT' into an 'Application'. Should not be needed by users.-runHandler :: ToTypedContent c- => RunHandlerEnv site- -> HandlerT site IO c- -> YesodApp-runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState -> do- let toErrorHandler e =+-- | 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++-- | Generate an @ErrorResponse@ based on the shown version of the exception+errFromShow :: E.SomeException -> IO ErrorResponse+errFromShow x = evaluate $!! InternalError $! T.pack $! show x++-- | Do a basic run of a handler, getting some contents and the final+-- @GHState@. The @GHState@ unfortunately may contain some impure+-- exceptions, but all other synchronous exceptions will be caught and+-- represented by the @HandlerContents@.+basicRunHandler :: ToTypedContent c+ => RunHandlerEnv site+ -> HandlerT site IO c+ -> YesodRequest+ -> InternalState+ -> IO (GHState, HandlerContents)+basicRunHandler rhe handler yreq resState = do+ -- Create a mutable ref to hold the state. We use mutable refs so+ -- that the updates will survive runtime exceptions.+ istate <- I.newIORef defState++ -- Run the handler itself, capturing any runtime exceptions and+ -- converting them into a @HandlerContents@+ contents' <- catchSync+ (do+ res <- unHandlerT handler (hd istate)+ tc <- evaluate (toTypedContent res)+ -- Success! Wrap it up in an @HCContent@+ return (HCContent defaultStatus tc))+ (\e -> case fromException e of- Just (HCError x) -> x- _ -> InternalError $ T.pack $ show e- istate <- liftIO $ I.newIORef GHState+ Just e' -> return e'+ Nothing -> fmap HCError $ toErrorHandler e)++ -- Get the raw state and return+ state <- I.readIORef istate+ return (state, contents')+ where+ defState = GHState { ghsSession = reqSession yreq , ghsRBC = Nothing , ghsIdent = 1@@ -81,56 +116,57 @@ , ghsCacheBy = mempty , ghsHeaders = mempty }- let hd = HandlerData- { handlerRequest = yreq- , handlerEnv = rhe- , handlerState = istate- , handlerToParent = const ()- , handlerResource = resState- }- contents' <- catch (fmap Right $ unHandlerT handler hd)- (\e -> return $ Left $ maybe (HCError $ toErrorHandler e) id- $ fromException e)- state <- liftIO $ I.readIORef istate+ hd istate = HandlerData+ { handlerRequest = yreq+ , handlerEnv = rhe+ , handlerState = istate+ , handlerToParent = const ()+ , handlerResource = resState+ } - (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))+-- | Convert an @ErrorResponse@ into a @YesodResponse@+handleError :: RunHandlerEnv site+ -> YesodRequest+ -> InternalState+ -> Map.Map Text S8.ByteString+ -> [Header]+ -> ErrorResponse+ -> IO YesodResponse+handleError rhe yreq resState finalSession headers e0 = do+ -- Find any evil hidden impure exceptions+ e <- (evaluate $!! e0) `catchSync` errFromShow - (headers, mcontents2) <- (do- headers <- return $!! appEndo (ghsHeaders state) []- return (headers, Nothing)) `E.catch` \e -> return- ([], Just $! HCError $! InternalError $! T.pack $! show (e :: E.SomeException))+ -- Generate a response, leveraging the updated session and+ -- response headers+ flip runInternalState resState $ do+ yar <- rheOnError rhe 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 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 sendFile' ct fp p =- return $ YRPlain H.status200 headers ct (ContentFile fp p) finalSession- contents1 <- evaluate contents `E.catch` \e -> return- (HCError $! InternalError $! T.pack $! show (e :: E.SomeException))- case contents1 of+-- | Convert a @HandlerContents@ into a @YesodResponse@+handleContents :: (ErrorResponse -> IO YesodResponse)+ -> Map.Map Text S8.ByteString+ -> [Header]+ -> HandlerContents+ -> IO YesodResponse+handleContents handleError' finalSession headers contents =+ case contents of HCContent status (TypedContent ct c) -> do- ec' <- liftIO $ evaluateContent c+ -- Check for impure exceptions hiding in the contents+ ec' <- evaluateContent c case ec' of- Left e -> handleError e+ Left e -> handleError' e Right c' -> return $ YRPlain status headers ct c' finalSession- HCError e -> handleError e+ HCError e -> handleError' e HCRedirect status loc -> do let disable_caching x = Header "Cache-Control" "no-cache, must-revalidate"@@ -141,20 +177,54 @@ return $ YRPlain status hs typePlain emptyContent finalSession- HCSendFile ct fp p -> catch- (sendFile' ct fp p)- (handleError . toErrorHandler)- HCCreated loc -> do- let hs = Header "Location" (encodeUtf8 loc) : headers- return $ YRPlain- H.status201- hs- typePlain- emptyContent- finalSession+ HCSendFile ct fp p -> return $ YRPlain+ H.status200+ headers+ ct+ (ContentFile fp p)+ finalSession+ HCCreated loc -> return $ YRPlain+ H.status201+ (Header "Location" (encodeUtf8 loc) : headers)+ typePlain+ emptyContent+ finalSession HCWai r -> return $ YRWai r HCWaiApp a -> return $ YRWaiApp a +-- | Evaluate the given value. If an exception is thrown, use it to+-- replace the provided contents and then return @mempty@ in place of the+-- evaluated value.+evalFallback :: (Monoid w, NFData w)+ => HandlerContents+ -> w+ -> IO (w, HandlerContents)+evalFallback contents val = catchSync+ (fmap (, contents) (evaluate $!! val))+ (fmap ((mempty, ) . HCError) . toErrorHandler)++-- | Function used internally by Yesod in the process of converting a+-- 'HandlerT' into an 'Application'. Should not be needed by users.+runHandler :: ToTypedContent c+ => RunHandlerEnv site+ -> HandlerT site IO c+ -> YesodApp+runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState -> do+ -- Get the raw state and original contents+ (state, contents0) <- basicRunHandler rhe handler yreq 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) [])++ -- Convert the HandlerContents into the final YesodResponse+ handleContents+ (handleError rhe yreq resState finalSession headers)+ finalSession+ headers+ contents2+ safeEh :: (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> ErrorResponse -> YesodApp@@ -197,8 +267,7 @@ runFakeHandler fakeSessionMap logger site handler = liftIO $ do ret <- I.newIORef (Left $ InternalError "runFakeHandler: no result") maxExpires <- getCurrentMaxExpiresRFC1123- let handler' = do liftIO . I.writeIORef ret . Right =<< handler- return ()+ let handler' = liftIO . I.writeIORef ret . Right =<< handler let yapp = runHandler RunHandlerEnv { rheRender = yesodRender site $ resolveApproot site fakeWaiRequest@@ -233,6 +302,10 @@ , vault = mempty , requestBodyLength = KnownLength 0 , requestHeaderRange = Nothing+#if MIN_VERSION_wai(3,2,0)+ , requestHeaderReferer = Nothing+ , requestHeaderUserAgent = Nothing+#endif } fakeRequest = YesodRequest@@ -256,7 +329,7 @@ | Just maxLen <- mmaxLen, KnownLength len <- requestBodyLength req, maxLen < len = sendResponse tooLargeResponse | otherwise = do let dontSaveSession _ = return []- (session, saveSession) <- liftIO $ do+ (session, saveSession) <- liftIO $ maybe (return (Map.empty, dontSaveSession)) (\sb -> sbLoadSession sb req) yreSessionBackend maxExpires <- yreGetMaxExpires let mkYesodReq = parseWaiRequest req session (isJust yreSessionBackend) mmaxLen
Yesod/Core/Types.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}@@ -41,6 +42,7 @@ 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,@@ -62,6 +64,7 @@ import Prelude hiding (catch) #endif import Control.DeepSeq (NFData (rnf))+import Control.DeepSeq.Generics (genericRnf) import Data.Conduit.Lazy (MonadActive, monadActive) import Yesod.Core.TypeCache (TypeMap, KeyedTypeMap) #if MIN_VERSION_monad_logger(0, 3, 10)@@ -314,7 +317,9 @@ | NotAuthenticated | PermissionDenied Text | BadMethod H.Method- deriving (Show, Eq, Typeable)+ deriving (Show, Eq, Typeable, Generic)+instance NFData ErrorResponse where+ rnf = genericRnf ----- header stuff -- | Headers to be added to a 'Result'.
test/YesodCoreTest/Exceptions.hs view
@@ -6,6 +6,8 @@ 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 @@ 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 @@ 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 @@ 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.cabal view
@@ -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 @@ 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,8 @@ , unix-compat , conduit-extra , exceptions >= 0.6- , deepseq+ , deepseq >= 1.3+ , deepseq-generics , mwc-random , primitive , word8