haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Add idempotent versions of setDescription API

Browse Source 
`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 `<meta/>` tags in HTML `<head/>`.

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.
This commit is contained in:
Isaac van Bakel 2022-04-20 12:31:49 +01:00
parent 9c0b00190a
commit b9fbdb3950
4 changed files with 82 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
yesod-core/src/Yesod/Core/Class/Yesod.hs
View File

@ -87,6 +87,8 @@ class RenderRoute site => Yesod site where
<html> <html>
<head> <head>
<title>#{pageTitle p} <title>#{pageTitle p}
$maybe description <- pageDescription p
<meta type="description" content="#{description}">
^{pageHead p} ^{pageHead p}
<body> <body>
$forall (status, msg) <- msgs $forall (status, msg) <- msgs
@ -539,8 +541,9 @@ widgetToPageContent w = do
{ wdRef = ref { wdRef = ref
, wdHandler = hd , 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 let title = maybe mempty unTitle mTitle
description = unDescription <$> mDescription
scripts = runUniqueList scripts' scripts = runUniqueList scripts'
stylesheets = runUniqueList stylesheets' stylesheets = runUniqueList stylesheets'
@ -610,7 +613,7 @@ widgetToPageContent w = do
^{regularScriptLoad} ^{regularScriptLoad}
|] |]
return $ PageContent title headAll $ return $ PageContent title description headAll $
case jsLoader master of case jsLoader master of
BottomOfBody -> bodyScript BottomOfBody -> bodyScript
_ -> body _ -> body

20
yesod-core/src/Yesod/Core/Types.hs
View File

@ -289,9 +289,10 @@ newtype CssBuilder = CssBuilder { unCssBuilder :: TBuilder.Builder }
-- --
-- > PageContent url -> HtmlUrl url -- > PageContent url -> HtmlUrl url
data PageContent url = PageContent data PageContent url = PageContent
{ pageTitle :: !Html { pageTitle :: !Html
, pageHead :: !(HtmlUrl url) , pageDescription :: !(Maybe Text)
, pageBody :: !(HtmlUrl url) , pageHead :: !(HtmlUrl url)
, pageBody :: !(HtmlUrl url)
} }
data Content = ContentBuilder !BB.Builder !(Maybe Int) -- ^ The content and optional content length. 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)] } data Stylesheet url = Stylesheet { styleLocation :: !(Location url), styleAttributes :: ![(Text, Text)] }
deriving (Show, Eq) deriving (Show, Eq)
newtype Title = Title { unTitle :: Html } newtype Title = Title { unTitle :: Html }
newtype Description = Description { unDescription :: Text }
newtype Head url = Head (HtmlUrl url) newtype Head url = Head (HtmlUrl url)
deriving Monoid deriving Monoid
@ -402,6 +404,7 @@ type CssBuilderUrl a = (a -> [(Text, Text)] -> Text) -> TBuilder.Builder
data GWData a = GWData data GWData a = GWData
{ gwdBody :: !(Body a) { gwdBody :: !(Body a)
, gwdTitle :: !(Last Title) , gwdTitle :: !(Last Title)
, gwdDescription :: !(Last Description)
, gwdScripts :: !(UniqueList (Script a)) , gwdScripts :: !(UniqueList (Script a))
, gwdStylesheets :: !(UniqueList (Stylesheet a)) , gwdStylesheets :: !(UniqueList (Stylesheet a))
, gwdCss :: !(Map (Maybe Text) (CssBuilderUrl a)) -- media type , gwdCss :: !(Map (Maybe Text) (CssBuilderUrl a)) -- media type
@ -409,20 +412,21 @@ data GWData a = GWData
, gwdHead :: !(Head a) , gwdHead :: !(Head a)
} }
instance Monoid (GWData a) where 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)) #if !(MIN_VERSION_base(4,11,0))
mappend = (<>) mappend = (<>)
#endif #endif
instance Semigroup (GWData a) where instance Semigroup (GWData a) where
GWData a1 a2 a3 a4 a5 a6 a7 <> GWData a1 a2 a3 a4 a5 a6 a7 a8 <>
GWData b1 b2 b3 b4 b5 b6 b7 = GWData GWData b1 b2 b3 b4 b5 b6 b7 b8 = GWData
(mappend a1 b1) (mappend a1 b1)
(mappend a2 b2) (mappend a2 b2)
(mappend a3 b3) (mappend a3 b3)
(mappend a4 b4) (mappend a4 b4)
(unionWith mappend a5 b5) (mappend a5 b5)
(mappend a6 b6) (unionWith mappend a6 b6)
(mappend a7 b7) (mappend a7 b7)
(mappend a8 b8)
data HandlerContents = data HandlerContents =
HCContent !H.Status !TypedContent HCContent !H.Status !TypedContent

74
yesod-core/src/Yesod/Core/Widget.hs
View File

@ -33,6 +33,8 @@ module Yesod.Core.Widget
, setTitleI , setTitleI
, setDescription , setDescription
, setDescriptionI , setDescriptionI
, setDescriptionIdemp
, setDescriptionIdempI
, setOGType , setOGType
, setOGImage , setOGImage
-- ** CSS -- ** CSS
@ -87,19 +89,19 @@ class ToWidget site a where
toWidget :: (MonadWidget m, HandlerSite m ~ site) => a -> m () toWidget :: (MonadWidget m, HandlerSite m ~ site) => a -> m ()
instance render ~ RY site => ToWidget site (render -> Html) where 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 instance render ~ RY site => ToWidget site (render -> Css) where
toWidget x = toWidget $ CssBuilder . fromLazyText . renderCss . x toWidget x = toWidget $ CssBuilder . fromLazyText . renderCss . x
instance ToWidget site Css where instance ToWidget site Css where
toWidget x = toWidget $ CssBuilder . fromLazyText . renderCss . const x toWidget x = toWidget $ CssBuilder . fromLazyText . renderCss . const x
instance render ~ RY site => ToWidget site (render -> CssBuilder) where 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 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 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 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 instance (site' ~ site, a ~ ()) => ToWidget site' (WidgetFor site a) where
toWidget = liftWidget toWidget = liftWidget
instance ToWidget site Html where instance ToWidget site Html where
@ -130,9 +132,9 @@ instance render ~ RY site => ToWidgetMedia site (render -> Css) where
instance ToWidgetMedia site Css where instance ToWidgetMedia site Css where
toWidgetMedia media x = toWidgetMedia media $ CssBuilder . fromLazyText . renderCss . const x toWidgetMedia media x = toWidgetMedia media $ CssBuilder . fromLazyText . renderCss . const x
instance render ~ RY site => ToWidgetMedia site (render -> CssBuilder) where 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 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 class ToWidgetBody site a where
toWidgetBody :: (MonadWidget m, HandlerSite m ~ site) => a -> m () 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 () toWidgetHead :: (MonadWidget m, HandlerSite m ~ site) => a -> m ()
instance render ~ RY site => ToWidgetHead site (render -> Html) where 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 instance render ~ RY site => ToWidgetHead site (render -> Css) where
toWidgetHead = toWidget toWidgetHead = toWidget
instance ToWidgetHead site Css where 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 -- * Google typically shows 55-64 characters, so aim to keep your title
-- length under 60 characters -- length under 60 characters
setTitle :: MonadWidget m => Html -> m () 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. -- | Set the localised page title.
-- --
@ -208,6 +210,14 @@ setDescription :: MonadWidget m => Text -> m ()
setDescription description = setDescription description =
toWidgetHead $ [hamlet|<meta name=description content=#{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 -- | Add translated description meta tag to the head of the page
-- --
-- n.b. See comments for @setDescription@. -- n.b. See comments for @setDescription@.
@ -220,6 +230,44 @@ setDescriptionI msg = do
mr <- getMessageRender mr <- getMessageRender
toWidgetHead $ [hamlet|<meta name=description content=#{mr msg}>|] 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 -- | Add OpenGraph type meta tag to the head of the page
-- --
-- See all available OG types here: https://ogp.me/#types -- See all available OG types here: https://ogp.me/#types
@ -252,7 +300,7 @@ addStylesheetAttrs :: MonadWidget m
=> Route (HandlerSite m) => Route (HandlerSite m)
-> [(Text, Text)] -> [(Text, Text)]
-> m () -> 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. -- | Link to the specified remote stylesheet.
addStylesheetRemote :: MonadWidget m => Text -> m () addStylesheetRemote :: MonadWidget m => Text -> m ()
@ -260,7 +308,7 @@ addStylesheetRemote = flip addStylesheetRemoteAttrs []
-- | Link to the specified remote stylesheet. -- | Link to the specified remote stylesheet.
addStylesheetRemoteAttrs :: MonadWidget m => Text -> [(Text, Text)] -> m () 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 addStylesheetEither :: MonadWidget m
=> Either (Route (HandlerSite m)) Text => Either (Route (HandlerSite m)) Text
@ -278,7 +326,7 @@ addScript = flip addScriptAttrs []
-- | Link to the specified local script. -- | Link to the specified local script.
addScriptAttrs :: MonadWidget m => Route (HandlerSite m) -> [(Text, Text)] -> m () 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. -- | Link to the specified remote script.
addScriptRemote :: MonadWidget m => Text -> m () addScriptRemote :: MonadWidget m => Text -> m ()
@ -286,7 +334,7 @@ addScriptRemote = flip addScriptRemoteAttrs []
-- | Link to the specified remote script. -- | Link to the specified remote script.
addScriptRemoteAttrs :: MonadWidget m => Text -> [(Text, Text)] -> m () 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 :: QuasiQuoter
whamlet = NP.hamletWithSettings rules NP.defaultHamletSettings whamlet = NP.hamletWithSettings rules NP.defaultHamletSettings

8
yesod-core/test/YesodCoreTest/Meta.hs
View File

@ -32,8 +32,8 @@ getTitleR = defaultLayout $ do
getDescriptionR :: Handler Html getDescriptionR :: Handler Html
getDescriptionR = defaultLayout $ do getDescriptionR = defaultLayout $ do
setDescription "First description" setDescriptionIdemp "First description"
setDescription "Second description" setDescriptionIdemp "Second description"
metaTest :: Spec metaTest :: Spec
metaTest = describe "Setting page metadata" $ do metaTest = describe "Setting page metadata" $ do
@ -43,12 +43,12 @@ metaTest = describe "Setting page metadata" $ do
{ pathInfo = ["title"] { pathInfo = ["title"]
} }
assertBody "<!DOCTYPE html>\n<html><head><title>Second title</title></head><body></body></html>" res assertBody "<!DOCTYPE html>\n<html><head><title>Second title</title></head><body></body></html>" res
describe "Yesod.Core.Widget.setDescription" $ do describe "Yesod.Core.Widget.setDescriptionIdemp" $ do
it "is idempotent" $ runner $ do it "is idempotent" $ runner $ do
res <- request defaultRequest res <- request defaultRequest
{ pathInfo = ["desc"] { pathInfo = ["desc"]
} }
assertBody "<!DOCTYPE html>\n<html><head><title></title><meta type=\"description\">Second description</meta></head><body></body></html>" res assertBody "<!DOCTYPE html>\n<html><head><title></title><meta type=\"description\" content=\"Second description\"></head><body></body></html>" res
runner :: Session () -> IO () runner :: Session () -> IO ()
runner f = toWaiAppPlain App >>= runSession f runner f = toWaiAppPlain App >>= runSession f