Script 'mail_helper' called by obssrc Hello community, here is the log from the commit of package ghc-yesod-core for openSUSE:Factory checked in at 2022-08-10 17:13:31 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-yesod-core (Old) and /work/SRC/openSUSE:Factory/.ghc-yesod-core.new.1521 (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-yesod-core" Wed Aug 10 17:13:31 2022 rev:12 rq:994056 version:1.6.23.1 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-yesod-core/ghc-yesod-core.changes 2021-08-25 20:58:25.633143941 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-yesod-core.new.1521/ghc-yesod-core.changes 2022-08-10 17:14:45.813937198 +0200 @@ -1,0 +2,31 @@ +Mon Apr 25 16:22:36 UTC 2022 - Peter Simons <psim...@suse.com> + +- Update yesod-core to version 1.6.23.1. + ## 1.6.23.1 + + * Fix typo in creation of the description `<meta>` tag in `defaultLayout`. [#1766](https://github.com/yesodweb/yesod/pull/1766) + + ## 1.6.23 + + * Add idempotent versions of `setDescription`, `setDescriptionI`. These functions + have odd behaviour when called multiple times, so they are now warned against. + This can't be a silent change - if you want to switch to the new functions, make + sure your layouts are updated to use `pageDescription` as well as `pageTitle`. + [#1765](https://github.com/yesodweb/yesod/pull/1765) + + ## 1.6.22.1 + + + Remove sometimes failing superfluous test. [#1756](https://github.com/yesodweb/yesod/pull/1756) + +------------------------------------------------------------------- +Thu Mar 24 03:28:36 UTC 2022 - Peter Simons <psim...@suse.com> + +- Update yesod-core to version 1.6.22.0. + ## 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) + +------------------------------------------------------------------- Old: ---- yesod-core-1.6.21.0.tar.gz New: ---- yesod-core-1.6.23.1.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-yesod-core.spec ++++++ --- /var/tmp/diff_new_pack.NKxxJ4/_old 2022-08-10 17:14:46.441938837 +0200 +++ /var/tmp/diff_new_pack.NKxxJ4/_new 2022-08-10 17:14:46.445938847 +0200 @@ -1,7 +1,7 @@ # # spec file for package ghc-yesod-core # -# Copyright (c) 2021 SUSE LLC +# Copyright (c) 2022 SUSE LLC # # All modifications and additions to the file contributed by third parties # remain the property of their copyright owners, unless otherwise agreed @@ -19,7 +19,7 @@ %global pkg_name yesod-core %bcond_with tests Name: ghc-%{pkg_name} -Version: 1.6.21.0 +Version: 1.6.23.1 Release: 0 Summary: Creation of type-safe, RESTful web applications License: MIT ++++++ yesod-core-1.6.21.0.tar.gz -> yesod-core-1.6.23.1.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/yesod-core-1.6.21.0/ChangeLog.md new/yesod-core-1.6.23.1/ChangeLog.md --- old/yesod-core-1.6.21.0/ChangeLog.md 2021-07-22 15:38:47.000000000 +0200 +++ new/yesod-core-1.6.23.1/ChangeLog.md 2022-04-25 11:55:17.000000000 +0200 @@ -1,5 +1,28 @@ # ChangeLog for yesod-core +## 1.6.23.1 + +* Fix typo in creation of the description `<meta>` tag in `defaultLayout`. [#1766](https://github.com/yesodweb/yesod/pull/1766) + +## 1.6.23 + +* Add idempotent versions of `setDescription`, `setDescriptionI`. These functions + have odd behaviour when called multiple times, so they are now warned against. + This can't be a silent change - if you want to switch to the new functions, make + sure your layouts are updated to use `pageDescription` as well as `pageTitle`. + [#1765](https://github.com/yesodweb/yesod/pull/1765) + +## 1.6.22.1 + ++ Remove sometimes failing superfluous test. [#1756](https://github.com/yesodweb/yesod/pull/1756) + +## 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 -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/yesod-core-1.6.21.0/src/Yesod/Core/Class/Yesod.hs new/yesod-core-1.6.23.1/src/Yesod/Core/Class/Yesod.hs --- old/yesod-core-1.6.21.0/src/Yesod/Core/Class/Yesod.hs 2021-07-22 15:38:47.000000000 +0200 +++ new/yesod-core-1.6.23.1/src/Yesod/Core/Class/Yesod.hs 2022-04-25 11:55:17.000000000 +0200 @@ -87,6 +87,8 @@ <html> <head> <title>#{pageTitle p} + $maybe description <- pageDescription p + <meta name="description" content="#{description}"> ^{pageHead p} <body> $forall (status, msg) <- msgs @@ -539,8 +541,9 @@ { wdRef = ref , wdHandler = hd } - GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head') <- readIORef ref + GWData (Body body) (Last mTitle) (Last mDescription) scripts' stylesheets' style jscript (Head head') <- readIORef ref let title = maybe mempty unTitle mTitle + description = unDescription <$> mDescription scripts = runUniqueList scripts' stylesheets = runUniqueList stylesheets' @@ -610,7 +613,7 @@ ^{regularScriptLoad} |] - return $ PageContent title headAll $ + return $ PageContent title description headAll $ case jsLoader master of BottomOfBody -> bodyScript _ -> body diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/yesod-core-1.6.21.0/src/Yesod/Core/Content.hs new/yesod-core-1.6.23.1/src/Yesod/Core/Content.hs --- old/yesod-core-1.6.21.0/src/Yesod/Core/Content.hs 2021-07-22 15:38:47.000000000 +0200 +++ new/yesod-core-1.6.23.1/src/Yesod/Core/Content.hs 2022-03-24 04:23:40.000000000 +0100 @@ -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 -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/yesod-core-1.6.21.0/src/Yesod/Core/Dispatch.hs new/yesod-core-1.6.23.1/src/Yesod/Core/Dispatch.hs --- old/yesod-core-1.6.21.0/src/Yesod/Core/Dispatch.hs 2021-07-22 15:38:47.000000000 +0200 +++ new/yesod-core-1.6.23.1/src/Yesod/Core/Dispatch.hs 2022-01-21 13:07:15.000000000 +0100 @@ -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 -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/yesod-core-1.6.21.0/src/Yesod/Core/Internal/Run.hs new/yesod-core-1.6.23.1/src/Yesod/Core/Internal/Run.hs --- old/yesod-core-1.6.21.0/src/Yesod/Core/Internal/Run.hs 2021-07-22 15:38:47.000000000 +0200 +++ new/yesod-core-1.6.23.1/src/Yesod/Core/Internal/Run.hs 2022-03-24 04:23:58.000000000 +0100 @@ -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,6 +53,29 @@ 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 @@ -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 -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/yesod-core-1.6.21.0/src/Yesod/Core/Types.hs new/yesod-core-1.6.23.1/src/Yesod/Core/Types.hs --- old/yesod-core-1.6.21.0/src/Yesod/Core/Types.hs 2021-07-22 15:38:47.000000000 +0200 +++ new/yesod-core-1.6.23.1/src/Yesod/Core/Types.hs 2022-04-21 04:35:57.000000000 +0200 @@ -289,9 +289,10 @@ -- -- > PageContent url -> HtmlUrl url data PageContent url = PageContent - { pageTitle :: !Html - , pageHead :: !(HtmlUrl url) - , pageBody :: !(HtmlUrl url) + { pageTitle :: !Html + , pageDescription :: !(Maybe Text) + , pageHead :: !(HtmlUrl url) + , pageBody :: !(HtmlUrl url) } data Content = ContentBuilder !BB.Builder !(Maybe Int) -- ^ The content and optional content length. @@ -387,6 +388,7 @@ data Stylesheet url = Stylesheet { styleLocation :: !(Location url), styleAttributes :: ![(Text, Text)] } deriving (Show, Eq) newtype Title = Title { unTitle :: Html } +newtype Description = Description { unDescription :: Text } newtype Head url = Head (HtmlUrl url) deriving Monoid @@ -402,6 +404,7 @@ data GWData a = GWData { gwdBody :: !(Body a) , gwdTitle :: !(Last Title) + , gwdDescription :: !(Last Description) , gwdScripts :: !(UniqueList (Script a)) , gwdStylesheets :: !(UniqueList (Stylesheet a)) , gwdCss :: !(Map (Maybe Text) (CssBuilderUrl a)) -- media type @@ -409,20 +412,21 @@ , gwdHead :: !(Head a) } instance Monoid (GWData a) where - mempty = GWData mempty mempty mempty mempty mempty mempty mempty + mempty = GWData mempty mempty mempty mempty mempty mempty mempty mempty #if !(MIN_VERSION_base(4,11,0)) mappend = (<>) #endif instance Semigroup (GWData a) where - GWData a1 a2 a3 a4 a5 a6 a7 <> - GWData b1 b2 b3 b4 b5 b6 b7 = GWData + GWData a1 a2 a3 a4 a5 a6 a7 a8 <> + GWData b1 b2 b3 b4 b5 b6 b7 b8 = GWData (mappend a1 b1) (mappend a2 b2) (mappend a3 b3) (mappend a4 b4) - (unionWith mappend a5 b5) - (mappend a6 b6) + (mappend a5 b5) + (unionWith mappend a6 b6) (mappend a7 b7) + (mappend a8 b8) data HandlerContents = HCContent !H.Status !TypedContent diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/yesod-core-1.6.21.0/src/Yesod/Core/Widget.hs new/yesod-core-1.6.23.1/src/Yesod/Core/Widget.hs --- old/yesod-core-1.6.21.0/src/Yesod/Core/Widget.hs 2021-07-22 15:38:47.000000000 +0200 +++ new/yesod-core-1.6.23.1/src/Yesod/Core/Widget.hs 2022-04-21 04:35:57.000000000 +0200 @@ -33,6 +33,8 @@ , setTitleI , setDescription , setDescriptionI + , setDescriptionIdemp + , setDescriptionIdempI , setOGType , setOGImage -- ** CSS @@ -87,19 +89,19 @@ toWidget :: (MonadWidget m, HandlerSite m ~ site) => a -> m () instance render ~ RY site => ToWidget site (render -> Html) where - toWidget x = tell $ GWData (Body x) mempty mempty mempty mempty mempty mempty + toWidget x = tell $ GWData (Body x) mempty mempty mempty mempty mempty mempty mempty instance render ~ RY site => ToWidget site (render -> Css) where toWidget x = toWidget $ CssBuilder . fromLazyText . renderCss . x instance ToWidget site Css where toWidget x = toWidget $ CssBuilder . fromLazyText . renderCss . const x instance render ~ RY site => ToWidget site (render -> CssBuilder) where - toWidget x = tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . x) mempty mempty + toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . x) mempty mempty instance ToWidget site CssBuilder where - toWidget x = tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . const x) mempty mempty + toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . const x) mempty mempty instance render ~ RY site => ToWidget site (render -> Javascript) where - toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Just x) mempty + toWidget x = tell $ GWData mempty mempty mempty mempty mempty mempty (Just x) mempty instance ToWidget site Javascript where - toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Just $ const x) mempty + toWidget x = tell $ GWData mempty mempty mempty mempty mempty mempty (Just $ const x) mempty instance (site' ~ site, a ~ ()) => ToWidget site' (WidgetFor site a) where toWidget = liftWidget instance ToWidget site Html where @@ -130,9 +132,9 @@ instance ToWidgetMedia site Css where toWidgetMedia media x = toWidgetMedia media $ CssBuilder . fromLazyText . renderCss . const x instance render ~ RY site => ToWidgetMedia site (render -> CssBuilder) where - toWidgetMedia media x = tell $ GWData mempty mempty mempty mempty (Map.singleton (Just media) $ unCssBuilder . x) mempty mempty + toWidgetMedia media x = tell $ GWData mempty mempty mempty mempty mempty (Map.singleton (Just media) $ unCssBuilder . x) mempty mempty instance ToWidgetMedia site CssBuilder where - toWidgetMedia media x = tell $ GWData mempty mempty mempty mempty (Map.singleton (Just media) $ unCssBuilder . const x) mempty mempty + toWidgetMedia media x = tell $ GWData mempty mempty mempty mempty mempty (Map.singleton (Just media) $ unCssBuilder . const x) mempty mempty class ToWidgetBody site a where toWidgetBody :: (MonadWidget m, HandlerSite m ~ site) => a -> m () @@ -150,7 +152,7 @@ toWidgetHead :: (MonadWidget m, HandlerSite m ~ site) => a -> m () instance render ~ RY site => ToWidgetHead site (render -> Html) where - toWidgetHead = tell . GWData mempty mempty mempty mempty mempty mempty . Head + toWidgetHead = tell . GWData mempty mempty mempty mempty mempty mempty mempty . Head instance render ~ RY site => ToWidgetHead site (render -> Css) where toWidgetHead = toWidget instance ToWidgetHead site Css where @@ -181,7 +183,7 @@ -- * Google typically shows 55-64 characters, so aim to keep your title -- length under 60 characters setTitle :: MonadWidget m => Html -> m () -setTitle x = tell $ GWData mempty (Last $ Just $ Title x) mempty mempty mempty mempty mempty +setTitle x = tell $ GWData mempty (Last $ Just $ Title x) mempty mempty mempty mempty mempty mempty -- | Set the localised page title. -- @@ -208,6 +210,14 @@ setDescription description = toWidgetHead $ [hamlet|<meta name=description content=#{description}>|] +{-# WARNING setDescription + [ "setDescription is not idempotent; we recommend setDescriptionIdemp instead" + , "Multiple calls to setDescription will insert multiple meta tags in the page head." + , "If you want an idempotent function, use setDescriptionIdemp - but if you do, you \ + \may need to change your layout to include pageDescription." + ] +#-} + -- | Add translated description meta tag to the head of the page -- -- n.b. See comments for @setDescription@. @@ -220,6 +230,48 @@ mr <- getMessageRender toWidgetHead $ [hamlet|<meta name=description content=#{mr msg}>|] +{-# WARNING setDescriptionI + [ "setDescriptionI is not idempotent; we recommend setDescriptionIdempI instead" + , "Multiple calls to setDescriptionI will insert multiple meta tags in the page head." + , "If you want an idempotent function, use setDescriptionIdempI - but if you do, you \ + \may need to change your layout to include pageDescription." + ] +#-} + +-- | Add description meta tag to the head of the page +-- +-- Google does not use the description tag as a ranking signal, but the +-- contents of this tag will likely affect your click-through rate since it +-- shows up in search results. +-- +-- The average length of the description shown in Google's search results is +-- about 160 characters on desktop, and about 130 characters on mobile, at time +-- of writing. +-- +-- Unlike 'setDescription', this version is *idempotent* - calling it multiple +-- times will result in only a single description meta tag in the head. +-- +-- Source: https://www.advancedwebranking.com/blog/meta-tags-important-in-seo/ +-- +-- @since 1.6.23 +setDescriptionIdemp :: MonadWidget m => Text -> m () +setDescriptionIdemp description = tell $ GWData mempty mempty (Last $ Just $ Description description) mempty mempty mempty mempty mempty + +-- | Add translated description meta tag to the head of the page +-- +-- n.b. See comments for @setDescriptionIdemp@. +-- +-- Unlike 'setDescriptionI', this version is *idempotent* - calling it multiple +-- times will result in only a single description meta tag in the head. +-- +-- @since 1.6.23 +setDescriptionIdempI + :: (MonadWidget m, RenderMessage (HandlerSite m) msg) + => msg -> m () +setDescriptionIdempI msg = do + mr <- getMessageRender + setDescriptionIdemp $ mr msg + -- | Add OpenGraph type meta tag to the head of the page -- -- See all available OG types here: https://ogp.me/#types @@ -252,7 +304,7 @@ => Route (HandlerSite m) -> [(Text, Text)] -> m () -addStylesheetAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Local x) y) mempty mempty mempty +addStylesheetAttrs x y = tell $ GWData mempty mempty mempty mempty (toUnique $ Stylesheet (Local x) y) mempty mempty mempty -- | Link to the specified remote stylesheet. addStylesheetRemote :: MonadWidget m => Text -> m () @@ -260,7 +312,7 @@ -- | Link to the specified remote stylesheet. addStylesheetRemoteAttrs :: MonadWidget m => Text -> [(Text, Text)] -> m () -addStylesheetRemoteAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Remote x) y) mempty mempty mempty +addStylesheetRemoteAttrs x y = tell $ GWData mempty mempty mempty mempty (toUnique $ Stylesheet (Remote x) y) mempty mempty mempty addStylesheetEither :: MonadWidget m => Either (Route (HandlerSite m)) Text @@ -278,7 +330,7 @@ -- | Link to the specified local script. addScriptAttrs :: MonadWidget m => Route (HandlerSite m) -> [(Text, Text)] -> m () -addScriptAttrs x y = tell $ GWData mempty mempty (toUnique $ Script (Local x) y) mempty mempty mempty mempty +addScriptAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Script (Local x) y) mempty mempty mempty mempty -- | Link to the specified remote script. addScriptRemote :: MonadWidget m => Text -> m () @@ -286,7 +338,7 @@ -- | Link to the specified remote script. addScriptRemoteAttrs :: MonadWidget m => Text -> [(Text, Text)] -> m () -addScriptRemoteAttrs x y = tell $ GWData mempty mempty (toUnique $ Script (Remote x) y) mempty mempty mempty mempty +addScriptRemoteAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Script (Remote x) y) mempty mempty mempty mempty whamlet :: QuasiQuoter whamlet = NP.hamletWithSettings rules NP.defaultHamletSettings diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/yesod-core-1.6.21.0/src/Yesod/Routes/TH/Dispatch.hs new/yesod-core-1.6.23.1/src/Yesod/Routes/TH/Dispatch.hs --- old/yesod-core-1.6.21.0/src/Yesod/Routes/TH/Dispatch.hs 2021-07-22 15:38:47.000000000 +0200 +++ new/yesod-core-1.6.23.1/src/Yesod/Routes/TH/Dispatch.hs 2022-03-24 04:24:47.000000000 +0100 @@ -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 -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/yesod-core-1.6.21.0/src/Yesod/Routes/TH/RenderRoute.hs new/yesod-core-1.6.23.1/src/Yesod/Routes/TH/RenderRoute.hs --- old/yesod-core-1.6.21.0/src/Yesod/Routes/TH/RenderRoute.hs 2021-07-22 15:38:47.000000000 +0200 +++ new/yesod-core-1.6.23.1/src/Yesod/Routes/TH/RenderRoute.hs 2022-03-24 04:24:47.000000000 +0100 @@ -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 -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/yesod-core-1.6.21.0/src/Yesod/Routes/TH/RouteAttrs.hs new/yesod-core-1.6.23.1/src/Yesod/Routes/TH/RouteAttrs.hs --- old/yesod-core-1.6.21.0/src/Yesod/Routes/TH/RouteAttrs.hs 2021-07-22 15:38:47.000000000 +0200 +++ new/yesod-core-1.6.23.1/src/Yesod/Routes/TH/RouteAttrs.hs 2022-03-24 04:24:47.000000000 +0100 @@ -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 -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/yesod-core-1.6.21.0/test/YesodCoreTest/ErrorHandling.hs new/yesod-core-1.6.23.1/test/YesodCoreTest/ErrorHandling.hs --- old/yesod-core-1.6.21.0/test/YesodCoreTest/ErrorHandling.hs 2021-07-22 15:38:47.000000000 +0200 +++ new/yesod-core-1.6.23.1/test/YesodCoreTest/ErrorHandling.hs 2022-04-14 04:53:35.000000000 +0200 @@ -6,6 +6,10 @@ , 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 +17,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 +50,9 @@ /auth-not-adequate AuthNotAdequateR GET /args-not-valid ArgsNotValidR POST /only-plain-text OnlyPlainTextR GET + +/thread-killed ThreadKilledR GET +/async-session AsyncSessionR GET |] overrideStatus :: Status @@ -111,6 +119,22 @@ getGoodBuilderR :: Handler TypedContent getGoodBuilderR = return $ TypedContent "text/plain" $ toContent goodBuilderContent +-- 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 100000 + Conc.killThread x + pure "reachable" + getErrorR :: Int -> Handler () getErrorR 1 = setSession undefined "foo" getErrorR 2 = setSession "foo" undefined @@ -154,6 +178,8 @@ 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 runner :: Session a -> IO a runner f = toWaiApp App >>= runSession f @@ -291,3 +317,15 @@ ("accept", "video/webm") : requestHeaders defaultRequest } assertStatus 405 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 -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/yesod-core-1.6.21.0/test/YesodCoreTest/Meta.hs new/yesod-core-1.6.23.1/test/YesodCoreTest/Meta.hs --- old/yesod-core-1.6.21.0/test/YesodCoreTest/Meta.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/yesod-core-1.6.23.1/test/YesodCoreTest/Meta.hs 2022-04-25 11:55:17.000000000 +0200 @@ -0,0 +1,54 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +module YesodCoreTest.Meta + ( metaTest + ) where + +import Test.Hspec + +import Yesod.Core +import Network.Wai +import Network.Wai.Test + +data App = App + +mkYesod "App" [parseRoutes| +/title TitleR GET +/desc DescriptionR GET +|] + +instance Yesod App where + +getTitleR :: Handler Html +getTitleR = defaultLayout $ do + setTitle "First title" + setTitle "Second title" + +getDescriptionR :: Handler Html +getDescriptionR = defaultLayout $ do + setDescriptionIdemp "First description" + setDescriptionIdemp "Second description" + +metaTest :: Spec +metaTest = describe "Setting page metadata" $ do + describe "Yesod.Core.Widget.setTitle" $ do + it "is idempotent" $ runner $ do + res <- request defaultRequest + { pathInfo = ["title"] + } + assertBody "<!DOCTYPE html>\n<html><head><title>Second title</title></head><body></body></html>" res + describe "Yesod.Core.Widget.setDescriptionIdemp" $ do + it "is idempotent" $ runner $ do + res <- request defaultRequest + { pathInfo = ["desc"] + } + assertBody "<!DOCTYPE html>\n<html><head><title></title><meta name=\"description\" content=\"Second description\"></head><body></body></html>" res + +runner :: Session () -> IO () +runner f = toWaiAppPlain App >>= runSession f diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/yesod-core-1.6.21.0/test/YesodCoreTest.hs new/yesod-core-1.6.23.1/test/YesodCoreTest.hs --- old/yesod-core-1.6.21.0/test/YesodCoreTest.hs 2021-07-22 15:38:47.000000000 +0200 +++ new/yesod-core-1.6.23.1/test/YesodCoreTest.hs 2022-04-21 04:35:57.000000000 +0200 @@ -5,6 +5,7 @@ import YesodCoreTest.Exceptions import YesodCoreTest.Widget import YesodCoreTest.Media +import YesodCoreTest.Meta import YesodCoreTest.Links import YesodCoreTest.Header import YesodCoreTest.NoOverloadedStrings @@ -63,3 +64,4 @@ Ssl.sameSiteSpec Csrf.csrfSpec breadcrumbTest + metaTest diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/yesod-core-1.6.21.0/yesod-core.cabal new/yesod-core-1.6.23.1/yesod-core.cabal --- old/yesod-core-1.6.21.0/yesod-core.cabal 2021-07-22 15:38:47.000000000 +0200 +++ new/yesod-core-1.6.23.1/yesod-core.cabal 2022-04-25 11:55:17.000000000 +0200 @@ -1,5 +1,5 @@ name: yesod-core -version: 1.6.21.0 +version: 1.6.23.1 license: MIT license-file: LICENSE author: Michael Snoyman <mich...@snoyman.com> @@ -155,6 +155,7 @@ YesodCoreTest.LiteApp YesodCoreTest.Media YesodCoreTest.MediaData + YesodCoreTest.Meta YesodCoreTest.NoOverloadedStrings YesodCoreTest.NoOverloadedStringsSub YesodCoreTest.ParameterizedSite
