hablo-1.0.0.0: src/HTML.hs

{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module HTML (
    generate
  ) where

import Article(Article(..))
import ArticlesList (ArticlesList(..))
import Blog (Blog(..), Path(..), Skin(..))
import qualified Blog (get)
import Control.Monad (forM)
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Reader (MonadReader(..), ReaderT)
import Data.List (sortOn)
import Data.Map ((!))
import qualified Data.Map as Map (elems, filterWithKey, toList)
import Data.Ord (Down(..))
import qualified Data.Set as Set (member)
import qualified Data.Text.Lazy.IO as TextIO (writeFile)
import Dom (page)
import Lucid
import Pretty ((.$))
import System.Directory (createDirectoryIfMissing)
import System.FilePath.Posix ((</>), (<.>))

data Collection = Collection {
      articlesFeatured :: [Article]
    , basePath :: FilePath
    , tag :: Maybe String
  }

collection :: Monad m => [Article] -> Maybe String -> ReaderT Blog m Collection
collection articlesFeatured tag = do
  root <- Blog.get $path.$root
  return $ Collection {
        articlesFeatured = sortByDate articlesFeatured
      , basePath = maybe root (root </>) tag
      , tag
    }
  where
    sortByDate = sortOn (Down . (! "date") . metadata)

articlesLists :: Monad m => Collection -> ReaderT Blog m [(FilePath, ArticlesList)]
articlesLists (Collection {articlesFeatured, basePath, tag}) = do
  limit <- take <$> (Blog.get $skin.$previewArticlesCount)
  return [
        (basePath </> "index.html", ArticlesList {
              tagged = tag
            , full = False
            , featured = limit articlesFeatured
          })
      , (basePath </> "all.html", ArticlesList {
              tagged = tag
            , full = True
            , featured = articlesFeatured
          })
    ]

generateArticles :: [Article] -> ReaderT Blog IO ()
generateArticles = mapM_ $ \article -> do
  baseDir <- (</>) <$> (Blog.get $path.$root) <*> (Blog.get $path.$articlesPath)
  (renderTextT $ page article)
    >>= liftIO . TextIO.writeFile (baseDir </> key article <.> "html")

generateCollection :: Collection -> ReaderT Blog IO ()
generateCollection (Collection {articlesFeatured = []}) = return ()
generateCollection aCollection = do
  liftIO . createDirectoryIfMissing False $ basePath aCollection
  articlesLists aCollection
  >>= (mapM_ $ \(filePath, articlesList) ->
    (renderTextT $ page articlesList)
    >>= liftIO . TextIO.writeFile filePath
  )

generate :: ReaderT Blog IO ()
generate = do
  Blog {articles, tags} <- ask
  generateArticles $ Map.elems articles
  collection (Map.elems articles) Nothing >>= generateCollection
  forM  (Map.toList tags) $
    \(tag, tagged) -> collection (getArticles tagged articles) $ Just tag
  >>= mapM_ generateCollection
  where
    getArticles tagged = Map.elems . Map.filterWithKey (\k _ -> Set.member k tagged)