reploy/site.hs

{-# LANGUAGE OverloadedStrings #-}

-- | The main deployment script.
module Main where

import Control.Monad ((>=>), unless, when)
import Control.Monad.Extra (whenM)
import Control.Monad.Trans.State.Lazy
import qualified Data.Aeson.KeyMap as KM
import qualified Data.ByteString.Lazy as B
import Data.Digest.Pure.SHA (sha256, showDigest)
import Data.Foldable (traverse_)
import Data.List (inits, nub)
import Data.List.Extra (groupSort)
import qualified Data.Map as M
import qualified Data.Set as S
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 qualified Options.Applicative
import System.FilePath
  ( (</>)
  , isAbsolute
  , splitDirectories
  , splitPath
  , takeDirectory
  , takeFileName
  )
import qualified Text.Mustache as Mu
import Text.Pandoc.Class (runIOorExplode)
import Text.Pandoc.Readers.Markdown (readMarkdown)
import Text.Pandoc.Writers.HTML (writeHtml5String)
import qualified Text.Parsec.Error

import FormatOpts
import Types
import Utils

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

{- | Extract `PageInfo` about a single page and save it into `pages` in
 - `SiteState`. -}
loadPage :: FilePath -> Site ()
loadPage fp = do
  io $ putStrLn $ "P <- " ++ 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 =
        unAbsolute . T.unpack . just ("mount point of " ++ fp) $ yml ^?
        key "mount" .
        _String
  existing <- use $ pages . to (M.!? mount)
  case existing of
    Just pi ->
      error $ "mount for " ++ fp ++ " already exists from " ++ _pagePath pi
    _ -> pure ()
  {- save to the state -}
  pages %=
    M.insert mount PageInfo {_pagePath = fp, _pageMeta = yml, _pageDoc = 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 = do
  rt <- use redirectTemplate
  tt <- use tagTemplate
  nub . ([rt, tt] ++) <$>
    (gets (^.. pages . traverse) >>= traverse pageTemplate)

-- | Compile a single template in a directory
compileTemplate ::
     FilePath
  -> FilePath
  -> Site (Either Text.Parsec.Error.ParseError Mu.Template)
compileTemplate templdir templ =
  io $ do
    putStrLn $ "T <- " ++ (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")

-- | Check that the page was not rendered before, and add it to the rendered set
checkTarget :: FilePath -> Site ()
checkTarget fp = do
  found <- S.member fp <$> use targets
  if found
    then error $ "colliding renders for page: " ++ fp
    else targets %= S.insert fp

-- | Prepend the root path to the given link
rootUrl :: FilePath -> Site FilePath
rootUrl fp = (</> unAbsolute fp) <$> use urlBase

-- | Process a single link pointing out from a page.
processLink :: FilePath -> FilePath -> Site String
processLink base l = do
  io $ putStrLn l
  if any (l `hasUriScheme`) ["http", "https", "ftp", "mailto"]
    then pure l
    else if isAbsolute l
           then rootUrl l
           else installFile (base </> l) >>= rootUrl

-- | Get a mount point of the page into the correct location.
-- (Pages are currently mounted just to the root.)
pageFilename :: FilePath -> Site FilePath
pageFilename = indexFilename

-- | Like `Mu.substitute` but writes (and eventually should throw) stuff on errors
checkedSubstitute :: Mu.Template -> Y.Value -> IO T.Text
checkedSubstitute t v = do
  let (es, txt) = Mu.checkedSubstitute t v
  traverse_ (putStrLn . ("Error: " ++) . show) es
  --null es `unless` error "template substitution problems"
  pure txt

-- | Render a page using the current template.
installPage :: FilePath -> PageInfo -> Site ()
installPage mount pi = do
  tname <- pageTemplate pi
  templ <- use $ templates . to (M.! fromString tname)
  file <- pageFilename mount
  fixedUrlDoc <-
    walkURLs (processLink $ pi ^. pagePath . to takeDirectory) $ pi ^. pageDoc
  checkTarget file
  io $ do
    putStrLn $ "P -> " ++ file
    makeDirectories file
    body <- runIOorExplode $ writeHtml5String htmlWriteOpts fixedUrlDoc
    let Y.Object meta' = pi ^. pageMeta
        meta = Y.Object $ KM.insert "body" (Y.String body) meta'
    checkedSubstitute templ meta >>= TIO.writeFile file
  installPageRedirects mount pi

{- | Install a simple redirect handler page. -}
installRedirect :: FilePath -> FilePath -> Site ()
installRedirect target from = do
  tname <- use redirectTemplate
  templ <- use $ templates . to (M.! fromString tname)
  file <- indexFilename from
  checkTarget file
  io $ do
    putStrLn $ "@ -> " ++ file ++ " -> " ++ target
    makeDirectories file
    txt <-
      checkedSubstitute templ $ Y.object [("target", Y.String $ T.pack target)]
    TIO.writeFile file txt

-- | Install all redirects required by one page.
installPageRedirects :: FilePath -> PageInfo -> Site ()
installPageRedirects target pi = do
  traverse_
    (installRedirect target)
    (pi ^.. pageMeta . key "redirects" . values . _String . to T.unpack .
     to unAbsolute)

-- | Find the path to the file of a given hash
dataFilename :: String -> FilePath -> Site (FilePath, FilePath)
dataFilename hash basename = do
  od <- use outputDir
  let (h1, h2) = splitAt 3 hash
      loc = "files" </> h1 </> h2 </> basename
  pure (od </> loc, loc)

-- | Copy a source file to the destination, making the necessary directories in the process.
copy :: FilePath -> FilePath -> IO ()
copy src dst = do
  makeDirectories dst
  B.readFile src >>= B.writeFile dst

{- | 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 fp = do
  let basename = takeFileName fp
  hash <- showDigest . sha256 <$> io (B.readFile fp)
  (file, loc) <- dataFilename hash basename
  alreadyExists <- S.member (hash, basename) <$> use installs
  unless alreadyExists $ do
    installs %= S.insert (hash, basename)
    checkTarget file
    io $ do
      putStrLn $ "F -> " ++ fp ++ " -> " ++ file
      copy fp file
  pure loc

-- | Simply copy a strictly named asset.
installAsset :: FilePath -> Site ()
installAsset fp = do
  od <- use outputDir
  ad <- use assetDir
  let [src, dst] = map (</> fp) [ad, od]
  checkTarget dst
  io $ do
    putStrLn $ "A -> " ++ src ++ " -> " ++ dst
    copy src dst

-- | Copy all files from asset directory.
installAssets :: Site ()
installAssets =
  use assetDir >>=
  (io . getRecursiveContents (pure . const False) >=> traverse_ installAsset)

-- | Get all tags from the pages of the site.
sourceTags :: Site ()
sourceTags = do
  sgat <-
    map
      (second $ map splitDirectories .
       (^.. pageMeta . key "tags" . values . _String . to T.unpack)) .
    M.assocs <$>
    use pages
  htags .= M.fromList (invTags sgat)

-- | Organize a list of pages with hierarchical tags to a list with
-- hierarchical tags with pages attached.
invTags :: [(FilePath, [[String]])] -> [([String], [FilePath])]
invTags x =
  map (fmap nub) $ groupSort [(t, p) | (p, htl) <- x, ht <- htl, t <- inits ht]

-- | Get the destination for the tag page.
tagFilename :: FilePath -> Site FilePath
tagFilename tag = indexFilename $ "tag" </> tag

-- | Fold the hierarchical tag bits to a slashed path.
tagPath :: [String] -> FilePath
tagPath = foldr (</>) ""

-- | Make a link to the tag page
tagLink :: [String] -> Site FilePath
tagLink = rootUrl . ("tag" </>) . tagPath

-- | Make metadata for printing out a single hierarchical tag (all levels clickable)
makeHTagMeta :: [String] -> Site Y.Value
makeHTagMeta tag = do
  links <-
    zip (Y.Null : map fromString tag) . map fromString <$>
    traverse tagLink (inits tag)
  pure . Y.array $ map (\(t, p) -> Y.object [("tag", t), ("href", p)]) links

-- | Make metadata for printing out a single tag as-is, without levels
makeHTagLinkMeta :: [String] -> Site Y.Value
makeHTagLinkMeta tag = do
  link <- tagLink tag
  pure $
    Y.object [("href", fromString link), ("tags", Y.array $ map fromString tag)]

-- | Make metadata for printing out a link to a page
makePageLinkMeta :: FilePath -> Site Y.Value
makePageLinkMeta mount = do
  link <- rootUrl mount
  meta <- use $ pages . to (M.! mount) . pageMeta
  pure $ Y.object [("href", fromString link), ("meta", meta)]

-- | Create the complete metadata structure for the template that renders a given tag page
makeTagMeta :: [String] -> Site Y.Value
makeTagMeta tag = do
  taggedPages <- use $ htags . to (M.! tag)
  subtags <-
    gets
      (^.. htags . to M.keys . each . filtered (not . null) .
           filtered ((== tag) . init))
  htagMeta <- makeHTagMeta tag
  subtagsMeta <- Y.array <$> traverse makeHTagLinkMeta subtags
  pagesMeta <- Y.array <$> traverse makePageLinkMeta taggedPages
  pure $
    Y.object
      [("htag", htagMeta), ("subtags", subtagsMeta), ("pages", pagesMeta)]

-- | Render a site for a given tag string.
renderTag :: [String] -> Site ()
renderTag tag = do
  tname <- use tagTemplate
  templ <- use $ templates . to (M.! fromString tname)
  file <- tagFilename (tagPath tag)
  checkTarget file
  meta <- makeTagMeta tag
  io $ do
    putStrLn $ "# -> " ++ file
    makeDirectories file
    checkedSubstitute templ meta >>= TIO.writeFile file

-- | Render all tag sites.
renderTags :: Site ()
renderTags = use (htags . to M.keys) >>= traverse_ renderTag

-- | Build the whole site.
main = do
  init <- Options.Applicative.execParser siteOptions
  flip runStateT init $ do
    installAssets
    use sourceDirs >>= traverse sourcePages
    sourceTags
    use templateDir >>= sourceTemplates
    use pages >>= traverse (uncurry installPage) . M.assocs
    renderTags
    io $ putStrLn "OK"
    whenM (use dumpFinalState) $ get >>= io . print