hablo-1.0.0.0: 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(..), Wording(..))
import qualified Blog (get)
import Control.Applicative ((<|>))
import Control.Monad.Reader (ReaderT)
import qualified Data.Map as Map (keys, lookup)
import Data.Monoid ((<>))
import Data.Text (Text, pack, empty)
import Files (absoluteLink)
import Lucid
import Lucid.Base (makeAttribute)
import Prelude hiding (head, lookup)
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, Article.metadata}) = do
    description <- getDescription (Map.lookup "summary" metadata)
    makeCard title (pack description) (Map.lookup "featuredImage" metadata)
    where
      getDescription = maybe (Blog.get $name.$("A new article on " <>)) return

  content = article True

instance Page ArticlesList where
  card al = do
    cardTitle <- getTitle <$> Blog.get name
    description <- pageTitle al
    makeCard cardTitle description Nothing
    where
      getTitle name = maybe name ((name ++ " - ") ++) $ tagged al

  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
      otherLink = Blog.get $wording.$(if full then latestLink else allLink)

article :: Bool -> Article -> HtmlGenerator ()
article raw (Article {key, body, 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"

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

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"]

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
          maybe defaultBanner toHtmlRaw =<< (Blog.get $skin.$banner)
          div_ [id_ "navigator"] (do
              h2_ =<< (Blog.get $wording.$tagsList.$toHtml)
              ul_ . mapM_ tag . Map.keys =<< Blog.get tags
            )
          div_ [id_ "contents"] $ content aPage
        )
    )