yesod-core 1.6.23.1 → 1.6.24.0

raw patch · 7 files changed

+157/−63 lines, 7 filesdep ~vectorPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: vector

API changes (from Hackage documentation)

Files

• ChangeLog.md +4/−0
• src/Yesod/Core/Class/Yesod.hs +18/−4
• src/Yesod/Core/Internal/Run.hs +19/−36
• src/Yesod/Core/Types.hs +7/−1
• test/YesodCoreTest/ErrorHandling.hs +66/−21
• test/YesodCoreTest/ErrorHandling/CustomApp.hs +41/−0
• yesod-core.cabal +2/−1

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

@@ -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.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.@@ -69,6 +73,16 @@     -- Note: Prior to yesod-core 1.5, the default value was 'ApprootRelative'.     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.     --

@@ -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           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 @@      -- 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 @@ -- -- 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 @@      -- 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 @@ -- @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 @@             , rheLog = messageLoggerSource site $ logger site             , rheOnError = errHandler             , rheMaxExpires = maxExpires+            , rheCatchHandlerExceptions = catchHandlerExceptions site             }         handler'       errHandler err req = do@@ -337,7 +319,7 @@   _ <- 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 @@               , rheLog = log'               , rheOnError = safeEh log'               , rheMaxExpires = maxExpires+              , rheCatchHandlerExceptions = catchHandlerExceptions yreSite               }           rhe = rheSafe               { rheOnError = runHandler rheSafe . errorHandler

@@ -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.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 @@       --       -- 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

@@ -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.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 @@ /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 @@   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 @@       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 @@             }     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.

@@ -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

@@ -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 @@                    YesodCoreTest.Header                    YesodCoreTest.Csrf                    YesodCoreTest.ErrorHandling+                   YesodCoreTest.ErrorHandling.CustomApp                    YesodCoreTest.Exceptions                    YesodCoreTest.InternalRequest                    YesodCoreTest.JsLoader