From 435f1aff3c38b69d8e9ebc06ef43c4a0104bff2c Mon Sep 17 00:00:00 2001 From: Mirek Kratochvil Date: Fri, 21 Jul 2023 10:54:45 +0200 Subject: rename the executable to reploy --- Dockerfile | 2 +- reploy.cabal | 2 +- reploy.hs | 563 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ site.hs | 563 ----------------------------------------------------------- 4 files changed, 565 insertions(+), 565 deletions(-) create mode 100644 reploy.hs delete mode 100644 site.hs diff --git a/Dockerfile b/Dockerfile index 3fba1ec..e3fb80f 100644 --- a/Dockerfile +++ b/Dockerfile @@ -31,4 +31,4 @@ WORKDIR /data COPY assets /data/assets/ COPY templates /data/templates/ COPY pages /data/pages/ -ENTRYPOINT ["/root/.cabal/bin/site"] +ENTRYPOINT ["/root/.cabal/bin/reploy"] diff --git a/reploy.cabal b/reploy.cabal index 12a123a..247e06e 100644 --- a/reploy.cabal +++ b/reploy.cabal @@ -9,7 +9,7 @@ license: Apache-2.0 license-file: LICENSE executable site - main-is: site.hs + main-is: reploy.hs other-modules: Types, Utils, FormatOpts build-depends: base == 4.* , aeson 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 diff --git a/site.hs b/site.hs deleted file mode 100644 index 0c3a645..0000000 --- a/site.hs +++ /dev/null @@ -1,563 +0,0 @@ -{- - - 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 -- cgit v1.2.3