Merge pull request #1765 from ivanbakel/idempotent-description

Add API for idempotent page description editing
2022-04-21 05:35:40 +03:00 · 2022-04-21 05:35:40 +03:00 · f338e519f2
commit f338e519f2
parent 4f962c9073 04683ca58b
7 changed files with 148 additions and 24 deletions
--- a/yesod-core/ChangeLog.md
+++ b/yesod-core/ChangeLog.md
@ -1,5 +1,13 @@
 # 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)
--- 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
            <html>
                <head>
                    <title>#{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
--- 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
--- 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,48 @@ 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/
+--
+-- @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 @@ 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 +312,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 +330,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 +338,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
--- a/yesod-core/test/YesodCoreTest.hs
+++ b/yesod-core/test/YesodCoreTest.hs
@ -5,6 +5,7 @@ import YesodCoreTest.CleanPath
 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 @@ specs = do
      Ssl.sameSiteSpec
      Csrf.csrfSpec
      breadcrumbTest
+      metaTest
--- a/yesod-core/test/YesodCoreTest/Meta.hs
+++ b/yesod-core/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</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 type=\"description\" content=\"Second description\"></head><body></body></html>" res
+
+runner :: Session () -> IO ()
+runner f = toWaiAppPlain App >>= runSession f
--- a/yesod-core/yesod-core.cabal
+++ b/yesod-core/yesod-core.cabal
@ -1,5 +1,5 @@
 name:            yesod-core
-version:         1.6.22.1
+version:         1.6.23
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@ -155,6 +155,7 @@ test-suite tests
                   YesodCoreTest.LiteApp
                   YesodCoreTest.Media
                   YesodCoreTest.MediaData
+                   YesodCoreTest.Meta
                   YesodCoreTest.NoOverloadedStrings
                   YesodCoreTest.NoOverloadedStringsSub
                   YesodCoreTest.ParameterizedSite