ihp-pagehead (empty) → 1.0.0
raw patch · 5 files changed
+450/−0 lines, 5 filesdep +basedep +blaze-htmldep +ihp-context
Dependencies added: base, blaze-html, ihp-context, ihp-hsx, text, vault, wai
Files
- IHP/PageHead/ControllerFunctions.hs +59/−0
- IHP/PageHead/Types.hs +56/−0
- IHP/PageHead/ViewFunctions.hs +264/−0
- LICENSE +21/−0
- ihp-pagehead.cabal +50/−0
+ IHP/PageHead/ControllerFunctions.hs view
@@ -0,0 +1,59 @@+{-|+Module: IHP.PageHead.ControllerFunctions+Description: Manage the @<title>@ and @<meta>@ tags of your HTML pages+Copyright: (c) digitally induced GmbH, 2021+-}+module IHP.PageHead.ControllerFunctions+( setTitle+, setDescription+, setOGTitle+, setOGType+, setOGDescription+, setOGUrl+, setOGImage+) where++import Prelude+import Data.IORef (modifyIORef')+import Data.Text (Text)+import Network.Wai (Request)+import IHP.PageHead.Types++-- | Sets the page title. Can be accessed using '{pageTitle}' inside your @Layout.hs@.+--+-- Example:+--+-- > action ShowProjectAction { projectId } = do+-- > project <- fetch projectId+-- > setTitle (project.title)+-- >+--+-- Inside your layout use it like:+--+-- > defaultLayout :: Html -> Html+-- > defaultLayout inner = [hsx|+-- > <head>+-- > <title>{pageTitle}</title>+-- > </head>+-- > |]+--+setTitle :: (?request :: Request) => Text -> IO ()+setTitle title = modifyIORef' (lookupPageHeadVault pageHeadVaultKey ?request) (\s -> s { title = Just (PageTitle title) })++setDescription :: (?request :: Request) => Text -> IO ()+setDescription description = modifyIORef' (lookupPageHeadVault pageHeadVaultKey ?request) (\s -> s { description = Just (PageDescription description) })++setOGTitle :: (?request :: Request) => Text -> IO ()+setOGTitle title = modifyIORef' (lookupPageHeadVault pageHeadVaultKey ?request) (\s -> s { ogTitle = Just (OGTitle title) })++setOGType :: (?request :: Request) => Text -> IO ()+setOGType type_ = modifyIORef' (lookupPageHeadVault pageHeadVaultKey ?request) (\s -> s { ogType = Just (OGType type_) })++setOGDescription :: (?request :: Request) => Text -> IO ()+setOGDescription description = modifyIORef' (lookupPageHeadVault pageHeadVaultKey ?request) (\s -> s { ogDescription = Just (OGDescription description) })++setOGUrl :: (?request :: Request) => Text -> IO ()+setOGUrl url = modifyIORef' (lookupPageHeadVault pageHeadVaultKey ?request) (\s -> s { ogUrl = Just (OGUrl url) })++setOGImage :: (?request :: Request) => Text -> IO ()+setOGImage image = modifyIORef' (lookupPageHeadVault pageHeadVaultKey ?request) (\s -> s { ogImage = Just (OGImage image) })
+ IHP/PageHead/Types.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE NoFieldSelectors #-}+{-|+Module: IHP.PageHead.Types+Copyright: (c) digitally induced GmbH, 2021+-}+module IHP.PageHead.Types where++import Data.Text (Text)+import Data.Maybe (Maybe(..))+import Data.IORef (IORef)+import Data.Typeable (Typeable, typeRep)+import Data.Proxy (Proxy(..))+import Data.Semigroup ((<>))+import GHC.Err (error)+import GHC.Show (show)+import Data.Function (($))+import qualified Data.Vault.Lazy as Vault+import Network.Wai+import System.IO.Unsafe (unsafePerformIO)++newtype PageTitle = PageTitle Text++newtype PageDescription = PageDescription Text++newtype OGTitle = OGTitle Text++newtype OGType = OGType Text++newtype OGDescription = OGDescription Text++newtype OGUrl = OGUrl Text++newtype OGImage = OGImage Text++data PageHeadState = PageHeadState+ { title :: Maybe PageTitle+ , description :: Maybe PageDescription+ , ogTitle :: Maybe OGTitle+ , ogType :: Maybe OGType+ , ogDescription :: Maybe OGDescription+ , ogUrl :: Maybe OGUrl+ , ogImage :: Maybe OGImage+ }++emptyPageHeadState :: PageHeadState+emptyPageHeadState = PageHeadState Nothing Nothing Nothing Nothing Nothing Nothing Nothing++pageHeadVaultKey :: Vault.Key (IORef PageHeadState)+pageHeadVaultKey = unsafePerformIO Vault.newKey+{-# NOINLINE pageHeadVaultKey #-}++lookupPageHeadVault :: forall value. Typeable value => Vault.Key value -> Request -> value+lookupPageHeadVault key req =+ case Vault.lookup key req.vault of+ Just v -> v+ Nothing -> error $ "lookupPageHeadVault: Could not find " <> show (typeRep (Proxy @value) ) <> " in request vault. Did you forget to add the PageHead middleware?"
+ IHP/PageHead/ViewFunctions.hs view
@@ -0,0 +1,264 @@+{-|+Module: IHP.PageHead.ViewFunctions+Description: Manage the @<title>@ and @<meta>@ tags of your HTML pages+Copyright: (c) digitally induced GmbH, 2021+-}+module IHP.PageHead.ViewFunctions+( pageTitle+, pageTitleOrDefault+, pageTitleOrNothing+, descriptionOrDefault+, ogTitleOrDefault+, ogTypeOrDefault+, ogDescriptionOrDefault+, ogUrl+, ogImage+, module IHP.PageHead.ControllerFunctions -- | Re-export as we want to call setTitle from the beforeRender hook+) where++import Prelude+import Data.IORef (readIORef)+import Data.Text (Text)+import Data.Maybe (fromMaybe)+import System.IO.Unsafe (unsafePerformIO)+import Network.Wai (Request)+import IHP.PageHead.Types+import IHP.PageHead.ControllerFunctions+import IHP.HSX.QQ (hsx)+import Text.Blaze.Html5 (Html)++-- | Returns the current page title. The title can be set using @setTitle "my title"@ from the action.+--+-- If the title hasn't been set yet, this will return an empty string. You can also use 'pageTitleOrDefault' to pass a custom default title.+--+-- You can use this inside your @<title>@ tag like this:+--+-- > [hsx|+-- > <head>+-- > <title>{pageTitle}</title>+-- > </head>+-- > |]+--+--+-- *App-wide default title:*+--+-- You can set a app-wide default title by calling 'setTitle' from the @FrontController.hs@:+--+-- > instance InitControllerContext Web where+-- > initContext = do+-- > setLayout defaultLayout+-- > setTitle "Jobs"+--+--+-- *View-specific title:*+--+-- You can set a custom title inside the view by calling 'setTitle' inside the 'beforeRender' hook.+--+-- > module JobSite.View.JobPositions.Show where+-- >+-- > instance View ShowView where+-- > beforeRender ShowView { .. } = do+-- > setTitle "Custom title"+-- >+-- > html ShowView { .. } = [hsx|..|]+pageTitle :: (?request :: Request) => Text+pageTitle = pageTitleOrDefault ""++-- | Returns the current page title, like 'pageTitle' but returns a provided default value instead of an empty string if no title is set.+--+-- You can use this inside your @<title>@ tag like this:+--+-- > [hsx|+-- > <head>+-- > <title>{pageTitleOrDefault "My Application"}</title>+-- > </head>+-- > |]+pageTitleOrDefault :: (?request :: Request) => Text -> Text+pageTitleOrDefault defaultValue = fromMaybe defaultValue pageTitleOrNothing++-- | Returns the current page title or Nothing if not set yet+pageTitleOrNothing :: (?request :: Request) => Maybe Text+pageTitleOrNothing = case (unsafePerformIO (readIORef (lookupPageHeadVault pageHeadVaultKey ?request))).title of+ Just (PageTitle title) -> Just title+ Nothing -> Nothing+++-- | Returns the meta og:title element. The og:title can be set using @setOGTitle "my title"@ from the view.+--+-- You can use this inside your Layout like this:+--+-- > [hsx|+-- > <head>+-- > <title>{pageTitle}</title>+-- > {ogTitleOrDefault "default title"}+-- > </head>+-- > |]+--+--+-- *View-specific og:title:*+--+-- You can override the default og:title inside the view by calling 'setOGTitle' inside the 'beforeRender' hook:+--+-- > module JobSite.View.JobPositions.Show where+-- >+-- > instance View ShowView where+-- > beforeRender ShowView { .. } = do+-- > setOGTitle "Custom title"+-- >+-- > html ShowView { .. } = [hsx|..|]+ogTitleOrDefault :: (?request :: Request) => Text -> Html+ogTitleOrDefault defaultValue = [hsx|<meta property="og:title" content={content}/>|]+ where+ content = case (unsafePerformIO (readIORef (lookupPageHeadVault pageHeadVaultKey ?request))).ogTitle of+ Just (OGTitle title) -> title+ Nothing -> defaultValue++-- | Returns @<meta name="description" content="Lorem Ipsum">@ element. The description can be set using @setDescription "my description"@ from the view.+--+-- You can use this inside your Layout like this:+--+-- > [hsx|+-- > <head>+-- > <title>{pageTitle}</title>+-- > {descriptionOrDefault "CO2 Database"}+-- > </head>+-- > |]+--+--+-- *View-specific description:*+--+-- You can override the default description inside the view by calling 'setDescription' inside the 'beforeRender' hook:+--+-- > module JobSite.View.JobPositions.Show where+-- >+-- > instance View ShowView where+-- > beforeRender ShowView { .. } = do+-- > setDescription "The CO2 Footprint of beef is about 67kg CO2 per 1kg of beef."+-- >+-- > html ShowView { .. } = [hsx|..|]+descriptionOrDefault :: (?request :: Request) => Text -> Html+descriptionOrDefault defaultValue = [hsx|<meta name="description" content={content}/>|]+ where+ content = case (unsafePerformIO (readIORef (lookupPageHeadVault pageHeadVaultKey ?request))).description of+ Just (PageDescription description) -> description+ Nothing -> defaultValue++-- | Returns the meta og:type element. The og:type can be set using @setOGType "data"@ from the view.+--+-- You can use this inside your Layout like this:+--+-- > [hsx|+-- > <head>+-- > <title>{pageTitle}</title>+-- > {ogTypeOrDefault "data"}+-- > </head>+-- > |]+--+--+-- *View-specific og:type:*+--+-- You can override the default og:type inside the view by calling 'setOGType' inside the 'beforeRender' hook:+--+-- > module JobSite.View.JobPositions.Show where+-- >+-- > instance View ShowView where+-- > beforeRender ShowView { .. } = do+-- > setOGType "mytype"+-- >+-- > html ShowView { .. } = [hsx|..|]+ogTypeOrDefault :: (?request :: Request) => Text -> Html+ogTypeOrDefault defaultValue = [hsx|<meta property="og:type" content={content}/>|]+ where+ content = case (unsafePerformIO (readIORef (lookupPageHeadVault pageHeadVaultKey ?request))).ogType of+ Just (OGType type_) -> type_+ Nothing -> defaultValue++-- | Returns the meta og:description element. The og:description can be set using @setOGDescription "my description"@ from the view.+--+-- You can use this inside your Layout like this:+--+-- > [hsx|+-- > <head>+-- > <title>{pageTitle}</title>+-- > {ogDescriptionOrDefault "CO2 Database"}+-- > </head>+-- > |]+--+--+-- *View-specific og:description:*+--+-- You can override the default og:description inside the view by calling 'setOGDescription' inside the 'beforeRender' hook:+--+-- > module JobSite.View.JobPositions.Show where+-- >+-- > instance View ShowView where+-- > beforeRender ShowView { .. } = do+-- > setOGDescription "The CO2 Footprint of beef is about 67kg CO2 per 1kg of beef."+-- >+-- > html ShowView { .. } = [hsx|..|]+ogDescriptionOrDefault :: (?request :: Request) => Text -> Html+ogDescriptionOrDefault defaultValue = [hsx|<meta property="og:description" content={content}/>|]+ where+ content = case (unsafePerformIO (readIORef (lookupPageHeadVault pageHeadVaultKey ?request))).ogDescription of+ Just (OGDescription description) -> description+ Nothing -> defaultValue+++-- | Returns the meta og:url element if @setOGUrl "https://example.com/"@ was called before.+--+-- You can use this inside your Layout like this:+--+-- > [hsx|+-- > <head>+-- > <title>{pageTitle}</title>+-- > {ogUrl}+-- > </head>+-- > |]+--+-- When 'setOGUrl' is not called, no meta tag will be rendered.+--+-- *Setting og:url:*+--+-- You can set the og:url inside the view by calling 'setOGUrl' inside the 'beforeRender' hook:+--+-- > module JobSite.View.JobPositions.Show where+-- >+-- > instance View ShowView where+-- > beforeRender ShowView { .. } = do+-- > setOGUrl (urlTo ShowAction { .. })+-- >+-- > html ShowView { .. } = [hsx|..|]+ogUrl :: (?request :: Request) => Html+ogUrl = case (unsafePerformIO (readIORef (lookupPageHeadVault pageHeadVaultKey ?request))).ogUrl of+ Just (OGUrl url) -> [hsx|<meta property="og:url" content={url}/>|]+ Nothing -> mempty+++-- | Returns the meta og:image element if @setOGImage "https://example.com/image.png"@ was called before.+--+-- You can use this inside your Layout like this:+--+-- > [hsx|+-- > <head>+-- > <title>{pageTitle}</title>+-- > {ogImage}+-- > </head>+-- > |]+--+-- When 'setOGImage' is not called, no meta tag will be rendered.+--+-- *Setting og:image:*+--+-- You can set the og:image inside the view by calling 'setOGImage' inside the 'beforeRender' hook:+--+-- > module JobSite.View.JobPositions.Show where+-- >+-- > instance View ShowView where+-- > beforeRender ShowView { .. } = do+-- > setOGImage "https://example.com/image.png"+-- >+-- > html ShowView { .. } = [hsx|..|]+ogImage :: (?request :: Request) => Html+ogImage = case (unsafePerformIO (readIORef (lookupPageHeadVault pageHeadVaultKey ?request))).ogImage of+ Just (OGImage url) -> [hsx|<meta property="og:image" content={url}/>|]+ Nothing -> mempty
+ LICENSE view
@@ -0,0 +1,21 @@+The MIT License (MIT)++Copyright (c) 2020 digitally induced GmbH++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ ihp-pagehead.cabal view
@@ -0,0 +1,50 @@+cabal-version: 2.2+name: ihp-pagehead+version: 1.0.0+synopsis: Page title and meta tags for IHP+description:+ Manage page titles and Open Graph meta tags in IHP applications.+ This is a lightweight package depending only on ihp-context, ihp-hsx, and blaze-html.+license: MIT+license-file: LICENSE+author: digitally induced GmbH+maintainer: hello@digitallyinduced.com+homepage: https://ihp.digitallyinduced.com/+bug-reports: https://github.com/digitallyinduced/ihp/issues+copyright: (c) digitally induced GmbH+category: Web, IHP+stability: Stable+tested-with: GHC == 9.8.4+build-type: Simple++source-repository head+ type: git+ location: https://github.com/digitallyinduced/ihp++common shared-properties+ default-language: GHC2021+ default-extensions:+ OverloadedStrings+ , NoImplicitPrelude+ , ImplicitParams+ , BlockArguments+ , LambdaCase+ , QuasiQuotes+ , OverloadedRecordDot+ ghc-options: -Werror=incomplete-patterns -Werror=unused-imports -Werror=missing-fields++library+ import: shared-properties+ hs-source-dirs: .+ build-depends:+ base >= 4.17.0 && < 4.22+ , ihp-context+ , ihp-hsx+ , text+ , blaze-html+ , vault+ , wai+ exposed-modules:+ IHP.PageHead.Types+ , IHP.PageHead.ControllerFunctions+ , IHP.PageHead.ViewFunctions