path: root/reploy.hs

{-
 - 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 #-}
{-# LANGUAGE TupleSections #-}

-- | The main site deployment executable module.
module Main where

import Control.Monad ((>=>), join, unless, when)
import Control.Monad.Extra (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 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 Lens.Micro
import Lens.Micro.Aeson
import Lens.Micro.Mtl
import qualified Options.Applicative
import System.Directory (doesFileExist)
import System.FilePath
  ( isAbsolute
  , joinPath
  , splitFileName
  , splitPath
  , takeDirectory
  , takeFileName
  )
import qualified Text.Mustache as Mu
import qualified Text.Mustache.Types as MT
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 AesonUtils
import FormatOpts
import Tags
import Types
import Utils

-- | Load the pages from a directory and add them to `pages`.
sourcePages :: FilePath -> Site ()
sourcePages fp = sourcePaths fp go
  where
    go p
      | hasSuffix ".md" (takeFileName p) = loadPage (fp </> p)
      | otherwise = pure ()

{- | 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 -> Site (Either Text.Parsec.Error.ParseError Mu.Template)
compileTemplate templ = do
  tds <- use templateDirs
  io $ do
    putStrLn $ "T <- " ++ templ
    Mu.automaticCompile tds templ

-- | Use a template set from a given directory.
sourceTemplates :: Site ()
sourceTemplates = do
  ts <- pageTemplates
  templs' <- fmap sequence . traverse compileTemplate $ 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
  idxf <- use indexFile
  pure (od </> mount </> idxf)

-- | 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

-- | Conjure a function that transforms absolute links to pages to full rooted
-- URLs.
rootedPageLink' :: Site (FilePath -> FilePath)
rootedPageLink' = do
  ub <- use urlBase
  app <- use appendUrlIndex
  if app
    then do
      idxf <- use indexFile
      pure $ \x -> ub </> unAbsolute x </> idxf
    else pure $ (ub </>) . unAbsolute

-- | Transform a link to page to a full rooted URL
rootedPageLink :: FilePath -> Site FilePath
rootedPageLink = (<*>) rootedPageLink' . pure

-- | Conjure a function that transforms absolute links to files to rooted URLs.
rootedLink' :: Site (FilePath -> FilePath)
rootedLink' = do
  ub <- use urlBase
  pure $ (ub </>) . unAbsolute

-- | Transform a link to file to a rooted URL.
rootedLink :: FilePath -> Site FilePath
rootedLink = (<*>) rootedLink' . pure

-- | Process a single link pointing out from a page.
processLink :: FilePath -> FilePath -> FilePath -> Site String
processLink base mount l
  | any (l `hasUriScheme`) ["http", "https", "ftp", "mailto"] || take 1 l == "#" =
    pure l
  | isAbsolute l =
    let (path, rest) = break (`elem` ['?', '#']) l
     in (<> rest) <$> rootedPageLink path
  | l `hasUriScheme` "mount" =
    let (path, rest) = break (`elem` ['?', '#']) $ drop 6 l
        mountpath =
          joinPath . reverse
            $ foldl interpretPath (reverse $ splitPath mount) (splitPath path)
        interpretPath m x
          | x `elem` ["..", "../"] = drop 1 m
          | x `elem` [".", "./"] = m
          | x == "/" = ["/"]
          | otherwise = x : m
     in (<> rest) <$> rootedPageLink mountpath
  | otherwise = installFile (base </> l) >>= rootedLink

-- | Conjure a function that finds a displayable name for a page at a particular mount.
pageName' :: Site (FilePath -> String)
pageName' = do
  ps <- use pages
  pure $ \mnt' ->
    just ("lookup for undefined page name : " ++ mnt')
      $ ps M.!? unAbsolute mnt'
          >>= (^? pageMeta . key "name" . _String . to T.unpack)

-- | Like `Mu.substitute` but writes (and eventually should throw) stuff on errors
checkedSubstitute :: Mu.Template -> MT.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 MT.Value
addGlobalMeta meta = do
  r <- use urlBase
  rt <- rootedLink'
  rtp <- rootedPageLink'
  pn <- pageName'
  aui <- use appendUrlIndex
  ifi <- use indexFile
  Y.Object m <- (`objMerge` meta) <$> use extraMeta
  let l = map (\(k, v) -> (K.toText k, Mu.toMustache v)) $ KM.toList m
  pure . Mu.object
    $ l
        ++ [ ("root", Mu.toMustache $ T.pack r)
           , ("rawRootUrl", Mu.overText $ T.pack . rt . T.unpack)
           , ("pageLink", Mu.overText $ T.pack . rtp . T.unpack)
           , ("pageName", Mu.overText $ T.pack . pn . T.unpack)
           ]
        ++ (if aui
              then [("indexFile", Mu.toMustache $ T.pack ifi)]
              else [])

-- | Get the expected timestamp file for a given filepath
metadataFile :: FilePath -> Site FilePath
metadataFile fp = do
  sfx <- use metadataSuffix
  pure . uncurry (</>) . fmap (++ sfx) . splitFileName $ fp

-- | If an extra-metadata file exists, patch it over the current metadata.
addExtraMeta :: PageInfo -> Y.Value -> Site Y.Value
addExtraMeta pi m = do
  metaPath <- metadataFile $ pi ^. pagePath
  metaExists <- io $ doesFileExist metaPath
  if metaExists
    then do
      io $ putStrLn ("M <- " ++ metaPath)
      em' <- io $ Y.decodeFileEither metaPath
      case em' of
        Left pe ->
          error
            $ "decoding "
                ++ metaPath
                ++ " failed: "
                ++ Y.prettyPrintParseException pe
        Right em -> pure $ objMerge em m
    else pure m

-- | Add page-specific information to the metadata. In this instance, this just
-- expands the tags for rendering and continues by adding extra metadata via
-- `addExtraMeta`.
addPageMeta :: PageInfo -> Y.Value -> Site Y.Value
addPageMeta pi (Y.Object m) = do
  htagMeta <-
    traverse (htagRenderMeta tagLink) . sort
      $ pi ^.. pageMeta
          . key "tags"
          . values
          . _String
          . to T.unpack
          . to splitTag
  addExtraMeta 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 <- indexFilename mount
  fixedUrlDoc <-
    walkURLs (processLink (pi ^. pagePath . to takeDirectory) mount)
      $ 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 <- addTOC pi fixedUrlDoc meta >>= addPageMeta pi >>= addGlobalMeta
  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
  target <- rootedPageLink target'
  tname <- use redirectTemplate
  templ <- use $ templates . to (M.! fromString tname)
  file <- indexFilename (unAbsolute from)
  checkTarget file
  io $ do
    putStrLn $ "@ -> " ++ file ++ " -> " ++ target
    makeDirectories file
    txt <-
      checkedSubstitute templ
        $ Mu.object [("target", Mu.toMustache $ 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 = "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 an explicitly named asset in the given asset dir
installAsset :: FilePath -> FilePath -> Site ()
installAsset ad fp = do
  od <- use outputDir
  let [src, dst] = map (</> fp) [ad, od]
  checkTarget dst
  io $ do
    putStrLn $ "A " ++ src ++ " -> " ++ dst
    copy src dst

-- | Copy all files from a given asset directory.
installAssetDir :: FilePath -> Site ()
installAssetDir ad =
  io (getRecursiveContents (pure . const False) ad)
    >>= traverse_ (installAsset ad)

-- | Copy all files from the asset directories.
installAssets :: Site ()
installAssets = use assetDirs >>= traverse_ installAssetDir

-- | Get the destination for the tag page.
tagFilename :: [String] -> Site FilePath
tagFilename = indexFilename . joinPath . ("tag" :)

-- | Make a link to the tag page
tagLink :: [String] -> Site FilePath
tagLink = rootedPageLink . joinPath . ("tag" :)

-- | Get the destination for the tag page.
listFilename :: [String] -> Site FilePath
listFilename = indexFilename . joinPath . ("list" :)

-- | Make a link to the tag page
listLink :: [String] -> Site FilePath
listLink = rootedPageLink . joinPath . ("list" :)

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

wrapPagesMeta :: Y.Value -> String -> FilePath -> Y.Value
wrapPagesMeta x linkname link =
  Y.object [("pages", x), (fromString linkname, fromString link)]

makeTagRenderMeta :: [String] -> Site Y.Value
makeTagRenderMeta = htagRenderMetaWithSubtags tagLink extra makeTagRenderMeta
  where
    extra htag = do
      meta <- exactlyTaggedPagesRenderMeta makePageLinkRenderMeta htag
      wrapPagesMeta meta "listhref" <$> listLink htag

makeListRenderMeta :: [String] -> Site Y.Value
makeListRenderMeta =
  htagRenderMetaWithSubtags
    listLink
    pr
    (htagRenderMetaWithSubtags
       listLink
       (const $ pure (Y.object []))
       (const $ pure Y.Null))
  where
    pr htag = do
      meta <- allTaggedPagesRenderMeta makePageLinkRenderMeta htag
      wrapPagesMeta meta "taghref" <$> tagLink htag

-- | Parametrized render of a listing-style site.
renderListing ::
     String
  -> ([String] -> Site FilePath)
  -> ([String] -> Site MT.Value)
  -> String
  -> [String]
  -> Site ()
renderListing templName fileName makeMeta mark htag = do
  templ <- (M.! fromString templName) <$> use templates
  file <- fileName htag
  checkTarget file
  meta <- makeMeta htag
  io $ do
    putStrLn $ (mark ++ " -> " ++ file)
    makeDirectories file
    checkedSubstitute templ meta >>= TIO.writeFile file

renderTags = do
  lt <- use tagTemplate
  M.keys <$> use ehtags
    >>= traverse_
          (renderListing
             lt
             tagFilename
             (makeTagRenderMeta >=> addGlobalMeta)
             "#")

renderLists = do
  lt <- use listTemplate
  M.keys <$> use ehtags
    >>= traverse_
          (renderListing
             lt
             listFilename
             (makeListRenderMeta >=> addGlobalMeta)
             "*")

-- | Transform one mounted PageInfo to the base search data
makeSearchData :: FilePath -> PageInfo -> Site [Y.Value]
makeSearchData mount pi = do
  link <- rootedPageLink mount
  text <- io . runIOorExplode $ writePlain plainWriteOpts (pi ^. pageDoc)
  let name = pi ^? pageMeta . key "name" . _String
  -- TODO: unify retrieval of tags?
  let tags =
        sort $ pi ^.. pageMeta . key "tags" . values . _String . to T.unpack
  tagnames <- traverse (traverse getTagGroupName . inits . splitTag) 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)
                 , ("name", maybe (fromString mount) Y.String name)
                 , ("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 makeSearchData)
      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 sourceTagMeta
    sourceTags
    sourceTemplates
    use pages >>= traverse (uncurry installPage) . M.assocs
    renderTags
    renderLists
    renderSearchData
    io $ putStrLn "OK"
    whenM (use dumpFinalState) $ get >>= io . print