diff --git a/src/Foundation.hs b/src/Foundation.hs index 3538c59..fc70ddf 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -25,8 +25,9 @@ import Model.Cache ( getCached ) import Model.Category ( Category ) import Model.Entry ( entryTitle ) 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 Data.Text as T 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. (title, crumbs) <- breadcrumbs 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] @@ -187,22 +188,6 @@ instance YesodBreadcrumbs App where breadcrumb (EntryWithSlugR kind entryId _) = breadcrumb $ EntryR kind entryId 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. instance YesodPersist App where type YesodPersistBackend App = SqlBackend diff --git a/src/SchemaOrg/BreadcrumbList.hs b/src/SchemaOrg/BreadcrumbList.hs new file mode 100644 index 0000000..9c278e9 --- /dev/null +++ b/src/SchemaOrg/BreadcrumbList.hs @@ -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 + ] + ]