82 lines
2.8 KiB
Haskell
82 lines
2.8 KiB
Haskell
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
module DOM.Card (
|
|
HasCard(..)
|
|
, make
|
|
) where
|
|
|
|
import Article (Article(..))
|
|
import ArticlesList (ArticlesList(..))
|
|
import qualified ArticlesList (description)
|
|
import Blog (Blog(..), Renderer, Skin(..))
|
|
import Collection (Collection(..))
|
|
import qualified Collection (title)
|
|
import Control.Applicative ((<|>))
|
|
import Control.Monad.Reader (asks)
|
|
import qualified Data.Map as Map (lookup)
|
|
import Data.Text (Text, pack)
|
|
import Lucid (HtmlT, content_, meta_)
|
|
import Lucid.Base (makeAttribute)
|
|
import qualified Markdown (Markdown(..))
|
|
import Page (Page(..))
|
|
import Pretty ((.$))
|
|
|
|
class HasCard a where
|
|
cardType :: Renderer m => a -> m Text
|
|
description :: Renderer m => a -> m Text
|
|
image :: Renderer m => a -> m (Maybe String)
|
|
title :: Renderer m => a -> m String
|
|
urlPath :: Renderer m => a -> m String
|
|
|
|
og :: Applicative m => Text -> Text -> HtmlT m ()
|
|
og attribute value =
|
|
meta_ [
|
|
makeAttribute "property" $ "og:" <> attribute
|
|
, content_ value
|
|
]
|
|
|
|
make :: (HasCard a, Renderer m) => a -> String -> HtmlT m ()
|
|
make element siteURL = do
|
|
og "url" . sitePrefix =<< urlPath element
|
|
og "type" =<< cardType element
|
|
og "title" . pack =<< title element
|
|
og "description" =<< description element
|
|
maybeImage =<< ((<|>) <$> image element <*> (asks $skin.$cardImage))
|
|
og "site_name" =<< (asks $name.$pack)
|
|
where
|
|
maybeImage = maybe (return ()) (og "image" . sitePrefix)
|
|
sitePrefix = pack . (siteURL ++)
|
|
|
|
instance HasCard Article where
|
|
cardType _ = return "article"
|
|
description (Article (Markdown.Markdown {Markdown.metadata})) =
|
|
fmap pack . getDescription $ Map.lookup "summary" metadata
|
|
where
|
|
getDescription = maybe (asks $name.$("A new article on " <>)) return
|
|
image (Article (Markdown.Markdown {Markdown.metadata})) =
|
|
return $ Map.lookup "featuredImage" metadata
|
|
title = return . Markdown.title . Article.getMarkdown
|
|
urlPath = fmap (\t -> "/articles/" ++ t ++ ".html") . title
|
|
|
|
instance HasCard Page where
|
|
cardType _ = return "website"
|
|
description page@(Page (Markdown.Markdown {Markdown.metadata})) =
|
|
fmap pack . getDescription $ Map.lookup "summary" metadata
|
|
where
|
|
getDescription = maybe (title page) return
|
|
image (Page (Markdown.Markdown {Markdown.metadata})) =
|
|
return $ Map.lookup "featuredImage" metadata
|
|
title = return . Markdown.title . Page.getMarkdown
|
|
urlPath = fmap (\t -> "/pages/" ++ t ++ ".html") . title
|
|
|
|
instance HasCard ArticlesList where
|
|
cardType _ = return "website"
|
|
description = ArticlesList.description
|
|
image _ = return Nothing
|
|
title (ArticlesList {collection}) = Collection.title collection
|
|
urlPath al@(ArticlesList {collection}) =
|
|
return $ maybe "" ('/':) (tag collection) ++ file
|
|
where
|
|
file = '/' : (if full al then "all" else "index") ++ ".html"
|