hablo/src/DOM/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 Blog.URL (AbsoluteURL, checkURL, defaultOn, pathOn)
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 Network.URL (URL)
import qualified Markdown (Markdown(..))
import Page (Page(..))
import Pretty ((.$))
import System.FilePath.Posix ((</>), (<.>))
import Text.Blaze.Html5 ((!), AttributeValue, Html, ToValue(..), meta, customAttribute)
import Text.Blaze.Html5.Attributes as A (content)

class HasCard a where
  cardType :: Renderer m => a -> m Text
  description :: Renderer m => a -> m Text
  image :: Renderer m => a -> m (Maybe URL)
  title :: Renderer m => a -> m String
  urlPath :: Renderer m => a -> m String

og :: Applicative m => AttributeValue -> Text -> m Html
og attribute t =
  pure $ meta
    ! (customAttribute "property" $ "og:" <> attribute)
    ! content (toValue t)

make :: (HasCard a, Renderer m) => a -> AbsoluteURL -> m Html
make element siteURL = do
  og "url" . (pathOn siteURL) =<< 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 mempty) (og "image" . defaultOn siteURL)

mDImage :: (Renderer m, MarkdownContent a) => a -> m (Maybe URL)
mDImage = mapM checkURL . 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"