diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,17 @@ # ChangeLog for yesod-core +## 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) diff --git a/src/Yesod/Core/Class/Yesod.hs b/src/Yesod/Core/Class/Yesod.hs --- a/src/Yesod/Core/Class/Yesod.hs +++ b/src/Yesod/Core/Class/Yesod.hs @@ -87,6 +87,8 @@ #{pageTitle p} + $maybe description <- pageDescription p + <meta type="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 --git a/src/Yesod/Core/Types.hs b/src/Yesod/Core/Types.hs --- a/src/Yesod/Core/Types.hs +++ b/src/Yesod/Core/Types.hs @@ -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 --git a/src/Yesod/Core/Widget.hs b/src/Yesod/Core/Widget.hs --- a/src/Yesod/Core/Widget.hs +++ b/src/Yesod/Core/Widget.hs @@ -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 --git a/test/YesodCoreTest.hs b/test/YesodCoreTest.hs --- a/test/YesodCoreTest.hs +++ b/test/YesodCoreTest.hs @@ -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 --git a/test/YesodCoreTest/ErrorHandling.hs b/test/YesodCoreTest/ErrorHandling.hs --- a/test/YesodCoreTest/ErrorHandling.hs +++ b/test/YesodCoreTest/ErrorHandling.hs @@ -1,6 +1,5 @@ {-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE ViewPatterns #-} module YesodCoreTest.ErrorHandling ( errorHandlingTest @@ -52,7 +51,6 @@ /args-not-valid ArgsNotValidR POST /only-plain-text OnlyPlainTextR GET -/allocation-limit AlocationLimitR GET /thread-killed ThreadKilledR GET /async-session AsyncSessionR GET |] @@ -121,17 +119,6 @@ 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 @@ -144,7 +131,7 @@ 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 + liftIO $ Conc.threadDelay 100000 Conc.killThread x pure "reachable" @@ -192,7 +179,6 @@ 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 @@ -331,12 +317,6 @@ ("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 diff --git a/test/YesodCoreTest/Meta.hs b/test/YesodCoreTest/Meta.hs new file mode 100644 --- /dev/null +++ b/test/YesodCoreTest/Meta.hs @@ -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" res + describe "Yesod.Core.Widget.setDescriptionIdemp" $ do + it "is idempotent" $ runner $ do + res <- request defaultRequest + { pathInfo = ["desc"] + } + assertBody "\n" res + +runner :: Session () -> IO () +runner f = toWaiAppPlain App >>= runSession f 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.22.0 +version: 1.6.23 license: MIT license-file: LICENSE author: Michael Snoyman @@ -155,6 +155,7 @@ YesodCoreTest.LiteApp YesodCoreTest.Media YesodCoreTest.MediaData + YesodCoreTest.Meta YesodCoreTest.NoOverloadedStrings YesodCoreTest.NoOverloadedStringsSub YesodCoreTest.ParameterizedSite