{-# 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"