reploy/site.hs

{-# LANGUAGE OverloadedStrings #-}

-- | The main deployment script.
module Main where

import Control.Monad (unless, when)
import Control.Monad.IO.Class
import Control.Monad.Trans.State.Lazy
import Data.Default (def)
import Data.Foldable (traverse_)
import Data.List (nub)
import Data.List.Extra (stripSuffix)
import qualified Data.Map as M
import Data.Maybe (fromMaybe, isJust)
import Data.String (fromString)
import qualified Data.Text as T
import qualified Data.Text.Encoding
import qualified Data.Text.IO as TIO
import qualified Data.Yaml as Y
import Hakyll.Core.Util.File (getRecursiveContents, makeDirectories)
import Lens.Micro
import Lens.Micro.Aeson
import Lens.Micro.Mtl
import System.Environment (getArgs)
import System.FilePath ((</>), splitPath)
import qualified Text.Mustache as Mu
import qualified Text.Parsec.Error
import Text.Pandoc.Class (runIOorExplode)
import qualified Text.Pandoc.Extensions
import Text.Pandoc.Options (ReaderOptions(..))
import Text.Pandoc.Readers.Markdown (readMarkdown)

import Types

-- | A shortcut for `liftIO`.
io :: MonadIO m => IO a -> m a
io = liftIO

-- | A helper for throwing an error if something is `Nothing`
just :: String -> Maybe a -> a
just _ (Just val) = val
just err Nothing = error ("Missing: " ++ err)

-- | Test for whether something listy has a suffix
hasSuffix :: Eq a => [a] -> [a] -> Bool
hasSuffix s = isJust . stripSuffix s

-- | Load the pages from a directory and add them to `pages`.
sourcePages :: FilePath -> Site ()
sourcePages fp = do
  links <-
    io $ filter (hasSuffix ".md" . last . splitPath) <$>
    getRecursiveContents (pure . const False) fp
  traverse_ loadPage (map (fp </>) links)

-- | Default markdown reading options for Pandoc.
markdownReadOpts =
  def
    { readerExtensions =
        Text.Pandoc.Extensions.enableExtension
          Text.Pandoc.Extensions.Ext_smart
          Text.Pandoc.Extensions.pandocExtensions
    }

{- | Extract `PageInfo` about a single page and save it into `pages` in
 - `SiteState`. -}
loadPage :: FilePath -> Site ()
loadPage fp = do
  io $ putStrLn $ "<<< " ++ fp
  txt <- io $ TIO.readFile fp
  {- tear out the metadata manually -}
  (T.take 4 txt == "---\n") `unless`
    error ("metadata block start missing in " ++ fp)
  let (meta, markdown) = T.breakOn "\n---\n" (T.drop 4 txt)
  T.null meta `when` error ("metadata block bad in " ++ fp)
  {- parse everything -}
  yml <- Y.decodeThrow $ Data.Text.Encoding.encodeUtf8 meta
  md <- io $ runIOorExplode $ readMarkdown markdownReadOpts (T.drop 5 markdown)
  {- find the main mount point for the page -}
  let mount =
        T.unpack . just ("mount point of " ++ fp) $ yml ^? key "title" . _String
  {- save to the state -}
  pages %=
    M.insert mount PageInfo {_pagePath = fp, _pageMeta = yml, _pagePandoc = md}

-- | Find which template to use for rendering a page.
pageTemplate :: PageInfo -> Site FilePath
pageTemplate pi = do
  dt <- use defaultTemplate
  pure . maybe dt T.unpack $ pi ^? pageMeta . key "template" . _String

-- | Collect all templates required for rendering the currently loaded pages.
pageTemplates :: Site [FilePath]
pageTemplates = nub <$> (gets (^.. pages . traverse) >>= traverse pageTemplate)

compileTemplate :: FilePath -> FilePath -> Site (Either Text.Parsec.Error.ParseError Mu.Template)
compileTemplate templdir templ = io $ do
  putStrLn $ "TTT " ++ (templdir </> templ)
  Mu.automaticCompile [templdir] templ

-- | Use a template set from a given directory.
sourceTemplates :: FilePath -> Site ()
sourceTemplates templdir = do
  ts <- pageTemplates
  templs' <- fmap sequence . traverse (compileTemplate templdir) $ ts
  case templs' of
    Left err -> error $ "template compilation: " ++ show err
    Right templs -> templates .= M.fromList (zip ts templs)

-- | Find the path to the "index.html"  of a given mount.
indexFilename :: FilePath -> Site FilePath
indexFilename mount = do
  od <- use outputDir
  pure (od </> mount </> "index.html")

-- | Render a page using the current template.
installPage :: FilePath -> PageInfo -> Site ()
installPage mount pi = do
  {- find the correct template and metadata -}
  tname <- pageTemplate pi
  templ <- use $ templates . to (M.! fromString tname)
  file <- indexFilename mount
  io $ do
    putStrLn $ ">>> " ++ file
    makeDirectories file
    TIO.writeFile file . Mu.substitute templ $ pi ^. pageMeta

{- | Install a file. Files are installed into a single shared location. That
 - prevents file duplication and also gives a bit of control for where the
 - files reside and what are their names. -}
installFile :: FilePath -> Site FilePath
installFile = undefined

{- | Install a simple redirect handler page. -}
installRedirect :: FilePath -> FilePath -> Site ()
installRedirect = undefined

-- | Install all redirects required by pages.
installRedirects :: Site ()
installRedirects = undefined

-- | Render a site for a given tag string.
renderTag :: [String] -> Site ()
renderTag = undefined

-- | Render all tag sites.
renderTags :: Site ()
renderTags = undefined

-- | Build the whole site.
main =
  flip runStateT emptySiteState $ do
    traverse sourcePages ["external"]
    sourceTemplates "templates"
    use pages >>= traverse (uncurry installPage) . M.assocs
    get >>= io . print