diff --git a/IHP/PageHead/ControllerFunctions.hs b/IHP/PageHead/ControllerFunctions.hs new file mode 100644 --- /dev/null +++ b/IHP/PageHead/ControllerFunctions.hs @@ -0,0 +1,59 @@ +{-| +Module: IHP.PageHead.ControllerFunctions +Description: Manage the @@ 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} +-- > +-- > |] +-- +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) }) diff --git a/IHP/PageHead/Types.hs b/IHP/PageHead/Types.hs new file mode 100644 --- /dev/null +++ b/IHP/PageHead/Types.hs @@ -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?" diff --git a/IHP/PageHead/ViewFunctions.hs b/IHP/PageHead/ViewFunctions.hs new file mode 100644 --- /dev/null +++ b/IHP/PageHead/ViewFunctions.hs @@ -0,0 +1,264 @@ +{-| +Module: IHP.PageHead.ViewFunctions +Description: Manage the @@ 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} +-- > +-- > |] +-- +-- +-- *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 @@ tag like this: +-- +-- > [hsx| +-- > <head> +-- > <title>{pageTitleOrDefault "My Application"} +-- > +-- > |] +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| +-- > +-- > {pageTitle} +-- > {ogTitleOrDefault "default title"} +-- > +-- > |] +-- +-- +-- *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||] + where + content = case (unsafePerformIO (readIORef (lookupPageHeadVault pageHeadVaultKey ?request))).ogTitle of + Just (OGTitle title) -> title + Nothing -> defaultValue + +-- | Returns @@ element. The description can be set using @setDescription "my description"@ from the view. +-- +-- You can use this inside your Layout like this: +-- +-- > [hsx| +-- > +-- > {pageTitle} +-- > {descriptionOrDefault "CO2 Database"} +-- > +-- > |] +-- +-- +-- *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||] + 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| +-- > +-- > {pageTitle} +-- > {ogTypeOrDefault "data"} +-- > +-- > |] +-- +-- +-- *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||] + 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| +-- > +-- > {pageTitle} +-- > {ogDescriptionOrDefault "CO2 Database"} +-- > +-- > |] +-- +-- +-- *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||] + 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| +-- > +-- > {pageTitle} +-- > {ogUrl} +-- > +-- > |] +-- +-- 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||] + 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| +-- > +-- > {pageTitle} +-- > {ogImage} +-- > +-- > |] +-- +-- 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||] + Nothing -> mempty diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/ihp-pagehead.cabal b/ihp-pagehead.cabal new file mode 100644 --- /dev/null +++ b/ihp-pagehead.cabal @@ -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