Card.hs

{-# 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(..), template)
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 Markdown (MarkdownContent(..), metadata)
import qualified Markdown (Markdown(..))
import Page (Page(..))
import Pretty ((.$))
import System.FilePath.Posix ((</>), (<.>))

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 </>)

mDImage :: (Renderer m, MarkdownContent a ) => a -> m (Maybe String)
mDImage = return . Map.lookup "featuredImage" . metadata . getMarkdown

mDTitle :: (Renderer m, MarkdownContent a) => a -> m String
mDTitle = return . Markdown.title . getMarkdown

mDUrlPath :: (Renderer m, MarkdownContent a) => a -> m String
mDUrlPath a = return $ Markdown.path (getMarkdown a) <.> "html"

mDDescription :: (Renderer m, MarkdownContent a) => String -> a -> m Text
mDDescription key =
  getDescription . Map.lookup "summary" . metadata . getMarkdown
  where
    getDescription = maybe defaultDescription (return . pack)
    defaultDescription = asks name >>= template key . \v -> [("name", pack v)]

instance HasCard Article where
  cardType _ = return "article"
  description = mDDescription "articleDescription"
  image = mDImage
  title = mDTitle
  urlPath = mDUrlPath

instance HasCard Page where
  cardType _ = return "website"
  description = mDDescription "pageDescription"
  image = mDImage
  title = mDTitle
  urlPath = mDUrlPath

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 "" id (tag collection) </> file
    where
      file = (if full al then "all" else "index") <.> ".html"