Move the schema.org/BreadcrumbList stuff out of Foundation

This commit is contained in:
Danielle McLean 2017-10-16 20:57:36 +11:00
parent a880e66c31
commit 5a83121431
Signed by: 00dani
GPG key ID: 5A5D2D1AFF12EEC5
2 changed files with 24 additions and 18 deletions

View file

@ -25,8 +25,9 @@ import Model.Cache ( getCached )
import Model.Category ( Category ) import Model.Category ( Category )
import Model.Entry ( entryTitle ) import Model.Entry ( entryTitle )
import Model.Entry.Kind ( EntryKind, allEntryKinds, pluralise ) import Model.Entry.Kind ( EntryKind, allEntryKinds, pluralise )
import SchemaOrg.BreadcrumbList ( breadcrumbList )
import Data.Aeson ( encode, object ) import Data.Aeson ( encode )
import qualified Text.Blaze.Internal as B import qualified Text.Blaze.Internal as B
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.Lazy.Encoding as E import qualified Data.Text.Lazy.Encoding as E
@ -108,7 +109,7 @@ instance Yesod App where
-- Get the breadcrumbs, as defined in the YesodBreadcrumbs instance. -- Get the breadcrumbs, as defined in the YesodBreadcrumbs instance.
(title, crumbs) <- breadcrumbs (title, crumbs) <- breadcrumbs
let allCrumbs = maybe crumbs (\route -> crumbs ++ [(route, title)]) mcurrentRoute let allCrumbs = maybe crumbs (\route -> crumbs ++ [(route, title)]) mcurrentRoute
jsonCrumbs <- fmap (E.decodeUtf8 . encode) . withUrlRenderer $ jsonLdBreadcrumbList allCrumbs jsonCrumbs <- fmap (E.decodeUtf8 . encode) . withUrlRenderer $ breadcrumbList allCrumbs
let navbars = [leftMenuItems, rightMenuItems] <*> [muser] let navbars = [leftMenuItems, rightMenuItems] <*> [muser]
@ -187,22 +188,6 @@ instance YesodBreadcrumbs App where
breadcrumb (EntryWithSlugR kind entryId _) = breadcrumb $ EntryR kind entryId breadcrumb (EntryWithSlugR kind entryId _) = breadcrumb $ EntryR kind entryId
breadcrumb _ = return ("home", Nothing) breadcrumb _ = return ("home", Nothing)
jsonLdBreadcrumbList :: [(Route App, Text)] -> (Route App -> [(Text, Text)] -> Text) -> Value
jsonLdBreadcrumbList crumbs url = object
[ ("@context", "http://schema.org")
, ("@type", "BreadcrumbList")
, "itemListElement" .= zipWith (jsonLdListItem url) [1 :: Int ..] crumbs
]
jsonLdListItem :: (Route App -> [(Text, Text)] -> Text) -> Int -> (Route App, Text) -> Value
jsonLdListItem url i (r, t) = object
[ ("@type", "ListItem")
, "position" .= i
, "item" .= object
[ "@id" .= url r []
, "name" .= t
]
]
-- How to run database actions. -- How to run database actions.
instance YesodPersist App where instance YesodPersist App where
type YesodPersistBackend App = SqlBackend type YesodPersistBackend App = SqlBackend

View file

@ -0,0 +1,21 @@
{-# LANGUAGE OverloadedStrings #-}
module SchemaOrg.BreadcrumbList ( breadcrumbList ) where
import Data.Aeson
import qualified Data.Text as T
breadcrumbList :: [(a, T.Text)] -> (a -> [(T.Text, T.Text)] -> T.Text) -> Value
breadcrumbList crumbs url = object
[ ("@context", "http://schema.org")
, ("@type", "BreadcrumbList")
, "itemListElement" .= zipWith (listItem url) [1 :: Int ..] crumbs
]
listItem :: (a -> [(T.Text, T.Text)] -> T.Text) -> Int -> (a, T.Text) -> Value
listItem url i (r, t) = object
[ ("@type", "ListItem")
, "position" .= i
, "item" .= object
[ "@id" .= url r []
, "name" .= t
]
]