diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,12 @@ # ChangeLog for yesod-core +## 1.6.22.0 + +* Add missing list to documentation for ``Yesod.Core.Dispatch.warp``. [#1745](https://github.com/yesodweb/yesod/pull/1745) +* Add instances for `ToContent Void`, `ToTypedContent Void`. [#1752](https://github.com/yesodweb/yesod/pull/1752) +* Handle async exceptions within yesod rather then warp. [#1753](https://github.com/yesodweb/yesod/pull/1753) +* Support template-haskell 2.18 [#1754](https://github.com/yesodweb/yesod/pull/1754) + ## 1.6.21.0 * Export `Yesod.Core.Dispatch.defaultGen` so that users may reuse it for their own `YesodRunnerEnv`s [#1734](https://github.com/yesodweb/yesod/pull/1734) diff --git a/src/Yesod/Core/Content.hs b/src/Yesod/Core/Content.hs --- a/src/Yesod/Core/Content.hs +++ b/src/Yesod/Core/Content.hs @@ -64,6 +64,7 @@ import qualified Data.Aeson as J import Data.Text.Lazy.Builder (toLazyText) +import Data.Void (Void, absurd) import Yesod.Core.Types import Text.Lucius (Css, renderCss) import Text.Julius (Javascript, unJavascript) @@ -103,6 +104,8 @@ toContent bs = ContentBuilder (renderHtmlBuilder bs) Nothing instance ToContent () where toContent () = toContent B.empty +instance ToContent Void where + toContent = absurd instance ToContent (ContentType, Content) where toContent = snd instance ToContent TypedContent where @@ -276,6 +279,8 @@ toTypedContent = id instance ToTypedContent () where toTypedContent () = TypedContent typePlain (toContent ()) +instance ToTypedContent Void where + toTypedContent = absurd instance ToTypedContent (ContentType, Content) where toTypedContent (ct, content) = TypedContent ct content instance ToTypedContent RepJson where diff --git a/src/Yesod/Core/Dispatch.hs b/src/Yesod/Core/Dispatch.hs --- a/src/Yesod/Core/Dispatch.hs +++ b/src/Yesod/Core/Dispatch.hs @@ -187,6 +187,16 @@ -- middlewares. This set may change at any point without a breaking version -- number. Currently, it includes: -- +-- * Logging +-- +-- * GZIP compression +-- +-- * Automatic HEAD method handling +-- +-- * Request method override with the _method query string parameter +-- +-- * Accept header override with the _accept query string parameter +-- -- If you need more fine-grained control of middlewares, please use 'toWaiApp' -- directly. -- diff --git a/src/Yesod/Core/Internal/Run.hs b/src/Yesod/Core/Internal/Run.hs --- a/src/Yesod/Core/Internal/Run.hs +++ b/src/Yesod/Core/Internal/Run.hs @@ -5,9 +5,23 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE FlexibleContexts #-} -module Yesod.Core.Internal.Run where - +module Yesod.Core.Internal.Run + ( toErrorHandler + , errFromShow + , basicRunHandler + , handleError + , handleContents + , evalFallback + , runHandler + , safeEh + , runFakeHandler + , yesodRunner + , yesodRender + , resolveApproot + ) + where +import qualified Control.Exception as EUnsafe import Yesod.Core.Internal.Response import Data.ByteString.Builder (toLazyByteString) import qualified Data.ByteString.Lazy as BL @@ -39,7 +53,30 @@ 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 + -- | Convert a synchronous exception into an ErrorResponse toErrorHandler :: SomeException -> IO ErrorResponse toErrorHandler e0 = handleAny errFromShow $ @@ -71,7 +108,7 @@ -- Run the handler itself, capturing any runtime exceptions and -- converting them into a @HandlerContents@ - contents' <- catchAny + contents' <- unsafeAsyncCatch (do res <- unHandlerFor handler (hd istate) tc <- evaluate (toTypedContent res) @@ -172,11 +209,13 @@ -- | 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. +-- +-- Note that this also catches async exceptions. evalFallback :: (Monoid w, NFData w) => HandlerContents -> w -> IO (w, HandlerContents) -evalFallback contents val = catchAny +evalFallback contents val = unsafeAsyncCatchAny (fmap (, contents) (evaluate $!! val)) (fmap ((mempty, ) . HCError) . toErrorHandler) diff --git a/src/Yesod/Routes/TH/Dispatch.hs b/src/Yesod/Routes/TH/Dispatch.hs --- a/src/Yesod/Routes/TH/Dispatch.hs +++ b/src/Yesod/Routes/TH/Dispatch.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards, TemplateHaskell, ViewPatterns #-} module Yesod.Routes.TH.Dispatch ( MkDispatchSettings (..) @@ -73,7 +74,7 @@ handlePiece (Static str) = return (LitP $ StringL str, Nothing) handlePiece (Dynamic _) = do x <- newName "dyn" - let pat = ViewP (VarE 'fromPathPiece) (ConP 'Just [VarP x]) + let pat = ViewP (VarE 'fromPathPiece) (conPCompat 'Just [VarP x]) return (pat, Just $ VarE x) handlePieces :: [Piece a] -> Q ([Pat], [Exp]) @@ -86,7 +87,7 @@ mkPathPat final = foldr addPat final where - addPat x y = ConP '(:) [x, y] + addPat x y = conPCompat '(:) [x, y] go :: SDC -> ResourceTree a -> Q Clause go sdc (ResourceParent name _check pieces children) = do @@ -124,11 +125,11 @@ Methods multi methods -> do (finalPat, mfinalE) <- case multi of - Nothing -> return (ConP '[] [], Nothing) + Nothing -> return (conPCompat '[] [], Nothing) Just _ -> do multiName <- newName "multi" let pat = ViewP (VarE 'fromPathMultiPiece) - (ConP 'Just [VarP multiName]) + (conPCompat 'Just [VarP multiName]) return (pat, Just $ VarE multiName) let dynsMulti = @@ -200,3 +201,10 @@ defaultGetHandler :: Maybe String -> String -> Q Exp defaultGetHandler Nothing s = return $ VarE $ mkName $ "handle" ++ s defaultGetHandler (Just method) s = return $ VarE $ mkName $ map toLower method ++ s + +conPCompat :: Name -> [Pat] -> Pat +conPCompat n pats = ConP n +#if MIN_VERSION_template_haskell(2,18,0) + [] +#endif + pats diff --git a/src/Yesod/Routes/TH/RenderRoute.hs b/src/Yesod/Routes/TH/RenderRoute.hs --- a/src/Yesod/Routes/TH/RenderRoute.hs +++ b/src/Yesod/Routes/TH/RenderRoute.hs @@ -67,7 +67,7 @@ let cnt = length $ filter isDynamic pieces dyns <- replicateM cnt $ newName "dyn" child <- newName "child" - let pat = ConP (mkName name) $ map VarP $ dyns ++ [child] + let pat = conPCompat (mkName name) $ map VarP $ dyns ++ [child] pack' <- [|pack|] tsp <- [|toPathPiece|] @@ -100,7 +100,7 @@ case resourceDispatch res of Subsite{} -> return <$> newName "sub" _ -> return [] - let pat = ConP (mkName $ resourceName res) $ map VarP $ dyns ++ sub + let pat = conPCompat (mkName $ resourceName res) $ map VarP $ dyns ++ sub pack' <- [|pack|] tsp <- [|toPathPiece|] @@ -182,3 +182,10 @@ instanceD :: Cxt -> Type -> [Dec] -> Dec instanceD = InstanceD Nothing + +conPCompat :: Name -> [Pat] -> Pat +conPCompat n pats = ConP n +#if MIN_VERSION_template_haskell(2,18,0) + [] +#endif + pats diff --git a/src/Yesod/Routes/TH/RouteAttrs.hs b/src/Yesod/Routes/TH/RouteAttrs.hs --- a/src/Yesod/Routes/TH/RouteAttrs.hs +++ b/src/Yesod/Routes/TH/RouteAttrs.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE RecordWildCards #-} module Yesod.Routes.TH.RouteAttrs @@ -26,7 +27,11 @@ toIgnore = length $ filter isDynamic pieces isDynamic Dynamic{} = True isDynamic Static{} = False - front' = front . ConP (mkName name) . ignored + front' = front . ConP (mkName name) +#if MIN_VERSION_template_haskell(2,18,0) + [] +#endif + . ignored goRes :: (Pat -> Pat) -> Resource a -> Q Clause goRes front Resource {..} = diff --git a/test/YesodCoreTest/ErrorHandling.hs b/test/YesodCoreTest/ErrorHandling.hs --- a/test/YesodCoreTest/ErrorHandling.hs +++ b/test/YesodCoreTest/ErrorHandling.hs @@ -1,11 +1,16 @@ {-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE ViewPatterns #-} module YesodCoreTest.ErrorHandling ( errorHandlingTest , Widget , resourcesApp ) where + +import qualified System.Mem as Mem +import qualified Control.Concurrent.Async as Async +import Control.Concurrent as Conc import Yesod.Core import Test.Hspec import Network.Wai @@ -13,6 +18,7 @@ import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Char8 as S8 import Control.Exception (SomeException, try) +import UnliftIO.Exception(finally) import Network.HTTP.Types (Status, mkStatus) import Data.ByteString.Builder (Builder, toLazyByteString) import Data.Monoid (mconcat) @@ -45,6 +51,10 @@ /auth-not-adequate AuthNotAdequateR GET /args-not-valid ArgsNotValidR POST /only-plain-text OnlyPlainTextR GET + +/allocation-limit AlocationLimitR GET +/thread-killed ThreadKilledR GET +/async-session AsyncSessionR GET |] overrideStatus :: Status @@ -111,6 +121,33 @@ getGoodBuilderR :: Handler TypedContent getGoodBuilderR = return $ TypedContent "text/plain" $ toContent goodBuilderContent +getAlocationLimitR :: Handler Html +getAlocationLimitR = + (do + liftIO $ do + Mem.setAllocationCounter 1 -- very low limit + Mem.enableAllocationLimit + defaultLayout $ [whamlet| +

this will trigger https://hackage.haskell.org/package/base-4.16.0.0/docs/Control-Exception.html#t:AllocationLimitExceeded + which we need to catch + |]) `finally` liftIO Mem.disableAllocationLimit + +-- this handler kills it's own thread +getThreadKilledR :: Handler Html +getThreadKilledR = do + x <- liftIO Conc.myThreadId + liftIO $ Async.withAsync (Conc.killThread x) Async.wait + pure "unreachablle" + +getAsyncSessionR :: Handler Html +getAsyncSessionR = do + setSession "jap" $ foldMap (pack . show) [0..999999999999999999999999] -- it's going to take a while to figure this one out + x <- liftIO Conc.myThreadId + liftIO $ forkIO $ do + liftIO $ Conc.threadDelay 100_000 + Conc.killThread x + pure "reachable" + getErrorR :: Int -> Handler () getErrorR 1 = setSession undefined "foo" getErrorR 2 = setSession "foo" undefined @@ -154,6 +191,9 @@ 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 "allocation limit = 500" caseAllocationLimit500 + it "async session exception = 500" asyncSessionKilled500 runner :: Session a -> IO a runner f = toWaiApp App >>= runSession f @@ -291,3 +331,21 @@ ("accept", "video/webm") : requestHeaders defaultRequest } assertStatus 405 res + +caseAllocationLimit500 :: IO () +caseAllocationLimit500 = runner $ do + res <- request defaultRequest { pathInfo = ["allocation-limit"] } + assertStatus 500 res + assertBodyContains "Internal Server Error" res + +caseThreadKilled500 :: IO () +caseThreadKilled500 = runner $ do + res <- request defaultRequest { pathInfo = ["thread-killed"] } + assertStatus 500 res + assertBodyContains "Internal Server Error" res + +asyncSessionKilled500 :: IO () +asyncSessionKilled500 = runner $ do + res <- request defaultRequest { pathInfo = ["async-session"] } + assertStatus 500 res + assertBodyContains "Internal Server Error" res diff --git a/yesod-core.cabal b/yesod-core.cabal --- a/yesod-core.cabal +++ b/yesod-core.cabal @@ -1,5 +1,5 @@ name: yesod-core -version: 1.6.21.0 +version: 1.6.22.0 license: MIT license-file: LICENSE author: Michael Snoyman