59f601a34c
* Add functions for setting description and OG meta It's common that a website author will want to add a specific description and Open Graph image to a given page in their website. These functions are simple conveniences to add these meta tags to the document head. I decided against simply adding all possible meta tags, because not all of them are useful, and even in the case of Open Graph tags, many of them should be set only once and they should use the same value for the entire website. In those cases, it's probably better for the website author to add those tags in their layout template. Closes https://github.com/yesodweb/yesod/issues/1659
346 lines
13 KiB
Haskell
346 lines
13 KiB
Haskell
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
{-# LANGUAGE TupleSections #-}
|
|
{-# LANGUAGE RankNTypes #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE TypeSynonymInstances #-}
|
|
{-# LANGUAGE UndecidableInstances #-}
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
|
|
-- | Widgets combine HTML with JS and CSS dependencies with a unique identifier
|
|
-- generator, allowing you to create truly modular HTML components.
|
|
module Yesod.Core.Widget
|
|
( -- * Datatype
|
|
WidgetT
|
|
, WidgetFor
|
|
, PageContent (..)
|
|
-- * Special Hamlet quasiquoter/TH for Widgets
|
|
, whamlet
|
|
, whamletFile
|
|
, ihamletToRepHtml
|
|
, ihamletToHtml
|
|
-- * Convert to Widget
|
|
, ToWidget (..)
|
|
, ToWidgetHead (..)
|
|
, ToWidgetBody (..)
|
|
, ToWidgetMedia (..)
|
|
-- * Creating
|
|
-- ** Head of page
|
|
, setTitle
|
|
, setTitleI
|
|
, setDescription
|
|
, setDescriptionI
|
|
, setOGType
|
|
, setOGImage
|
|
-- ** CSS
|
|
, addStylesheet
|
|
, addStylesheetAttrs
|
|
, addStylesheetRemote
|
|
, addStylesheetRemoteAttrs
|
|
, addStylesheetEither
|
|
, CssBuilder (..)
|
|
-- ** Javascript
|
|
, addScript
|
|
, addScriptAttrs
|
|
, addScriptRemote
|
|
, addScriptRemoteAttrs
|
|
, addScriptEither
|
|
-- * Subsites
|
|
, handlerToWidget
|
|
-- * Internal
|
|
, whamletFileWithSettings
|
|
, asWidgetT
|
|
) where
|
|
|
|
import Data.Monoid
|
|
import qualified Text.Blaze.Html5 as H
|
|
import Text.Hamlet
|
|
import Text.Cassius
|
|
import Text.Julius
|
|
import Yesod.Routes.Class
|
|
import Yesod.Core.Handler (getMessageRender, getUrlRenderParams)
|
|
import Text.Shakespeare.I18N (RenderMessage)
|
|
import Data.Text (Text)
|
|
import qualified Data.Map as Map
|
|
import Language.Haskell.TH.Quote (QuasiQuoter)
|
|
import Language.Haskell.TH.Syntax (Q, Exp (InfixE, VarE, LamE, AppE), Pat (VarP), newName)
|
|
|
|
import qualified Text.Hamlet as NP
|
|
import Data.Text.Lazy.Builder (fromLazyText)
|
|
import Text.Blaze.Html (toHtml, preEscapedToMarkup)
|
|
import qualified Data.Text.Lazy as TL
|
|
import qualified Data.Text.Lazy.Builder as TB
|
|
|
|
import Yesod.Core.Types
|
|
import Yesod.Core.Class.Handler
|
|
|
|
type WidgetT site (m :: * -> *) = WidgetFor site
|
|
{-# DEPRECATED WidgetT "Use WidgetFor directly" #-}
|
|
|
|
preEscapedLazyText :: TL.Text -> Html
|
|
preEscapedLazyText = preEscapedToMarkup
|
|
|
|
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
|
|
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
|
|
instance ToWidget site CssBuilder where
|
|
toWidget x = tell $ GWData 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
|
|
instance ToWidget site Javascript where
|
|
toWidget x = tell $ GWData 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
|
|
toWidget = toWidget . const
|
|
-- | @since 1.4.28
|
|
instance ToWidget site Text where
|
|
toWidget = toWidget . toHtml
|
|
-- | @since 1.4.28
|
|
instance ToWidget site TL.Text where
|
|
toWidget = toWidget . toHtml
|
|
-- | @since 1.4.28
|
|
instance ToWidget site TB.Builder where
|
|
toWidget = toWidget . toHtml
|
|
|
|
-- | Allows adding some CSS to the page with a specific media type.
|
|
--
|
|
-- Since 1.2
|
|
class ToWidgetMedia site a where
|
|
-- | Add the given content to the page, but only for the given media type.
|
|
--
|
|
-- Since 1.2
|
|
toWidgetMedia :: (MonadWidget m, HandlerSite m ~ site)
|
|
=> Text -- ^ media value
|
|
-> a
|
|
-> m ()
|
|
instance render ~ RY site => ToWidgetMedia site (render -> Css) where
|
|
toWidgetMedia media x = toWidgetMedia media $ CssBuilder . fromLazyText . renderCss . x
|
|
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
|
|
instance ToWidgetMedia site CssBuilder where
|
|
toWidgetMedia media x = tell $ GWData 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 ()
|
|
|
|
instance render ~ RY site => ToWidgetBody site (render -> Html) where
|
|
toWidgetBody = toWidget
|
|
instance render ~ RY site => ToWidgetBody site (render -> Javascript) where
|
|
toWidgetBody j = toWidget $ \r -> H.script $ preEscapedLazyText $ renderJavascriptUrl r j
|
|
instance ToWidgetBody site Javascript where
|
|
toWidgetBody j = toWidget $ \_ -> H.script $ preEscapedLazyText $ renderJavascript j
|
|
instance ToWidgetBody site Html where
|
|
toWidgetBody = toWidget
|
|
|
|
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
|
|
instance render ~ RY site => ToWidgetHead site (render -> Css) where
|
|
toWidgetHead = toWidget
|
|
instance ToWidgetHead site Css where
|
|
toWidgetHead = toWidget
|
|
instance render ~ RY site => ToWidgetHead site (render -> CssBuilder) where
|
|
toWidgetHead = toWidget
|
|
instance ToWidgetHead site CssBuilder where
|
|
toWidgetHead = toWidget
|
|
instance render ~ RY site => ToWidgetHead site (render -> Javascript) where
|
|
toWidgetHead j = toWidgetHead $ \r -> H.script $ preEscapedLazyText $ renderJavascriptUrl r j
|
|
instance ToWidgetHead site Javascript where
|
|
toWidgetHead j = toWidgetHead $ \_ -> H.script $ preEscapedLazyText $ renderJavascript j
|
|
instance ToWidgetHead site Html where
|
|
toWidgetHead = toWidgetHead . const
|
|
|
|
-- | Set the page title.
|
|
--
|
|
-- Calling @setTitle@ or @setTitleI@ multiple times overrides previously set
|
|
-- values.
|
|
--
|
|
-- SEO Notes:
|
|
--
|
|
-- * Title tags are the second most important on-page factor for SEO, after
|
|
-- content
|
|
-- * Every page should have a unique title tag
|
|
-- * Start your title tag with your main targeted keyword
|
|
-- * Don't stuff your keywords
|
|
-- * 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
|
|
|
|
-- | Set the localised page title.
|
|
--
|
|
-- n.b. See comments for @setTitle@
|
|
setTitleI :: (MonadWidget m, RenderMessage (HandlerSite m) msg) => msg -> m ()
|
|
setTitleI msg = do
|
|
mr <- getMessageRender
|
|
setTitle $ toHtml $ mr msg
|
|
|
|
-- | 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.
|
|
--
|
|
-- Source: https://www.advancedwebranking.com/blog/meta-tags-important-in-seo/
|
|
--
|
|
-- @since 1.6.18
|
|
setDescription :: MonadWidget m => Text -> m ()
|
|
setDescription description =
|
|
toWidgetHead $ [hamlet|<meta name=description content=#{description}>|]
|
|
|
|
-- | Add translated description meta tag to the head of the page
|
|
--
|
|
-- n.b. See comments for @setDescription@.
|
|
--
|
|
-- @since 1.6.18
|
|
setDescriptionI
|
|
:: (MonadWidget m, RenderMessage (HandlerSite m) msg)
|
|
=> msg -> m ()
|
|
setDescriptionI msg = do
|
|
mr <- getMessageRender
|
|
toWidgetHead $ [hamlet|<meta name=description content=#{mr msg}>|]
|
|
|
|
-- | Add OpenGraph type meta tag to the head of the page
|
|
--
|
|
-- See all available OG types here: https://ogp.me/#types
|
|
--
|
|
-- @since 1.6.18
|
|
setOGType :: MonadWidget m => Text -> m ()
|
|
setOGType a = toWidgetHead $ [hamlet|<meta name="og:type" content=#{a}>|]
|
|
|
|
-- | Add OpenGraph image meta tag to the head of the page
|
|
--
|
|
-- Best practices:
|
|
--
|
|
-- * Use custom images for shareable pages, e.g., homepage, articles, etc.
|
|
-- * Use your logo or any other branded image for the rest of your pages.
|
|
-- * Use images with a 1.91:1 ratio and minimum recommended dimensions of
|
|
-- 1200x630 for optimal clarity across all devices.
|
|
--
|
|
-- Source: https://ahrefs.com/blog/open-graph-meta-tags/
|
|
--
|
|
-- @since 1.6.18
|
|
setOGImage :: MonadWidget m => Text -> m ()
|
|
setOGImage a = toWidgetHead $ [hamlet|<meta name="og:image" content=#{a}>|]
|
|
|
|
-- | Link to the specified local stylesheet.
|
|
addStylesheet :: MonadWidget m => Route (HandlerSite m) -> m ()
|
|
addStylesheet = flip addStylesheetAttrs []
|
|
|
|
-- | Link to the specified local stylesheet.
|
|
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
|
|
|
|
-- | Link to the specified remote stylesheet.
|
|
addStylesheetRemote :: MonadWidget m => Text -> m ()
|
|
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
|
|
|
|
addStylesheetEither :: MonadWidget m
|
|
=> Either (Route (HandlerSite m)) Text
|
|
-> m ()
|
|
addStylesheetEither = either addStylesheet addStylesheetRemote
|
|
|
|
addScriptEither :: MonadWidget m
|
|
=> Either (Route (HandlerSite m)) Text
|
|
-> m ()
|
|
addScriptEither = either addScript addScriptRemote
|
|
|
|
-- | Link to the specified local script.
|
|
addScript :: MonadWidget m => Route (HandlerSite m) -> m ()
|
|
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
|
|
|
|
-- | Link to the specified remote script.
|
|
addScriptRemote :: MonadWidget m => Text -> m ()
|
|
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
|
|
|
|
whamlet :: QuasiQuoter
|
|
whamlet = NP.hamletWithSettings rules NP.defaultHamletSettings
|
|
|
|
whamletFile :: FilePath -> Q Exp
|
|
whamletFile = NP.hamletFileWithSettings rules NP.defaultHamletSettings
|
|
|
|
whamletFileWithSettings :: NP.HamletSettings -> FilePath -> Q Exp
|
|
whamletFileWithSettings = NP.hamletFileWithSettings rules
|
|
|
|
asWidgetT :: WidgetT site m () -> WidgetT site m ()
|
|
asWidgetT = id
|
|
|
|
rules :: Q NP.HamletRules
|
|
rules = do
|
|
ah <- [|asWidgetT . toWidget|]
|
|
let helper qg f = do
|
|
x <- newName "urender"
|
|
e <- f $ VarE x
|
|
let e' = LamE [VarP x] e
|
|
g <- qg
|
|
bind <- [|(>>=)|]
|
|
return $ InfixE (Just g) bind (Just e')
|
|
let ur f = do
|
|
let env = NP.Env
|
|
(Just $ helper [|getUrlRenderParams|])
|
|
(Just $ helper [|fmap (toHtml .) getMessageRender|])
|
|
f env
|
|
return $ NP.HamletRules ah ur $ \_ b -> return $ ah `AppE` b
|
|
|
|
-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.
|
|
ihamletToRepHtml :: (MonadHandler m, RenderMessage (HandlerSite m) message)
|
|
=> HtmlUrlI18n message (Route (HandlerSite m))
|
|
-> m Html
|
|
ihamletToRepHtml = ihamletToHtml
|
|
{-# DEPRECATED ihamletToRepHtml "Please use ihamletToHtml instead" #-}
|
|
|
|
-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.
|
|
--
|
|
-- Since 1.2.1
|
|
ihamletToHtml :: (MonadHandler m, RenderMessage (HandlerSite m) message)
|
|
=> HtmlUrlI18n message (Route (HandlerSite m))
|
|
-> m Html
|
|
ihamletToHtml ih = do
|
|
urender <- getUrlRenderParams
|
|
mrender <- getMessageRender
|
|
return $ ih (toHtml . mrender) urender
|
|
|
|
tell :: MonadWidget m => GWData (Route (HandlerSite m)) -> m ()
|
|
tell = liftWidget . tellWidget
|
|
|
|
toUnique :: x -> UniqueList x
|
|
toUnique = UniqueList . (:)
|
|
|
|
handlerToWidget :: HandlerFor site a -> WidgetFor site a
|
|
handlerToWidget (HandlerFor f) = WidgetFor $ f . wdHandler
|