80 lines
2.4 KiB
Haskell
80 lines
2.4 KiB
Haskell
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
module DOM.Card (
|
|
Card(..)
|
|
, HasCard(..)
|
|
, make
|
|
) where
|
|
|
|
import qualified 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 Pretty ((.$))
|
|
|
|
data Card = Card {
|
|
cardType :: Text
|
|
, description :: Text
|
|
, image :: Maybe String
|
|
, title :: String
|
|
, urlPath :: String
|
|
}
|
|
|
|
class HasCard a where
|
|
getCard :: Renderer m => a -> m Card
|
|
|
|
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
|
|
Card {cardType, description, image, title, urlPath} <- getCard element
|
|
og "url" . pack $ siteURL ++ urlPath
|
|
og "type" cardType
|
|
og "title" $ pack title
|
|
og "description" description
|
|
maybeImage =<< ((image <|>) <$> (asks $skin.$cardImage))
|
|
og "site_name" =<< (asks $name.$pack)
|
|
where
|
|
maybeImage = maybe (return ()) (og "image" . pack . (siteURL++))
|
|
|
|
instance HasCard Article.Article where
|
|
getCard (Article.Article {Article.title, Article.metadata}) = do
|
|
description <- pack <$> getDescription (Map.lookup "summary" metadata)
|
|
return $ Card {
|
|
cardType = "article"
|
|
, description
|
|
, image = (Map.lookup "featuredImage" metadata)
|
|
, DOM.Card.title
|
|
, urlPath = "/articles/" ++ title ++ ".html"
|
|
}
|
|
where
|
|
getDescription = maybe (asks $name.$("A new article on " <>)) return
|
|
|
|
instance HasCard ArticlesList where
|
|
getCard al@(ArticlesList {collection}) = do
|
|
cardTitle <- Collection.title collection
|
|
description <- ArticlesList.description al
|
|
return $ Card {
|
|
cardType = "website"
|
|
, description
|
|
, image = Nothing
|
|
, DOM.Card.title = cardTitle
|
|
, urlPath = maybe "" ('/':) (tag collection) ++ file
|
|
}
|
|
where
|
|
file = '/' : (if full al then "all" else "index") ++ ".html"
|