yesod-core 1.6.21.0 → 1.6.22.0

raw patch · 9 files changed

+151/−12 lines, 9 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• ChangeLog.md +7/−0
• src/Yesod/Core/Content.hs +5/−0
• src/Yesod/Core/Dispatch.hs +10/−0
• src/Yesod/Core/Internal/Run.hs +43/−4
• src/Yesod/Routes/TH/Dispatch.hs +12/−4
• src/Yesod/Routes/TH/RenderRoute.hs +9/−2
• src/Yesod/Routes/TH/RouteAttrs.hs +6/−1
• test/YesodCoreTest/ErrorHandling.hs +58/−0
• yesod-core.cabal +1/−1

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

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

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

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

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

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

@@ -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 {..} =

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

@@ -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 <michael@snoyman.com>