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

Merge pull request #1765 from ivanbakel/idempotent-description

Browse Source 
Add API for idempotent page description editing
This commit is contained in:
Michael Snoyman 2022-04-21 05:35:40 +03:00 committed by GitHub
commit f338e519f2
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
7 changed files with 148 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
yesod-core/ChangeLog.md
View File

@ -1,5 +1,13 @@
# ChangeLog for yesod-core # 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 ## 1.6.22.1
+ Remove sometimes failing superfluous test. [#1756](https://github.com/yesodweb/yesod/pull/1756) + Remove sometimes failing superfluous test. [#1756](https://github.com/yesodweb/yesod/pull/1756)

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

78
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,48 @@ 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/
--
-- @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 -- | 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 +304,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 +312,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 +330,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 +338,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

2
yesod-core/test/YesodCoreTest.hs
View File

@ -5,6 +5,7 @@ import YesodCoreTest.CleanPath
import YesodCoreTest.Exceptions import YesodCoreTest.Exceptions
import YesodCoreTest.Widget import YesodCoreTest.Widget
import YesodCoreTest.Media import YesodCoreTest.Media
import YesodCoreTest.Meta
import YesodCoreTest.Links import YesodCoreTest.Links
import YesodCoreTest.Header import YesodCoreTest.Header
import YesodCoreTest.NoOverloadedStrings import YesodCoreTest.NoOverloadedStrings
@ -63,3 +64,4 @@ specs = do
Ssl.sameSiteSpec Ssl.sameSiteSpec
Csrf.csrfSpec Csrf.csrfSpec
breadcrumbTest breadcrumbTest
metaTest

54
yesod-core/test/YesodCoreTest/Meta.hs Normal file
View File

@ -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

3
yesod-core/yesod-core.cabal
View File

@ -1,5 +1,5 @@
name: yesod-core name: yesod-core
version: 1.6.22.1 version: 1.6.23
license: MIT license: MIT
license-file: LICENSE license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com> author: Michael Snoyman <michael@snoyman.com>
@ -155,6 +155,7 @@ test-suite tests
YesodCoreTest.LiteApp YesodCoreTest.LiteApp
YesodCoreTest.Media YesodCoreTest.Media
YesodCoreTest.MediaData YesodCoreTest.MediaData
YesodCoreTest.Meta
YesodCoreTest.NoOverloadedStrings YesodCoreTest.NoOverloadedStrings
YesodCoreTest.NoOverloadedStringsSub YesodCoreTest.NoOverloadedStringsSub
YesodCoreTest.ParameterizedSite YesodCoreTest.ParameterizedSite