hablo/src/Dom.hs

{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module Dom (
    page
  ) where

import Article (Article(..))
import qualified Article (preview)
import ArticlesList (ArticlesList(..), otherLink, otherUrl, pageTitle)
import Blog (Blog(..), Path(..), Skin(..))
import qualified Blog (get)
import Control.Monad.Reader (ReaderT)
import qualified Data.Map as Map (keys)
import Data.Monoid ((<>))
import Data.Text (pack, empty)
import Lucid
import Lucid.Base (makeAttribute)
import Prelude hiding (head)
import Pretty ((.$))
import System.FilePath.Posix ((</>), (<.>))

type HtmlGenerator = HtmlT (ReaderT Blog IO)

class Page a where
  card :: a -> HtmlGenerator ()
  content :: a -> HtmlGenerator ()

instance Page Article where
  card (Article {title}) =
    ("A new article on " <>) <$> Blog.get name
    >>= makeCard title

  content = article True

instance Page ArticlesList where
  card al = do
    blogName <- Blog.get name
    makeCard (maybe blogName ((blogName ++ " - ") ++) $ tagged al) (pageTitle al)

  content al@(ArticlesList {featured}) = do
    preview <- Article.preview <$> (Blog.get $skin.$previewLinesCount)
    h2_ . toHtml . pack $ pageTitle al
    navigationA [href_ . pack $ otherUrl al] . toHtml . pack $ otherLink al
    div_ [class_ "articles"] (
        mapM_ (article False . preview) featured
      )

article :: Bool -> Article -> HtmlGenerator ()
article raw (Article {key, body, title}) = do
  url <- ("/" </>) . (</> key <.> extension) <$> (Blog.get $path.$articlesPath)
  article_ (do
      header_ (do
          aElem [href_ . pack $ url] . h1_ $ toHtml title
        )
      pre_ . toHtml $ unlines body
    )
  where
    (aElem, extension) = if raw then (a_, "md") else (navigationA, "html")

makeCard :: String -> String -> HtmlGenerator ()
makeCard title description = do
  og "title" title
  og "description" description
  og "image" =<< (Blog.get $skin.$cardImage)
  og "site_name" =<< Blog.get name
  where
    og attribute value = meta_ [makeAttribute "property" $ "og:" <> attribute , content_ $ pack value]

navigationA :: Term arg result => arg -> result
navigationA = "a" `termWith` [class_ "navigation"]

tag :: String -> HtmlGenerator ()
tag tagName = li_ (navigationA [href_ $ pack ("/" </> tagName)] $ toHtml tagName)

defaultBanner :: HtmlGenerator ()
defaultBanner = do
  div_ [id_ "header"] (
      navigationA [href_ "/"] (
          h1_ . toHtml =<< Blog.get name
        )
    )

faviconLink :: FilePath -> HtmlGenerator ()
faviconLink url = link_ [rel_ "shortcut icon", href_ $ pack url, type_ "image/x-icon"]

page :: Page a => a -> HtmlGenerator ()
page aPage =
  doctypehtml_ (do
      head_ (do
          meta_ [charset_ "utf-8"]
          title_ . toHtml =<< Blog.get name
          script_ [src_ "/js/unit.js"] empty
          script_ [src_ "/js/remarkable.min.js"] empty
          script_ [src_ "/js/hablo.js"] empty
          maybe (toHtml empty) faviconLink =<< (Blog.get $skin.$favicon)
          card aPage
          (Blog.get $skin.$head) >>= maybe (toHtml empty) toHtmlRaw
        )
      body_ (do
          (Blog.get $skin.$banner) >>= maybe defaultBanner toHtmlRaw
          div_ [id_ "navigator"] (do
              h2_ "Tags"
              ul_ . mapM_ tag . Map.keys =<< Blog.get tags
            )
          div_ [id_ "contents"] $ content aPage
        )
    )