exa/reploy
1
0
Fork 0
Code Issues Pull requests Actions Packages Projects Releases Wiki Activity

Merge branch 'mk-howtocards-fixes' into 'master'

Browse source 
updates required for howto-cards

See merge request lcsb/sps/reploy!5
This commit is contained in:
Miroslav Kratochvil 2023-10-16 11:37:27 +02:00
parent 4cdbf598c0 005b69dd47
commit fee144a3ec
16 changed files with 499 additions and 350 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

25
AesonUtils.hs Normal file
View file

@ -0,0 +1,25 @@
{-
- 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.
-}
module AesonUtils where
import qualified Data.Aeson as A
import qualified Data.Aeson.KeyMap as KM
-- | A bit like `lodashMerge` from aeson-extra, but replaces the arrays. Right
-- argument overwrites the left one.
objMerge :: A.Value -> A.Value -> A.Value
objMerge (A.Object a) (A.Object b) = A.Object $ KM.unionWith objMerge a b
objMerge _ b = b

35
README.md
View file

@ -61,14 +61,18 @@ markdown file produces one "main" resulting page at the "mount" location, and
optionally several redirect pages and (additions to) category pages.
All markdown files have to contain a YAML header that describes where the page
should go and adds a few other formatting options. The whole content of the YAML header (together with some other data) is also made accessible to the Mustache templates -- that way you can smuggle custom contents to the HTML rendering machinery.
should go and adds a few other formatting options. The whole content of the
YAML header (together with some other data) is also made accessible to the
Mustache templates -- that way you can smuggle custom contents to the HTML
rendering machinery.
#### YAML header format
##### Required options
- `mount` (string): what should be the canonical URL of the page
- `title` (string): the name of the page for display in templates and page links
- `name` (string): the name of the page for display in templates and page links
(technically, the `name` is not required UNLESS you
##### Optional
@ -78,12 +82,9 @@ should go and adds a few other formatting options. The whole content of the YAML
search index.
- `toc` (boolean or int, default `3`): if false, no ToC is generated for the
page. Otherwise the integer sets the depth of the ToC.
- `timestamp` (string): A description of the "timestamp" for the page,
typically the date of the last page modification. For any file, this value is
also defaulted from `<filename>.timestamp` (e.g., `mypage.md.timestamp`),
which simplifies generation of the timestamps by external software (see
`scripts/source-timestamps.sh` for an example of how to do that from `git`
history)
- `order` (integer or string, defaults to `name` and then `mount`): order of
the page in page listings. Negative numbers and zero sort before strings,
positive numbers sort after strings.
- `tags` (array of strings): list of `/`-separated hierarchical tags
("categories") that are assigned to the page. The page will be listed in the
category listings accordingly.
@ -95,9 +96,12 @@ should go and adds a few other formatting options. The whole content of the YAML
```md
---
mount: /about-something
title: About something
name: About something
order: -1
toc: 2
template: special.html
tags:
- stuff/special
---
# A page about something!
@ -105,6 +109,19 @@ template: special.html
Lorem ipsum etc., as usual.
```
#### Example `tag-metadata.yml`
```yaml
"":
name: "Root tag"
extra_message_can_be_processed_by_template: "xxxx"
test/attempts:
name: "Testing"
order: -1
```
`name` and `order` work just as with pages.
### Template syntax
Reploy uses the "simple" vanilla

195
Tags.hs Normal file
View file

@ -0,0 +1,195 @@
{-# LANGUAGE OverloadedStrings #-}
module Tags where
import qualified Data.Aeson.Key as K
import qualified Data.Aeson.KeyMap as KM
import Data.Foldable (traverse_)
import Data.List (inits, nub, sortOn)
import Data.List.Extra (groupSort)
import qualified Data.Map as M
import Data.String (fromString)
import qualified Data.Text as T
import qualified Data.Yaml as Y
import Lens.Micro
import Lens.Micro.Aeson
import Lens.Micro.Mtl
import System.FilePath ((</>), joinPath, splitDirectories, takeFileName)
import AesonUtils
import Types
import Utils
-- | Split a tag string into a hierarchical tag elements. Corner slashes and
-- slash groups are removed.
splitTag :: String -> [String]
splitTag = dropWhile (all (== '/')) . splitDirectories
-- | Load all tag metadata from a directory.
sourceTagMeta :: FilePath -> Site ()
sourceTagMeta fp = do
tmf <- use tagMetaFile
let go p
| takeFileName p == tmf = sourceTagMetaFile (fp </> p)
| otherwise = pure ()
sourcePaths fp go
-- | Load a given tag metadata file.
sourceTagMetaFile :: FilePath -> Site ()
sourceTagMetaFile fp = do
yml' <-
io $ do
putStrLn $ "# <- " ++ fp
Y.decodeFileEither fp
case yml' of
Left err ->
error
("Failed to load tag metadata from " ++ fp ++ ": " ++
Y.prettyPrintParseException err)
Right yml -> traverse_ go (KM.toList yml)
where go :: (KM.Key, Y.Value) -> Site ()
go (k, v') =
let ks = K.toString k
kx = splitTag ks
v
| Y.String t <- v' =
Y.Object $ KM.fromList [("name", Y.String t)]
| Y.Object _ <- v' = v'
| otherwise =
error ("invalid definition of tag " ++ ks ++ " in " ++ fp)
ins (Just ov)
| v == ov = Just ov
| otherwise =
error
("conflicting tag metadata for tag " ++ ks ++ " in " ++
fp)
ins Nothing = Just v
in tagMeta %= M.alter ins kx
-- | Find a good display name for the _last_ hierarchical part of the htag.
getTagGroupName :: [String] -> Site String
getTagGroupName htag =
handleEmpty . maybe backup id . (>>= name) . (M.!? htag) <$> use tagMeta
where
name :: Y.Value -> Maybe String
name obj = obj ^? key "name" . _String . to T.unpack
backup
| null htag = ""
| null (last htag) = "(unnamed)"
| otherwise = last htag
handleEmpty x
| null x = "(root)"
| otherwise = x
-- | Get all tags from the pages of the site and fill in the `htags` and
-- `ehtags` data.
sourceTags :: Site ()
sourceTags = do
sgat <-
map
(second $ map splitTag .
(^.. 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]
-- | Extract the known metadata about a given tag, or give null if there's none.
htagMeta :: [String] -> Site Y.Value
htagMeta htag = maybe Y.Null id . (M.!? htag) <$> use tagMeta
-- | Make metadata for printing out a single hierarchical tag
htagRenderMeta :: ([String] -> Site FilePath) -> [String] -> Site Y.Value
htagRenderMeta makeLink htag = do
let htags = inits htag
links <- map fromString <$> traverse makeLink htags
names <- map fromString <$> traverse getTagGroupName htags
metas <- traverse htagMeta htags
pure $
Y.object
[ ("href", last links)
, ("name", last names)
, ("meta", last metas)
, ( "htag"
, Y.array $
zipWith3
(\l n m -> Y.object [("href", l), ("name", n), ("meta", m)])
links
names
metas)
]
data SortKey num
= Negative num
| Stringy String
| Positive num
deriving (Show, Eq, Ord)
toSortKey ident x
| Just i <- x ^? key "meta" . key "order" . _Number =
if i <= 0
then Negative i
else Positive i
| Just s <- x ^? key "meta" . key "order" . _String = Stringy (T.unpack s)
| Just n <- x ^? key "name" . _String = Stringy (T.unpack n)
| otherwise = Stringy ident
-- | A generic helper for rendering metadata for tagged pages.
genericTaggedPagesRenderMeta ::
(FilePath -> Site Y.Value)
-> [String]
-> M.Map [String] [FilePath]
-> Site Y.Value
genericTaggedPagesRenderMeta makePageMeta htag tagmap =
Y.array . map snd . sortOn (uncurry toSortKey) <$>
traverse metaPair (maybe [] id $ tagmap M.!? htag)
where
metaPair x = do
m <- makePageMeta x
pure (x, m)
-- | Render metadata for all precisely tagged pages (not considering the
-- inheritance of tags following the hierarchy).
exactlyTaggedPagesRenderMeta ::
(FilePath -> Site Y.Value) -> [String] -> Site Y.Value
exactlyTaggedPagesRenderMeta makePageLinkMeta t =
use htags >>= genericTaggedPagesRenderMeta makePageLinkMeta t
-- | Render metadata for all pages tagged by a given hierarchical tags (subtags
-- included).
allTaggedPagesRenderMeta ::
(FilePath -> Site Y.Value) -> [String] -> Site Y.Value
allTaggedPagesRenderMeta makePageLinkMeta t =
use ehtags >>= genericTaggedPagesRenderMeta makePageLinkMeta t
-- | Like `htagRenderMeta`, but has hooks for extra metadata (e.g., listing of
-- pages) and for sub-tag rendering. That can be used for recursively building
-- metadata for whole tag hierarchies.
htagRenderMetaWithSubtags ::
([String] -> Site FilePath)
-> ([String] -> Site Y.Value)
-> ([String] -> Site Y.Value)
-> [String]
-> Site Y.Value
htagRenderMetaWithSubtags makeLink extraMeta subtagMeta htag = do
meta <- htagRenderMeta makeLink htag
em <- extraMeta htag
subtags <-
filter ((== htag) . init) . filter (not . null) . M.keys <$> use ehtags
let metaPair x = do
m <- subtagMeta x
pure (joinPath x, m)
subtagMetas <-
Y.array . filter (/= Y.Null) . map snd . sortOn (uncurry toSortKey) <$>
traverse metaPair subtags
pure $ meta `objMerge` Y.object [("subtags", subtagMetas)] `objMerge` em

93
Types.hs
View file

@ -20,9 +20,9 @@
-- | Separated-out main types of the deployment scriptage.
module Types where
import AesonUtils
import Control.Monad.Trans.State.Lazy
import qualified Data.ByteString.UTF8
import Data.List.NonEmpty (nonEmpty, toList)
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.Yaml as Y
@ -45,39 +45,30 @@ makeLenses ''PageInfo
-- | Complete internal state of the deployment process that holds all data
data SiteState =
SiteState
-- | Map of page mounts to `PageInfo`
{ _pages :: M.Map FilePath PageInfo
-- | Map of redirects (from -> to)
, _redirects :: M.Map FilePath FilePath
-- | Map of tags, assigning to each tag sequence a list of
-- tagged page mounts
, _htags :: M.Map [String] [FilePath]
-- | Map of tags, assigning to each tag sequence a list of tagged page
-- mounts. This one is expanded (tags imply parent categories).
, _ehtags :: M.Map [String] [FilePath]
-- | Map of "short" tags to expanded human-friendly names
, _tagNames :: M.Map String String
-- | List of installed files (enables sharing)
, _installs :: S.Set (String, FilePath)
-- | List of installed files (prevents overwriting)
, _targets :: S.Set FilePath
-- | Map of Mustache templates organized by template search path (within
-- the template directory)
, _templates :: M.Map FilePath Mu.Template
{ _pages :: M.Map FilePath PageInfo -- ^ Map of page mounts to `PageInfo`
, _redirects :: M.Map FilePath FilePath -- ^ Map of redirects (from -> to)
, _htags :: M.Map [String] [FilePath] -- ^ Map of tags, assigning to each tag sequence a list of tagged page mounts
, _ehtags :: M.Map [String] [FilePath] -- ^ Map of tags, assigning to each tag sequence a list of tagged page mounts. This one is expanded (tags imply parent categories).
, _tagMeta :: M.Map [String] Y.Value -- ^ Map of tags to expanded human-friendly names
, _installs :: S.Set (String, FilePath) -- ^ List of copy-installed files (among other, this enables sharing)
, _targets :: S.Set FilePath -- ^ List of files installed to the target site (this allows us to throw an error in case anything would write to the same target twice)
, _templates :: M.Map FilePath Mu.Template -- ^ Map of Mustache templates organized by template search path (within the template directory)
, _outputDir :: FilePath -- ^ Directory for output
, _searchDataOut :: Maybe FilePath -- ^ File to write the searchable versions of pages to (as JSON)
, _assetDir :: FilePath -- ^ Directory for output
, _assetDirs :: [FilePath] -- ^ Directory for output
, _sourceDirs :: [FilePath] -- ^ Path to page source data
, _notSourceDirs :: [FilePath] -- ^ Subdirectories of source dirs where pages should not be sourced
, _tagMetaFile :: FilePath -- ^ Name of the "tag metadata" files to find in the source directories.
, _templateDir :: FilePath -- ^ Path to template directory
, _defaultTemplate :: FilePath -- ^ Name of the default template
, _redirectTemplate :: FilePath -- ^ Name of the template for redirect pages
, _tagTemplate :: FilePath -- ^ Name of the template for category pages
, _listTemplate :: FilePath -- ^ Name of the template for listing pages
, _extraMeta :: [(String, Y.Value)] -- ^ Extra metadata added to rendering of all templates
, _timestampSuffix :: FilePath -- ^ File to search for a timestamp (e.g., if the prefix is ".ts", a timestamp for file "page.md" will be looked for in "page.md.ts"). These are best autogenerated with a script that sources the data from git or so.
, _extraMeta :: Y.Value -- ^ Extra metadata added to rendering of all templates
, _metadataSuffix :: FilePath -- ^ File suffix to search for a extra metadata (e.g., if the suffix is ".extra", the extra metadata for file "page.md" will be looked for in "page.md.extra"). These are best autogenerated with a script that sources the data from git or so.
, _indexFile :: FilePath -- ^ Name of the "index" files to be generated.
, _urlBase :: FilePath -- ^ "Root route" to prepend to all absolute links.
, _appendUrlIndex :: Bool -- ^ Append full @index.html@ to all page URLs
, _appendUrlIndex :: Bool -- ^ Append full index filenames to all page URLs
, _dumpFinalState :: Bool -- ^ Triggers printing out the structure when the processing finishes.
}
deriving (Show)
@ -101,23 +92,26 @@ siteOptions' = do
long "search-data-output" <>
help "Output JSON with searchable page data to this file") <|>
pure Nothing
_assetDir <-
strOption $
_assetDirs <-
many . strOption $
long "assets" <>
short 'a' <>
help "Assets directory to be copied verbatim" <>
value "assets" <> showDefault
help "Assets directory to be copied verbatim (possibly multiple paths)"
_sourceDirs <-
fmap (maybe ["pages"] toList . nonEmpty) . many . strOption $
many . strOption $
long "source-directory" <>
short 's' <>
help
"Path to the directory with source data (possibly multiple paths, defaults to a single directory \"pages\")"
help "Path to the directory with source data (possibly multiple paths)"
_notSourceDirs <-
fmap (maybe ["assets"] toList . nonEmpty) . many . strOption $
many . strOption $
long "exclude-source-directory" <>
help
"Names of subdirectories of the sources that should never be used for sourcing pages (possibly multiple directory names, defaults to a single directory \"assets\")"
"Names of subdirectories of the sources that should never be used for sourcing pages (possibly multiple directory names)"
_tagMetaFile <-
strOption $
long "tag-metadata-file" <>
help "Name of files with tag metadata" <>
value "tag-metadata.yml" <> showDefault
_templateDir <-
strOption $
long "template-directory" <>
@ -126,7 +120,7 @@ siteOptions' = do
_defaultTemplate <-
strOption $
long "default-template" <>
help "Default template to use for stuff (found in templates directory)" <>
help "Default template to use for stuff (as found in templates directory)" <>
value "default.html" <> showDefault
_redirectTemplate <-
strOption $
@ -143,30 +137,33 @@ siteOptions' = do
long "list-template" <>
help "Template for making tag-listing pages" <>
value "list.html" <> showDefault
_timestampSuffix <-
_metadataSuffix <-
strOption $
long "timestamp-prefix" <>
help "Timestamp file suffix for markdowns" <>
value ".timestamp" <> showDefault
long "metadata-suffix" <>
help
"Suffix for YAML files with base metadata for each markdown page. Metadata from files override the extra metadata specified on commandline, but are overridden by metadata specified directly in the markdown header of the pages." <>
value ".metadata.yml" <> showDefault
_extraMeta <-
let processKeyVal :: String -> (String, Y.Value)
let processKeyVal :: String -> Y.Value
processKeyVal opt =
case break (== ':') opt of
(k, ':':v) ->
case Y.decodeEither' $ Data.ByteString.UTF8.fromString v of
Right v -> (k, v :: Y.Value)
case Y.decodeEither' $ Data.ByteString.UTF8.fromString opt of
Right v -> v
Left err ->
error $
"cannot parse key:val in --extra-metadata: " ++ show err
_ -> error "cannot process key:val in --extra-metadata"
in fmap (map processKeyVal) . many . strOption $
"cannot parse YAML in --extra-metadata: " ++
Y.prettyPrintParseException err
in fmap (foldl objMerge Y.Null . map processKeyVal) . many . strOption $
long "extra-metadata" <>
help
"Extra metadata to add to pages rendering in format `key:<yaml>'. May be specified multiple times."
"Extra metadata to add to pages rendering in YAML format. May be specified multiple times."
_urlBase <-
strOption $
long "url-base" <>
short 'u' <> help "Base absolute URL" <> value "/" <> showDefault
_indexFile <-
strOption $
long "index-filename" <>
help "Base absolute URL" <> value "index.html" <> showDefault
_appendUrlIndex <-
switch $
long "append-url-index" <>
@ -183,7 +180,7 @@ siteOptions' = do
, _redirects = M.empty
, _htags = M.empty
, _ehtags = M.empty
, _tagNames = M.empty
, _tagMeta = M.empty
, _installs = S.empty
, _targets = S.empty
, _templates = M.empty

21
Utils.hs
View file

@ -22,12 +22,13 @@ import Control.Monad.IO.Class
import Data.List.Extra (stripSuffix)
import Data.Maybe (isJust)
import qualified Data.Text as T
import Lens.Micro.Mtl
import System.Directory
( createDirectoryIfMissing
, doesDirectoryExist
, getDirectoryContents
)
import System.FilePath ((</>), takeDirectory)
import System.FilePath ((</>), splitDirectories, takeDirectory)
import Text.Pandoc.Definition
import qualified Text.Pandoc.Walk
import Types
@ -116,6 +117,24 @@ getRecursiveContents ignore top = go ""
else return [rel]
return $ concat paths
-- | A nice tool interned from Relude.
foldMapM :: (Monoid b, Monad m, Foldable f) => (a -> m b) -> f a -> m b
foldMapM f xs = foldr step return xs mempty
where
step x r z = f x >>= \y -> r $! z `mappend` y
-- | Source paths from a source-y directory. The paths that have to be ignored
-- by config `notSourceDirs` are omitted.
sourcePaths :: Monoid a => FilePath -> (FilePath -> Site a) -> Site a
sourcePaths fp process = do
notSource <- use notSourceDirs
let ignoreDir ds
| null ds = False
| last ds `elem` notSource = True
| otherwise = False
io (getRecursiveContents (pure . ignoreDir . splitDirectories) fp) >>=
foldMapM process
-- | Given a path to a file, try to make the path writable by making all
-- directories on the path. (Interned from Hakyll.)
makeDirectories :: FilePath -> IO ()

2
pages/index.md
View file

@ -2,7 +2,7 @@
mount: /
redirects:
- also_index
title: Home
name: Home
toc: off
timestamp: null
---

2
pages/search.md
View file

@ -1,6 +1,6 @@
---
mount: /search
title: Search
name: Search
template: search.html
search: off
toc: off

4
reploy.cabal
View file

@ -3,14 +3,14 @@ cabal-version: 3.0
name: reploy
synopsis: Straightforward static all-in-one website builder
category: Web
version: 0.2.0.0
version: 0.3.0.0
build-type: Simple
license: Apache-2.0
license-file: LICENSE
executable reploy
main-is: reploy.hs
other-modules: Types, Utils, FormatOpts
other-modules: Types, AesonUtils, Utils, Tags, FormatOpts
build-depends: base == 4.*
, aeson ^>= 2.1
, bytestring

399
reploy.hs
View file

@ -14,22 +14,21 @@
- under the License.
-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
-- | The main site deployment executable.
-- | The main site deployment executable module.
module Main where
import Control.Monad ((>=>), filterM, join, unless, when)
import Control.Monad.Extra (ifM, whenM)
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 Data.Bool (bool)
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
@ -47,9 +46,7 @@ import System.FilePath
( (</>)
, isAbsolute
, joinPath
, splitDirectories
, splitFileName
, splitPath
, takeDirectory
, takeFileName
)
@ -63,23 +60,19 @@ 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
-- | 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 </>))
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`. -}
@ -147,7 +140,8 @@ sourceTemplates templdir = do
indexFilename :: FilePath -> Site FilePath
indexFilename mount = do
od <- use outputDir
pure (od </> mount </> "index.html")
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 ()
@ -157,22 +151,31 @@ checkTarget fp = do
then error $ "colliding renders for page: " ++ fp
else targets %= S.insert fp
-- | Prepend the root path to the given link
rootUrl' :: FilePath -> FilePath -> FilePath
rootUrl' root = (root </>) . unAbsolute
-- | 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 </> x </> idxf
else pure (ub </>)
-- | Same as `rootUrl'` but conveniently in the monad
rootUrl :: FilePath -> Site FilePath
rootUrl fp = flip rootUrl' fp <$> use urlBase
-- | Transform a link to page to a full rooted URL
rootedPageLink :: FilePath -> Site FilePath
rootedPageLink = (<*>) rootedPageLink' . pure
-- | Like `rootUrl'` but also appends @index.html@ for systems that don't have
-- working directory indexes.
rootPageUrl' :: FilePath -> Bool -> FilePath -> FilePath
rootPageUrl' root index fp = bool id (</> "index.html") index $ rootUrl' root fp
-- | Conjure a function that transforms absolute links to files to rooted URLs.
rootedLink' :: Site (FilePath -> FilePath)
rootedLink' = do
ub <- use urlBase
pure (ub </>)
-- | Convenient version of `rootPageUrl'`
rootPageUrl :: FilePath -> Site FilePath
rootPageUrl fp = rootPageUrl' <$> use urlBase <*> use appendUrlIndex <*> pure fp
-- | 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 -> Site String
@ -181,67 +184,65 @@ processLink base l =
"#"
then pure l
else if isAbsolute l
then rootPageUrl 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
then rootedPageLink l
else installFile (base </> l) >>= rootedLink
-- | 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"
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 (Y.Object m) = do
r <- use urlBase
i <- use appendUrlIndex
em <- use extraMeta
rt <- rootedLink'
rtp <- rootedPageLink'
let l = map (\(k, v) -> (K.toText k, Mu.toMustache v)) $ KM.toList m
pure . Mu.object $ l ++ map (\(k, v) -> (T.pack k, Mu.toMustache v)) em ++
pure . Mu.object $ l ++
[ ("root", Mu.toMustache $ T.pack r)
, ("rawRootUrl", Mu.overText $ T.pack . rootUrl' r . T.unpack)
, ("pageLink", Mu.overText $ T.pack . rootPageUrl' r i . T.unpack)
, ("rawRootUrl", Mu.overText $ T.pack . rt . T.unpack)
, ("pageLink", Mu.overText $ T.pack . rtp . T.unpack)
]
-- | Get the expected timestamp file for a given filepath
timestampFile :: FilePath -> Site FilePath
timestampFile fp = do
sfx <- use timestampSuffix
metadataFile :: FilePath -> Site FilePath
metadataFile fp = do
sfx <- use metadataSuffix
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')
-- | 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
gem <- use extraMeta
objMerge gem <$>
if metaExists
then do
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. Eventually would be nice to have the timestamps
-- and possibly other info sourced right here.
-- 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 (makeHTagMeta tagLink) . sort $ pi ^.. pageMeta . key "tags" .
traverse (htagRenderMeta tagLink) . sort $ pi ^.. pageMeta . key "tags" .
values .
_String .
to T.unpack .
to splitDirectories
addTimeMeta pi . Y.Object $ KM.insert "htags" (Y.array htagMeta) m
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
@ -263,7 +264,7 @@ installPage :: FilePath -> PageInfo -> Site ()
installPage mount pi = do
tname <- pageTemplate pi
templ <- use $ templates . to (M.! fromString tname)
file <- pageFilename mount
file <- indexFilename mount
fixedUrlDoc <-
walkURLs (processLink $ pi ^. pagePath . to takeDirectory) $ pi ^. pageDoc
checkTarget file
@ -282,7 +283,7 @@ installPage mount pi = do
{- | Install a simple redirect handler page. -}
installRedirect :: FilePath -> FilePath -> Site ()
installRedirect target' from = do
target <- rootPageUrl target'
target <- rootedPageLink target'
tname <- use redirectTemplate
templ <- use $ templates . to (M.! fromString tname)
file <- indexFilename from
@ -333,231 +334,123 @@ installFile fp = do
copy fp file
pure loc
-- | Simply copy a strictly named asset.
installAsset :: FilePath -> Site ()
installAsset fp = do
-- | Simply copy an explicitly named asset in the given asset dir
installAsset :: FilePath -> FilePath -> Site ()
installAsset ad fp = do
od <- use outputDir
ad <- use assetDir
let [src, dst] = map (</> fp) [ad, od]
checkTarget dst
io $ do
putStrLn $ "A -> " ++ src ++ " -> " ++ dst
putStrLn $ "A " ++ src ++ " -> " ++ dst
copy src dst
-- | Copy all files from asset directory.
-- | 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 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]
installAssets = use assetDirs >>= traverse_ installAssetDir
-- | 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
tagFilename :: [String] -> Site FilePath
tagFilename = indexFilename . joinPath . ("tag" :)
-- | Make a link to the tag page
tagLink :: [String] -> Site FilePath
tagLink = rootPageUrl . ("tag" </>) . tagPath
tagLink = rootedPageLink . joinPath . ("tag" :)
-- | Fold the hierarchical tag bits to a slashed path.
listPath :: [String] -> FilePath
listPath = joinPath
-- | 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 = rootPageUrl . ("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
listLink = rootedPageLink . joinPath . ("list" :)
-- | Make metadata for printing out a link to a page
makePageLinkMeta :: FilePath -> Site Y.Value
makePageLinkMeta mount = do
link <- rootPageUrl mount
makePageLinkRenderMeta :: FilePath -> Site Y.Value
makePageLinkRenderMeta mount = do
link <- rootedPageLink mount
meta <- use $ pages . to (M.! mount) . pageMeta
pure $ Y.object [("href", fromString link), ("meta", meta)]
-- | Like `makeTagMeta`, but returns only plain YAML without the functions (in
-- outcome the result is easier to work with using the YAML machinery,
-- allowing this to recurse to itself).
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
pure $
Y.object
[ ("href", fromString link)
, ("tags", tags)
, ("htag", htagMeta)
, ("subtags", subtagsMeta)
, ("pages", pagesMeta)
, ("listhref", fromString listlink)
]
[("mount", fromString mount), ("href", fromString link), ("meta", meta)]
-- | Create the complete metadata structure for the template that renders a given categorical tag pages
makeTagMeta :: [String] -> Site MT.Value
makeTagMeta tag = makeTagMeta' tag >>= addGlobalMeta
wrapPagesMeta :: Y.Value -> String -> FilePath -> Y.Value
wrapPagesMeta x linkname link =
Y.object [("pages", x), (fromString linkname, fromString link)]
-- | 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)]
makeTagRenderMeta :: [String] -> Site Y.Value
makeTagRenderMeta = htagRenderMetaWithSubtags tagLink extra makeTagRenderMeta
where
extra htag = do
meta <- exactlyTaggedPagesRenderMeta makePageLinkRenderMeta htag
wrapPagesMeta meta "listhref" <$> listLink htag
-- | Create the structure for rendering a complete listing of one hierarchical tag.
makeListMeta :: [String] -> Site MT.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)
]
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
-- | 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)
-- | 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 <- makeTagMeta tag
meta <- makeMeta htag
io $ do
putStrLn $ "# -> " ++ file
putStrLn $ (mark ++ " -> " ++ file)
makeDirectories file
checkedSubstitute templ meta >>= TIO.writeFile file
-- | Render all tag sites.
renderTags :: Site ()
renderTags = use (ehtags . to M.keys) >>= traverse_ renderTag
renderTags = do
lt <- use tagTemplate
M.keys <$> use ehtags >>=
traverse_
(renderListing lt tagFilename (makeTagRenderMeta >=> addGlobalMeta) "#")
-- | 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
renderLists = do
lt <- use listTemplate
M.keys <$> use ehtags >>=
traverse_
(renderListing lt listFilename (makeListRenderMeta >=> addGlobalMeta) "*")
-- | Transform one mounted PageInfo to the base search data
mkSearchData :: FilePath -> PageInfo -> Site [Y.Value]
mkSearchData mount pi = do
link <- rootPageUrl mount
makeSearchData :: FilePath -> PageInfo -> Site [Y.Value]
makeSearchData mount pi = do
link <- rootedPageLink mount
text <- io . runIOorExplode $ writePlain plainWriteOpts (pi ^. pageDoc)
let title = pi ^? pageMeta . key "title" . _String
-- TODO: unify retrieval of tags
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 getTagName . splitDirectories) tags
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)
, ("title", maybe (fromString mount) Y.String title)
, ("name", maybe (fromString mount) Y.String name)
, ("tags", tagarray)
, ("text", Y.String text)
]
@ -568,7 +461,7 @@ renderSearchData :: Site ()
renderSearchData = use searchDataOut >>= traverse_ go
where
go out = do
ps <- use (pages . to M.assocs) >>= traverse (uncurry mkSearchData)
ps <- use (pages . to M.assocs) >>= traverse (uncurry makeSearchData)
io $ do
putStrLn $ "S -> " ++ out
AE.encodeFile out $ Y.array (concat ps)
@ -579,7 +472,7 @@ main = do
flip runStateT init $ do
installAssets
use sourceDirs >>= traverse sourcePages
use sourceDirs >>= traverse sourceTagnames
use sourceDirs >>= traverse sourceTagMeta
sourceTags
use templateDir >>= sourceTemplates
use pages >>= traverse (uncurry installPage) . M.assocs

6
scripts/make-search-index.js
View file

@ -34,7 +34,7 @@ lunr = require("lunr")
fs = require("fs")
if(process.argv.length !== 5) {
console.error('Needs exactly 3 arguments (input json, output index).');
console.error('Needs exactly 3 arguments (input json, output index, output metadata).');
process.exit(1);
}
@ -44,7 +44,7 @@ lunr.tokenizer.separator = /(\p{P}|\p{S}|\p{Z}|\p{C})+/u
var idx = lunr(function () {
this.ref('link')
this.field('title', {boost: 9})
this.field('name', {boost: 9})
this.field('tag', {boost: 3})
this.field('text')
@ -56,5 +56,5 @@ var idx = lunr(function () {
fs.writeFileSync(process.argv[3], JSON.stringify(idx), {encoding: 'utf8'})
fs.writeFileSync(process.argv[4], JSON.stringify(
Object.fromEntries(documents.map(x => [x.link, {"title": x.title, "tags": x.tags}]))
Object.fromEntries(documents.map(x => [x.link, {"name": x.name, "tags": x.tags}]))
), {encoding: 'utf8'})

10
scripts/source-timestamps.sh
View file

@ -1,4 +1,4 @@
#!/bin/sh
#!/bin/bash
#
# Copyright (C) 2023 University of Luxembourg
@ -30,13 +30,13 @@ do
find "$1" -type f -name '*.md' | grep -v "$NOT_SOURCE_REGEX" | while read file ; do
fn=`basename "$file"`
dir=`dirname "$file"`
tsfn="$fn.timestamp"
outfn="$fn.metadata.yml"
(
echo "making timestamp in '$dir' for file '$fn' ..." >> "$LOGFILE"
echo "adding timestamp in '$dir' for file '$fn' ..." >> "$LOGFILE"
cd "$dir"
if [ -f "$tsfn" ]
if grep -q -s "^timestamp:" "$outfn"
then echo "... but it already exists; skipping!" >> "$LOGFILE"
else git log -n 1 --pretty=format:%cs -- "$fn" > "$tsfn"
else git log -n 1 --pretty=format:$'timestamp: %cs\n' -- "$fn" >> "$outfn"
fi
)
done

7
templates/head.html
View file

@ -1,12 +1,13 @@
<head>
<meta charset="UTF-8" />
<title>
{{?title}}Page: {{title}}{{/title}}
{{^htag}}
{{?name}}Page: {{name}}{{/name}}
{{/htag}}
{{?htag}}
Category:
{{#htag}}
{{?tag}} » {{tag}}{{/tag}}
{{^tag}}All pages{{/tag}}
{{?name}} » {{name}}{{/name}}
{{/htag}}
{{/htag}}
</title>

2
templates/header.html
View file

@ -10,7 +10,7 @@
Categories:
<ul>
{{#htags}}
<li>{{#.}}<a href="{{href}}">{{^tag}}all{{/tag}}{{?tag}} » {{tag}}{{/tag}}{{/.}}</a></li>
<li><a href="{{href}}">{{#htag}} » {{name}}{{/htag}}</a></li>
{{/htags}}
</ul>
{{/htags}}

11
templates/list.html
View file

@ -4,29 +4,26 @@
<body>
{{> header.html}}
<h1>
{{?htag}}
Category listing:
{{#htag}}
<a href="{{href}}">
{{^tag}}all{{/tag}}
{{?tag}}» {{tag}}{{/tag}}
{{?name}}» {{name}}{{/name}}
</a>
{{/htag}}
{{/htag}}
</h1>
<p>See the <a href="{{taghref}}">hierarchical view of this category</a>.</p>
{{?subtags}}<h3>Sub-categories</h3>
<ul>
{{#subtags}}
<li><a href="{{href}}">{{#tags}} » {{.}} {{/tags}}</a></li>
<li>{{name}} (<a href="{{href}}">{{#htag}} » {{name}} {{/htag}}</a>)</li>
{{/subtags}}
</ul>
{{/subtags}}
{{?pages}}
<h3>Cards</h3>
<h3>Pages</h3>
<ul>
{{#pages}}
<li><a href="{{href}}">{{meta.title}}</a></li>
<li><a href="{{href}}">{{meta.name}}</a></li>
{{/pages}}
</ul>
{{/pages}}

2
templates/searchresults.html
View file

@ -81,7 +81,7 @@
var out = document.createElement("li")
var a = document.createElement("a")
a.className = "search-result"
a.appendChild(document.createTextNode(m.title))
a.appendChild(document.createTextNode(m.name))
a.href = r.ref
out.appendChild(a)
for(var ti=0; ti<m.tags.length; ++ti) {

31
templates/tag.html
View file

@ -4,44 +4,49 @@
<body>
{{> header.html}}
<h1>
Pages in category:
{{#htag}}
<a href="{{href}}">
{{^tag}}all{{/tag}}
{{?tag}}» {{tag}}{{/tag}}
</a>
{{/htag}}
Pages in category:
{{#htag}}
<a href="{{href}}">
{{?name}}» {{name}}{{/name}}
</a>
{{/htag}}
</h1>
<p>See the <a href="{{listhref}}">complete listing of all pages in this category</a>.</p>
<ul>
{{?pages}}
{{#pages}}
<li><a href="{{href}}">{{meta.title}}</a></li>
<li><a href="{{href}}">{{meta.name}}</a></li>
{{/pages}}
{{/pages}}
{{?subtags}}
{{#subtags}}
<li>
<a href="{{href}}">{{#tags}} » {{.}} {{/tags}}</a>
{{name}}
(<a href="{{href}}">{{#htag}} » {{name}} {{/htag}}</a>)
<ul>
{{?pages}}
{{#pages}}
<li><a href="{{href}}">{{meta.title}}</a></li>
<li><a href="{{href}}">{{meta.name}}</a></li>
{{/pages}}
{{/pages}}
{{?subtags}}
{{#subtags}}
<li>
<a href="{{href}}">{{#tags}} » {{.}} {{/tags}}</a>
{{name}}
(<a href="{{href}}">{{#htag}} » {{name}} {{/htag}}</a>)
<ul>
{{?pages}}
{{#pages}}
<li><a href="{{href}}">{{meta.title}}</a></li>
<li><a href="{{href}}">{{meta.name}}</a></li>
{{/pages}}
{{/pages}}
{{?subtags}}
{{#subtags}}
<li><a href="{{href}}">{{#tags}} » {{.}} {{/tags}}</a> (click to expand)</li>
<li>
{{name}}
(<a href="{{href}}">{{#htag}} » {{name}} {{/htag}}</a>,
click to expand)
</li>
{{/subtags}}
{{/subtags}}
</ul>