rename the executable to reploy

1 files changed, 563 insertions, 0 deletions

diff --git a/reploy.hs b/reploy.hs
new file mode 100644
index 0000000..0c3a645
--- /dev/null
+++ b/reploy.hs
@@ -0,0 +1,563 @@
+{-
+ - Copyright (C) 2023 University of Luxembourg
+ -
+ - Licensed under the Apache License, Version 2.0 (the "License"); you may not
+ - use this file except in compliance with the License. You may obtain a copy
+ - of the License from the LICENSE file in this repository, or at:
+ -
+ - http://www.apache.org/licenses/LICENSE-2.0
+ -
+ - Unless required by applicable law or agreed to in writing, software
+ - distributed under the License is distributed on an "AS IS" BASIS, WITHOUT
+ - WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the
+ - License for the specific language governing permissions and limitations
+ - under the License.
+ -}
+
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | The main deployment script.
+module Main where
+
+import Control.Monad ((>=>), filterM, join, unless, when)
+import Control.Monad.Extra (ifM, whenM)
+import Control.Monad.Trans.State.Lazy
+import qualified Data.Aeson as AE
+import qualified Data.Aeson.Key as K
+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, sort)
+import Data.List.Extra (groupSort)
+import qualified Data.Map as M
+import qualified Data.Scientific
+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.Directory (doesFileExist)
+import System.FilePath
+  ( (</>)
+  , isAbsolute
+  , joinPath
+  , splitDirectories
+  , splitFileName
+  , splitPath
+  , takeDirectory
+  , takeFileName
+  )
+import qualified Text.Mustache as Mu
+import Text.Pandoc.Class (runIOorExplode)
+import qualified Text.Pandoc.Definition
+import Text.Pandoc.Readers.Markdown (readMarkdown)
+import Text.Pandoc.Writers (writePlain)
+import Text.Pandoc.Writers.HTML (writeHtml5String)
+import Text.Pandoc.Writers.Shared (toTableOfContents)
+import qualified Text.Parsec.Error
+
+import FormatOpts
+import Types
+import Utils
+
+-- | Check if a given path should be sourced or not
+isSourceablePath :: FilePath -> Site Bool
+isSourceablePath fp = do
+  notSource <- use notSourceDirs
+  pure $ (&&) <$> hasSuffix ".md" . last <*> not . any (`elem` notSource) . init $
+    splitDirectories fp
+
+-- | Load the pages from a directory and add them to `pages`.
+sourcePages :: FilePath -> Site ()
+sourcePages fp =
+  (io $ getRecursiveContents (pure . const False) fp) >>=
+  filterM isSourceablePath >>=
+  traverse_ (loadPage . (fp </>))
+
+{- | 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
+  lt <- use listTemplate
+  nub . ([rt, tt, lt] ++) <$>
+    (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 =
+  if any (l `hasUriScheme`) ["http", "https", "ftp", "mailto"] || take 1 l ==
+     "#"
+    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
+
+-- | Add global information to page metadata for rendering (at this point just the url base)
+addGlobalMeta :: Y.Value -> Site Y.Value
+addGlobalMeta (Y.Object m) = do
+  r <- fromString <$> use urlBase
+  pure . Y.Object $ KM.insert "root" r m
+
+-- | Get the expected timestamp file for a given filepath
+timestampFile :: FilePath -> Site FilePath
+timestampFile fp = do
+  sfx <- use timestampSuffix
+  pure . uncurry (</>) . fmap (++ sfx) . splitFileName $ fp
+
+-- | If a timestamp file for the page exists, add the timestamp metadata.
+addTimeMeta :: PageInfo -> Y.Value -> Site Y.Value
+addTimeMeta pi m'@(Y.Object m)
+  | "timestamp" `KM.member` m = pure m' -- do not overwrite the timestamp if present
+  | otherwise = do
+    tspath <- timestampFile $ pi ^. pagePath
+    io $
+      ifM
+        (doesFileExist tspath)
+        (do putStrLn $ "timestamp <- " ++ tspath
+            ts <- Y.String <$> TIO.readFile tspath
+            pure . Y.Object $ KM.insert "timestamp" ts m)
+        (pure m')
+
+-- | Add page-specific information to the metadata. In this instance, this just
+-- expands the tags for rendering. Eventually would be nice to have the timestamps
+-- and possibly other info sourced right here.
+addPageMeta :: PageInfo -> Y.Value -> Site Y.Value
+addPageMeta pi (Y.Object m) = do
+  htagMeta <-
+    traverse (makeHTagMeta tagLink) . sort $ pi ^.. pageMeta . key "tags" .
+    values .
+    _String .
+    to T.unpack .
+    to splitDirectories
+  addTimeMeta pi . Y.Object $ KM.insert "htags" (Y.array htagMeta) m
+
+-- | If viable for a page (by config), add the TOC field
+addTOC :: PageInfo -> Text.Pandoc.Definition.Pandoc -> Y.Value -> Site Y.Value
+addTOC pi doc meta@(Y.Object meta') =
+  let go n = do
+        toc <-
+          io . runIOorExplode $ writeHtml5String htmlWriteOpts $
+          withPandocBlocks (pure . toTableOfContents (tocWriteOpts n)) doc
+        pure . Y.Object $ KM.insert "toc" (Y.String toc) meta'
+   in case ( pi ^? pageMeta . key "toc" . _Bool
+           , join $ pi ^? pageMeta . key "toc" . _Number .
+             to Data.Scientific.toBoundedInteger) of
+        (Just False, _) -> pure meta
+        (_, Nothing) -> go (3 :: Int)
+        (_, Just n) -> go n
+
+-- | 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
+  body <-
+    io . runIOorExplode $ writeHtml5String htmlWriteOpts $
+    addHeadingLinks "header-local-anchor" fixedUrlDoc
+  let Y.Object meta' = pi ^. pageMeta
+      meta = Y.Object $ KM.insert "body" (Y.String body) meta'
+  meta <- addGlobalMeta meta >>= addTOC pi fixedUrlDoc >>= addPageMeta pi
+  io $ do
+    putStrLn $ "P -> " ++ file
+    makeDirectories file
+    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)
+
+-- | Load tag names from a directory and add them to `tagNames`.
+sourceTagnames :: FilePath -> Site ()
+sourceTagnames fp =
+  io
+    (map (fp </>) . filter ((== "tagnames.yml") . last . splitPath) <$>
+     getRecursiveContents (pure . const False) fp) >>=
+  traverse_ sourceTagnameFile
+
+-- | Single item for `sourceTagnames`
+sourceTagnameFile :: FilePath -> Site ()
+sourceTagnameFile fp = do
+  yml' <-
+    io $ do
+      putStrLn $ "# <- " ++ fp
+      Y.decodeFileEither fp
+  case yml' of
+    Left err ->
+      error $ "Failed to load tagnames from " ++ fp ++ ": " ++ show err
+    Right yml -> traverse_ add $ KM.toList (yml :: KM.KeyMap String)
+      where add :: (KM.Key, String) -> Site ()
+            add (k, v) =
+              let go (Just ov) =
+                    if v == ov
+                      then Just ov
+                      else error
+                             ("conflicting tag names for tag " ++ K.toString k)
+                  go Nothing = Just v
+               in tagNames %= M.alter go (K.toString k)
+
+-- | Find the humanized name for a tag piece
+getTagName :: String -> Site String
+getTagName t = handleEmpty . maybe t id <$> use (tagNames . to (M.!? t))
+  where
+    handleEmpty "" = "all"
+    handleEmpty x = x
+
+-- | 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
+  ehtags .= M.fromList (invExpandTags sgat)
+  htags .= M.fromList (invTags sgat)
+
+-- | Organize a list of pages with hierarchical tags to a list with
+-- hierarchical tags with pages attached; with tags implying parents.
+invExpandTags :: [(FilePath, [[String]])] -> [([String], [FilePath])]
+invExpandTags x =
+  map (fmap nub) $ groupSort [(t, p) | (p, htl) <- x, ht <- htl, t <- inits ht]
+
+-- | Like `invExpandTags` but without the expansion.
+invTags :: [(FilePath, [[String]])] -> [([String], [FilePath])]
+invTags x = map (fmap nub) $ groupSort [(t, p) | (p, htl) <- x, t <- htl]
+
+-- | Get the destination for the tag page.
+tagFilename :: FilePath -> Site FilePath
+tagFilename tag = indexFilename $ "tag" </> tag
+
+-- | Get the destination for the tag page.
+listFilename :: FilePath -> Site FilePath
+listFilename tag = indexFilename $ "list" </> tag
+
+-- | Fold the hierarchical tag bits to a slashed path.
+tagPath :: [String] -> FilePath
+tagPath = joinPath
+
+-- | Make a link to the tag page
+tagLink :: [String] -> Site FilePath
+tagLink = rootUrl . ("tag" </>) . tagPath
+
+-- | Fold the hierarchical tag bits to a slashed path.
+listPath :: [String] -> FilePath
+listPath = joinPath
+
+-- | Make a link to the tag page
+listLink :: [String] -> Site FilePath
+listLink = rootUrl . ("list" </>) . listPath
+
+-- | Make metadata for printing out a single hierarchical tag (all levels clickable)
+makeHTagMeta :: ([String] -> Site FilePath) -> [String] -> Site Y.Value
+makeHTagMeta lf tag = do
+  links <- traverse lf (inits tag)
+  tags <- traverse getTagName ("" : tag)
+  pure . Y.array $
+    zipWith
+      (\t l -> Y.object [("tag", fromString t), ("href", fromString l)])
+      tags
+      links
+
+-- | 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 categorical tag pages
+makeTagMeta :: [String] -> Site Y.Value
+makeTagMeta tag = do
+  taggedPages <- use $ htags . to (M.!? tag) . to (maybe [] id)
+  subtags <-
+    gets
+      (^.. ehtags . to M.keys . each . filtered (not . null) .
+           filtered ((== tag) . init))
+  htagMeta <- makeHTagMeta tagLink tag
+  subtagsMeta <- Y.array <$> traverse makeTagMeta subtags
+  pagesMeta <- Y.array <$> traverse makePageLinkMeta taggedPages
+  link <- tagLink tag
+  listlink <- listLink tag
+  tags <- Y.array . map fromString <$> traverse getTagName tag
+  addGlobalMeta $
+    Y.object
+      [ ("href", fromString link)
+      , ("tags", tags)
+      , ("htag", htagMeta)
+      , ("subtags", subtagsMeta)
+      , ("pages", pagesMeta)
+      , ("listhref", fromString listlink)
+      ]
+
+-- | Make metadata for printing out a single tag as-is, without levels
+makeHTagLinkMeta :: [String] -> Site Y.Value
+makeHTagLinkMeta tag = do
+  link <- listLink tag
+  tags <- Y.array . map fromString <$> traverse getTagName tag
+  pure $ Y.object [("href", fromString link), ("tags", tags)]
+
+-- | Create the structure for rendering a complete listing of one hierarchical tag.
+makeListMeta :: [String] -> Site Y.Value
+makeListMeta tag = do
+  taggedPages <- use $ ehtags . to (M.! tag)
+  subtags <-
+    gets
+      (^.. ehtags . to M.keys . each . filtered (not . null) .
+           filtered ((== tag) . init))
+  htagMeta <- makeHTagMeta listLink tag
+  subtagsMeta <- Y.array <$> traverse makeHTagLinkMeta subtags
+  pagesMeta <- Y.array <$> traverse makePageLinkMeta taggedPages
+  tl <- tagLink tag
+  addGlobalMeta $
+    Y.object
+      [ ("htag", htagMeta)
+      , ("subtags", subtagsMeta)
+      , ("pages", pagesMeta)
+      , ("taghref", fromString tl)
+      ]
+
+-- | 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 (ehtags . to M.keys) >>= traverse_ renderTag
+
+-- | Render a site for a given tag string.
+renderList :: [String] -> Site ()
+renderList tag = do
+  tname <- use listTemplate
+  templ <- use $ templates . to (M.! fromString tname)
+  file <- listFilename (listPath tag)
+  checkTarget file
+  meta <- makeListMeta tag
+  io $ do
+    putStrLn $ "* -> " ++ file
+    makeDirectories file
+    checkedSubstitute templ meta >>= TIO.writeFile file
+
+-- | Render all tag sites.
+renderLists :: Site ()
+renderLists = use (ehtags . to M.keys) >>= traverse_ renderList
+
+-- | Transform one mounted PageInfo to the base search data
+mkSearchData :: FilePath -> PageInfo -> Site [Y.Value]
+mkSearchData mount pi = do
+  link <- rootUrl mount
+  text <- io . runIOorExplode $ writePlain plainWriteOpts (pi ^. pageDoc)
+  let title = pi ^? pageMeta . key "title" . _String
+  -- TODO: unify retrieval of tags
+  let tags =
+        sort $ pi ^.. pageMeta . key "tags" . values . _String . to T.unpack
+  tagnames <- traverse (traverse getTagName . splitDirectories) tags
+  let tagarray = Y.array . map (Y.array . map fromString) $ tagnames
+  if pi ^? pageMeta . key "search" . _Bool == Just False -- `off` gets parsed as bool
+    then pure []
+    else pure $
+         [ Y.object
+             [ ("link", fromString link)
+             , ("title", maybe (fromString mount) Y.String title)
+             , ("tags", tagarray)
+             , ("text", Y.String text)
+             ]
+         ]
+
+-- | Collect all pages' search data to the file
+renderSearchData :: Site ()
+renderSearchData = use searchDataOut >>= traverse_ go
+  where
+    go out = do
+      ps <- use (pages . to M.assocs) >>= traverse (uncurry mkSearchData)
+      io $ do
+        putStrLn $ "S -> " ++ out
+        AE.encodeFile out $ Y.array (concat ps)
+
+-- | Build the whole site.
+main = do
+  init <- Options.Applicative.execParser siteOptions
+  flip runStateT init $ do
+    installAssets
+    use sourceDirs >>= traverse sourcePages
+    use sourceDirs >>= traverse sourceTagnames
+    sourceTags
+    use templateDir >>= sourceTemplates
+    use pages >>= traverse (uncurry installPage) . M.assocs
+    renderTags
+    renderLists
+    renderSearchData
+    io $ putStrLn "OK"
+    whenM (use dumpFinalState) $ get >>= io . print