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 `<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
parent
9c0b00190a
commit
b9fbdb3950
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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</title></head><body></body></html>" res
|
||||
describe "Yesod.Core.Widget.setDescription" $ do
|
||||
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\">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 f = toWaiAppPlain App >>= runSession f
|
||||
|
||||
Loading…
Reference in New Issue
Block a user