hablo/src/DOM.hs

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

import Article (Article(..))
import qualified Article (preview)
import ArticlesList (ArticlesList(..), otherUrl, pageTitle)
import Blog (Blog(..), Path(..), Skin(..), URL(..))
import qualified Blog (get)
import Blog.Wording (render)
import Control.Monad.Reader (ReaderT)
import qualified Data.Map as Map (keys)
import Data.Text (pack, empty)
import DOM.Card (HasCard)
import qualified DOM.Card as Card (make)
import Files (absoluteLink)
import Lucid
import Prelude hiding (head, lookup)
import Pretty ((.$))
import System.FilePath.Posix ((</>), (<.>))

type HtmlGenerator = HtmlT (ReaderT Blog IO)

class HasCard a => Page a where
  content :: a -> HtmlGenerator ()

instance Page Article where
  content = article True

instance Page ArticlesList where
  content al@(ArticlesList {featured, full}) = do
    preview <- Article.preview <$> (Blog.get $skin.$previewLinesCount)
    h2_ . toHtml =<< pageTitle al
    a_ [href_ . pack $ otherUrl al] . toHtml =<< otherLink
    div_ [class_ "articles"] (
        mapM_ (article False . preview) featured
      )
    where
      link = render (if full then "latestLink" else "allLink") []
      otherLink = Blog.get $wording.$(link)

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

tag :: String -> HtmlGenerator ()
tag tagName = li_ (
    a_ [href_ . pack $ absoluteLink tagName, class_ "tag"] $ toHtml tagName
  )

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

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

optional :: (a -> HtmlGenerator ()) -> Maybe a -> HtmlGenerator ()
optional = maybe (return ()) 

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
          optional faviconLink =<< (Blog.get $skin.$favicon)
          optional (Card.make aPage) =<< (Blog.get $urls.$site)
          (Blog.get $skin.$head) >>= maybe (toHtml empty) toHtmlRaw
        )
      body_ (do
          maybe defaultBanner toHtmlRaw =<< (Blog.get $skin.$banner)
          div_ [id_ "navigator"] (do
              h2_ =<< (Blog.get $wording.$(render "tagsList" []).$toHtml)
              ul_ . mapM_ tag . Map.keys =<< Blog.get tags
            )
          div_ [id_ "contents"] $ content aPage
        )
    )