reploy/site.hs

{-# LANGUAGE OverloadedStrings #-}

-- | The main deployment script.
module Main where

import Control.Monad ((>=>), unless, when)
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 System.FilePath
  ( (</>)
  , isAbsolute
  , splitDirectories
  , splitPath
  , 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 = do
  links <-
    io $ filter (hasSuffix ".md" . last . splitPath) <$>
    getRecursiveContents (pure . const False) fp
  traverse_ loadPage (map (fp </>) links)

{- | 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 =
        T.unpack . just ("mount point of " ++ fp) $ yml ^? key "title" . _String
  {- 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)

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

-- | Process a single link pointing out from a page.
processLink :: FilePath -> String -> Site String
processLink base l = do
  if isAbsolute l
    then pure l
    else (do io . putStrLn $ "rel:" ++ l
             pure $ '/' : (base </> l) -- TODO
          )

-- | Get a mount point of the page into the correct location.
pageFilename :: FilePath -> Site FilePath
pageFilename p = indexFilename $ "page" </> p

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 mount) $ 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)

-- | 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 = "data" </> 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)

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

-- | Render a site for a given tag string.
renderTag :: [String] -> [FilePath] -> Site ()
renderTag tag pages = do
  tname <- use tagTemplate
  templ <- use $ templates . to (M.! fromString tname)
  let tagpath = foldr (</>) mempty tag
  file <- tagFilename tagpath
  checkTarget file
  io $ do
    putStrLn $ "# -> " ++ file
    makeDirectories file
    let str = fromString
        arr = Y.array
        meta =
          Y.Object $
          KM.fromList
            [ ("tagpath", str tagpath)
            , ("tag", arr $ map str tag)
            , ("pages", arr $ map str pages)
            ]
    checkedSubstitute templ meta >>= TIO.writeFile file

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

-- | Build the whole site.
main =
  flip runStateT emptySiteState $ do
    installAssets
    traverse sourcePages ["external"]
    sourceTags
    sourceTemplates "templates"
    use pages >>= traverse (uncurry installPage) . M.assocs
    renderTags
    -- testing part begin
    installFile "external/mypage/img/awesome.png"
    -- testing part end
    io $ putStrLn "OK"
    get >>= io . print