From b9fbdb3950d60e74114adb3d1c8edb321cbb5f3a Mon Sep 17 00:00:00 2001 From: Isaac van Bakel Date: Wed, 20 Apr 2022 12:31:49 +0100 Subject: [PATCH] Add idempotent versions of setDescription API `setDescription` and `setDescriptionI` present a similar API to `setTitle` and `setTitleI`, but unlike those functions the description functions are not idempotent - so calling them multiple times inserts multiple `` tags in HTML ``. This adds explicitly idempotent versions of those functions which are handled in a similar way to the title, so that calling them multiple times has the effect of taking the final value specified. Because the non-idempotent behaviour of setDescription is not obvious, this also adds warnings for that behaviour to make it clear what the effect of multiple calls will be. Unfortunately, setDescriptionIdemp can't be made a drop-in replacement because developers may have defined their own layouts which need to take pageDescription into account. --- yesod-core/src/Yesod/Core/Class/Yesod.hs | 7 ++- yesod-core/src/Yesod/Core/Types.hs | 20 ++++--- yesod-core/src/Yesod/Core/Widget.hs | 74 +++++++++++++++++++----- yesod-core/test/YesodCoreTest/Meta.hs | 8 +-- 4 files changed, 82 insertions(+), 27 deletions(-) diff --git a/yesod-core/src/Yesod/Core/Class/Yesod.hs b/yesod-core/src/Yesod/Core/Class/Yesod.hs index 2a2c1b04..3a3756c6 100644 --- a/yesod-core/src/Yesod/Core/Class/Yesod.hs +++ b/yesod-core/src/Yesod/Core/Class/Yesod.hs @@ -87,6 +87,8 @@ class RenderRoute site => Yesod site where #{pageTitle p} + $maybe description <- pageDescription p + <meta type="description" content="#{description}"> ^{pageHead p} <body> $forall (status, msg) <- msgs @@ -539,8 +541,9 @@ widgetToPageContent w = do { 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 @@ widgetToPageContent w = do ^{regularScriptLoad} |] - return $ PageContent title headAll $ + return $ PageContent title description headAll $ case jsLoader master of BottomOfBody -> bodyScript _ -> body diff --git a/yesod-core/src/Yesod/Core/Types.hs b/yesod-core/src/Yesod/Core/Types.hs index 11a55f1a..df95b2d9 100644 --- a/yesod-core/src/Yesod/Core/Types.hs +++ b/yesod-core/src/Yesod/Core/Types.hs @@ -289,9 +289,10 @@ newtype CssBuilder = CssBuilder { unCssBuilder :: TBuilder.Builder } -- -- > 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 Script url = Script { scriptLocation :: !(Location url), scriptAttributes : 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 @@ type CssBuilderUrl a = (a -> [(Text, Text)] -> Text) -> TBuilder.Builder 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 @@ data GWData a = GWData , 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/yesod-core/src/Yesod/Core/Widget.hs b/yesod-core/src/Yesod/Core/Widget.hs index 20569790..0e652b79 100644 --- a/yesod-core/src/Yesod/Core/Widget.hs +++ b/yesod-core/src/Yesod/Core/Widget.hs @@ -33,6 +33,8 @@ module Yesod.Core.Widget , setTitleI , setDescription , setDescriptionI + , setDescriptionIdemp + , setDescriptionIdempI , setOGType , setOGImage -- ** CSS @@ -87,19 +89,19 @@ class ToWidget site a where 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 render ~ RY site => ToWidgetMedia site (render -> Css) where 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 @@ class ToWidgetHead site a where 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 @@ instance ToWidgetHead site Html where -- * 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 :: MonadWidget m => Text -> m () 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,44 @@ setDescriptionI msg = do 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/ +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. +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 +300,7 @@ addStylesheetAttrs :: MonadWidget m => 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 +308,7 @@ addStylesheetRemote = flip addStylesheetRemoteAttrs [] -- | 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 +326,7 @@ addScript = flip addScriptAttrs [] -- | 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 +334,7 @@ addScriptRemote = flip addScriptRemoteAttrs [] -- | 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/yesod-core/test/YesodCoreTest/Meta.hs b/yesod-core/test/YesodCoreTest/Meta.hs index ed0a0849..6bd9af28 100644 --- a/yesod-core/test/YesodCoreTest/Meta.hs +++ b/yesod-core/test/YesodCoreTest/Meta.hs @@ -32,8 +32,8 @@ getTitleR = defaultLayout $ do getDescriptionR :: Handler Html getDescriptionR = defaultLayout $ do - setDescription "First description" - setDescription "Second description" + setDescriptionIdemp "First description" + setDescriptionIdemp "Second description" metaTest :: Spec metaTest = describe "Setting page metadata" $ do @@ -43,12 +43,12 @@ metaTest = describe "Setting page metadata" $ do { pathInfo = ["title"] } assertBody "<!DOCTYPE html>\n<html><head><title>Second title" res - describe "Yesod.Core.Widget.setDescription" $ do + describe "Yesod.Core.Widget.setDescriptionIdemp" $ do it "is idempotent" $ runner $ do res <- request defaultRequest { pathInfo = ["desc"] } - assertBody "\nSecond description" res + assertBody "\n" res runner :: Session () -> IO () runner f = toWaiAppPlain App >>= runSession f