hablo/src/DOM.hs

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

import Article (Article(..))
import qualified Article (preview)
import ArticlesList (
    ArticlesList(..), description, getArticles, otherURL, rssLinkTexts
  )
import Blog (Blog(..), Path(..), Skin(..), URL(..), template)
import Control.Monad.Reader (ReaderT, asks)
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 (
      HtmlT, a_, article_, body_, charset_, class_, div_, doctypehtml_, h1_, h2_
    , head_, header_, href_, li_, link_, id_, meta_, pre_, rel_, script_, src_
    , title_, toHtml, toHtmlRaw, type_, ul_
  )
import Markdown (Markdown(..))
import Prelude hiding (head, lookup)
import Pretty ((.$))
import System.FilePath.Posix ((</>), (<.>))

type HtmlGenerator = HtmlT (ReaderT Blog IO)

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

instance HasContent Article where
  content = markdown True . Article.getMarkdown

instance HasContent ArticlesList where
  content al@(ArticlesList {full}) = do
    preview <- Article.preview <$> (asks $skin.$previewLinesCount)
    h2_ . toHtml =<< description al
    ul_ $ do
      asks hasRSS >>= rssLink
      li_ . a_ [href_ . pack $ otherURL al, class_ "other"] =<< otherLink
    div_ [class_ "articles"] (
        mapM_ (markdown False . preview) =<< getArticles al
      )
    where
      otherLink =
        toHtml <$> template (if full then "latestLink" else "allLink") []
      rssLink :: Bool -> HtmlGenerator ()
      rssLink True = do
        (text, title) <- rssLinkTexts al
        li_ . a_ [href_ "rss.xml", class_ "RSS", title_ title] $ toHtml text
      rssLink False = return ()

markdown :: Bool -> Markdown -> HtmlGenerator ()
markdown raw (Markdown {key, body, title}) = do
  url <- absoluteLink . (</> key <.> extension) <$> (asks $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 name = li_ (
    a_ [href_ . pack $ absoluteLink name ++ "/", class_ "tag"] $ toHtml name
  )

defaultBanner :: HtmlGenerator ()
defaultBanner = do
  div_ [id_ "header"] (
      a_ [href_ "/"] (
          h1_ . toHtml =<< asks 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 ()) 

htmlDocument :: HasContent a => a -> HtmlGenerator ()
htmlDocument someContent =
  doctypehtml_ (do
      head_ (do
          meta_ [charset_ "utf-8"]
          title_ . toHtml =<< asks name
          script_ [src_ "/js/remarkable.min.js"] empty
          script_ [src_ "/js/hablo.js"] empty
          optional faviconLink =<< (asks $skin.$favicon)
          optional (Card.make someContent) =<< (asks $urls.$cards)
          optional toHtmlRaw =<< (asks $skin.$head)
        )
      body_ (do
          maybe defaultBanner toHtmlRaw =<< (asks $skin.$banner)
          div_ [id_ "navigator"] (do
              h2_ . toHtml =<< template "tagsList" []
              ul_ . mapM_ tag . Map.keys =<< asks tags
            )
          div_ [id_ "contents"] $ content someContent
        )
    )