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

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
commit fee144a3ec
16 changed files with 499 additions and 350 deletions

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

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. optionally several redirect pages and (additions to) category pages.
All markdown files have to contain a YAML header that describes where the page 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 #### YAML header format
##### Required options ##### Required options
- `mount` (string): what should be the canonical URL of the page - `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 ##### Optional
@ -78,12 +82,9 @@ should go and adds a few other formatting options. The whole content of the YAML
search index. search index.
- `toc` (boolean or int, default `3`): if false, no ToC is generated for the - `toc` (boolean or int, default `3`): if false, no ToC is generated for the
page. Otherwise the integer sets the depth of the ToC. page. Otherwise the integer sets the depth of the ToC.
- `timestamp` (string): A description of the "timestamp" for the page, - `order` (integer or string, defaults to `name` and then `mount`): order of
typically the date of the last page modification. For any file, this value is the page in page listings. Negative numbers and zero sort before strings,
also defaulted from `<filename>.timestamp` (e.g., `mypage.md.timestamp`), positive numbers sort after strings.
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)
- `tags` (array of strings): list of `/`-separated hierarchical tags - `tags` (array of strings): list of `/`-separated hierarchical tags
("categories") that are assigned to the page. The page will be listed in the ("categories") that are assigned to the page. The page will be listed in the
category listings accordingly. category listings accordingly.
@ -95,9 +96,12 @@ should go and adds a few other formatting options. The whole content of the YAML
```md ```md
--- ---
mount: /about-something mount: /about-something
title: About something name: About something
order: -1
toc: 2 toc: 2
template: special.html template: special.html
tags:
- stuff/special
--- ---
# A page about something! # A page about something!
@ -105,6 +109,19 @@ template: special.html
Lorem ipsum etc., as usual. 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 ### Template syntax
Reploy uses the "simple" vanilla 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

View file

@ -20,9 +20,9 @@
-- | Separated-out main types of the deployment scriptage. -- | Separated-out main types of the deployment scriptage.
module Types where module Types where
import AesonUtils
import Control.Monad.Trans.State.Lazy import Control.Monad.Trans.State.Lazy
import qualified Data.ByteString.UTF8 import qualified Data.ByteString.UTF8
import Data.List.NonEmpty (nonEmpty, toList)
import qualified Data.Map as M import qualified Data.Map as M
import qualified Data.Set as S import qualified Data.Set as S
import qualified Data.Yaml as Y import qualified Data.Yaml as Y
@ -45,39 +45,30 @@ makeLenses ''PageInfo
-- | Complete internal state of the deployment process that holds all data -- | Complete internal state of the deployment process that holds all data
data SiteState = data SiteState =
SiteState SiteState
-- | Map of page mounts to `PageInfo` { _pages :: M.Map FilePath PageInfo -- ^ Map of page mounts to `PageInfo`
{ _pages :: M.Map FilePath PageInfo , _redirects :: M.Map FilePath FilePath -- ^ Map of redirects (from -> to)
-- | Map of redirects (from -> to) , _htags :: M.Map [String] [FilePath] -- ^ Map of tags, assigning to each tag sequence a list of tagged page mounts
, _redirects :: M.Map FilePath FilePath , _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).
-- | Map of tags, assigning to each tag sequence a list of , _tagMeta :: M.Map [String] Y.Value -- ^ Map of tags to expanded human-friendly names
-- tagged page mounts , _installs :: S.Set (String, FilePath) -- ^ List of copy-installed files (among other, this enables sharing)
, _htags :: M.Map [String] [FilePath] , _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)
-- | Map of tags, assigning to each tag sequence a list of tagged page , _templates :: M.Map FilePath Mu.Template -- ^ Map of Mustache templates organized by template search path (within the template directory)
-- 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
, _outputDir :: FilePath -- ^ Directory for output , _outputDir :: FilePath -- ^ Directory for output
, _searchDataOut :: Maybe FilePath -- ^ File to write the searchable versions of pages to (as JSON) , _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 , _sourceDirs :: [FilePath] -- ^ Path to page source data
, _notSourceDirs :: [FilePath] -- ^ Subdirectories of source dirs where pages should not be sourced , _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 , _templateDir :: FilePath -- ^ Path to template directory
, _defaultTemplate :: FilePath -- ^ Name of the default template , _defaultTemplate :: FilePath -- ^ Name of the default template
, _redirectTemplate :: FilePath -- ^ Name of the template for redirect pages , _redirectTemplate :: FilePath -- ^ Name of the template for redirect pages
, _tagTemplate :: FilePath -- ^ Name of the template for category pages , _tagTemplate :: FilePath -- ^ Name of the template for category pages
, _listTemplate :: FilePath -- ^ Name of the template for listing pages , _listTemplate :: FilePath -- ^ Name of the template for listing pages
, _extraMeta :: [(String, Y.Value)] -- ^ Extra metadata added to rendering of all templates , _extraMeta :: 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. , _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. , _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. , _dumpFinalState :: Bool -- ^ Triggers printing out the structure when the processing finishes.
} }
deriving (Show) deriving (Show)
@ -101,23 +92,26 @@ siteOptions' = do
long "search-data-output" <> long "search-data-output" <>
help "Output JSON with searchable page data to this file") <|> help "Output JSON with searchable page data to this file") <|>
pure Nothing pure Nothing
_assetDir <- _assetDirs <-
strOption $ many . strOption $
long "assets" <> long "assets" <>
short 'a' <> short 'a' <>
help "Assets directory to be copied verbatim" <> help "Assets directory to be copied verbatim (possibly multiple paths)"
value "assets" <> showDefault
_sourceDirs <- _sourceDirs <-
fmap (maybe ["pages"] toList . nonEmpty) . many . strOption $ many . strOption $
long "source-directory" <> long "source-directory" <>
short 's' <> short 's' <>
help help "Path to the directory with source data (possibly multiple paths)"
"Path to the directory with source data (possibly multiple paths, defaults to a single directory \"pages\")"
_notSourceDirs <- _notSourceDirs <-
fmap (maybe ["assets"] toList . nonEmpty) . many . strOption $ many . strOption $
long "exclude-source-directory" <> long "exclude-source-directory" <>
help 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 <- _templateDir <-
strOption $ strOption $
long "template-directory" <> long "template-directory" <>
@ -126,7 +120,7 @@ siteOptions' = do
_defaultTemplate <- _defaultTemplate <-
strOption $ strOption $
long "default-template" <> 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 value "default.html" <> showDefault
_redirectTemplate <- _redirectTemplate <-
strOption $ strOption $
@ -143,30 +137,33 @@ siteOptions' = do
long "list-template" <> long "list-template" <>
help "Template for making tag-listing pages" <> help "Template for making tag-listing pages" <>
value "list.html" <> showDefault value "list.html" <> showDefault
_timestampSuffix <- _metadataSuffix <-
strOption $ strOption $
long "timestamp-prefix" <> long "metadata-suffix" <>
help "Timestamp file suffix for markdowns" <> help
value ".timestamp" <> showDefault "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 <- _extraMeta <-
let processKeyVal :: String -> (String, Y.Value) let processKeyVal :: String -> Y.Value
processKeyVal opt = processKeyVal opt =
case break (== ':') opt of case Y.decodeEither' $ Data.ByteString.UTF8.fromString opt of
(k, ':':v) -> Right v -> v
case Y.decodeEither' $ Data.ByteString.UTF8.fromString v of Left err ->
Right v -> (k, v :: Y.Value) error $
Left err -> "cannot parse YAML in --extra-metadata: " ++
error $ Y.prettyPrintParseException err
"cannot parse key:val in --extra-metadata: " ++ show err in fmap (foldl objMerge Y.Null . map processKeyVal) . many . strOption $
_ -> error "cannot process key:val in --extra-metadata"
in fmap (map processKeyVal) . many . strOption $
long "extra-metadata" <> long "extra-metadata" <>
help 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 <- _urlBase <-
strOption $ strOption $
long "url-base" <> long "url-base" <>
short 'u' <> help "Base absolute URL" <> value "/" <> showDefault short 'u' <> help "Base absolute URL" <> value "/" <> showDefault
_indexFile <-
strOption $
long "index-filename" <>
help "Base absolute URL" <> value "index.html" <> showDefault
_appendUrlIndex <- _appendUrlIndex <-
switch $ switch $
long "append-url-index" <> long "append-url-index" <>
@ -183,7 +180,7 @@ siteOptions' = do
, _redirects = M.empty , _redirects = M.empty
, _htags = M.empty , _htags = M.empty
, _ehtags = M.empty , _ehtags = M.empty
, _tagNames = M.empty , _tagMeta = M.empty
, _installs = S.empty , _installs = S.empty
, _targets = S.empty , _targets = S.empty
, _templates = M.empty , _templates = M.empty

View file

@ -22,12 +22,13 @@ import Control.Monad.IO.Class
import Data.List.Extra (stripSuffix) import Data.List.Extra (stripSuffix)
import Data.Maybe (isJust) import Data.Maybe (isJust)
import qualified Data.Text as T import qualified Data.Text as T
import Lens.Micro.Mtl
import System.Directory import System.Directory
( createDirectoryIfMissing ( createDirectoryIfMissing
, doesDirectoryExist , doesDirectoryExist
, getDirectoryContents , getDirectoryContents
) )
import System.FilePath ((</>), takeDirectory) import System.FilePath ((</>), splitDirectories, takeDirectory)
import Text.Pandoc.Definition import Text.Pandoc.Definition
import qualified Text.Pandoc.Walk import qualified Text.Pandoc.Walk
import Types import Types
@ -116,6 +117,24 @@ getRecursiveContents ignore top = go ""
else return [rel] else return [rel]
return $ concat paths 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 -- | Given a path to a file, try to make the path writable by making all
-- directories on the path. (Interned from Hakyll.) -- directories on the path. (Interned from Hakyll.)
makeDirectories :: FilePath -> IO () makeDirectories :: FilePath -> IO ()

View file

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

View file

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

View file

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

399
reploy.hs
View file

@ -14,22 +14,21 @@
- under the License. - under the License.
-} -}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
-- | The main site deployment executable. -- | The main site deployment executable module.
module Main where module Main where
import Control.Monad ((>=>), filterM, join, unless, when) import Control.Monad ((>=>), join, unless, when)
import Control.Monad.Extra (ifM, whenM) import Control.Monad.Extra (whenM)
import Control.Monad.Trans.State.Lazy import Control.Monad.Trans.State.Lazy
import qualified Data.Aeson as AE import qualified Data.Aeson as AE
import qualified Data.Aeson.Key as K import qualified Data.Aeson.Key as K
import qualified Data.Aeson.KeyMap as KM import qualified Data.Aeson.KeyMap as KM
import Data.Bool (bool)
import qualified Data.ByteString.Lazy as B import qualified Data.ByteString.Lazy as B
import Data.Digest.Pure.SHA (sha256, showDigest) import Data.Digest.Pure.SHA (sha256, showDigest)
import Data.Foldable (traverse_) import Data.Foldable (traverse_)
import Data.List (inits, nub, sort) import Data.List (inits, nub, sort)
import Data.List.Extra (groupSort)
import qualified Data.Map as M import qualified Data.Map as M
import qualified Data.Scientific import qualified Data.Scientific
import qualified Data.Set as S import qualified Data.Set as S
@ -47,9 +46,7 @@ import System.FilePath
( (</>) ( (</>)
, isAbsolute , isAbsolute
, joinPath , joinPath
, splitDirectories
, splitFileName , splitFileName
, splitPath
, takeDirectory , takeDirectory
, takeFileName , takeFileName
) )
@ -63,23 +60,19 @@ import Text.Pandoc.Writers.HTML (writeHtml5String)
import Text.Pandoc.Writers.Shared (toTableOfContents) import Text.Pandoc.Writers.Shared (toTableOfContents)
import qualified Text.Parsec.Error import qualified Text.Parsec.Error
import AesonUtils
import FormatOpts import FormatOpts
import Tags
import Types import Types
import Utils 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`. -- | Load the pages from a directory and add them to `pages`.
sourcePages :: FilePath -> Site () sourcePages :: FilePath -> Site ()
sourcePages fp = sourcePages fp = sourcePaths fp go
(io $ getRecursiveContents (pure . const False) fp) >>= where
filterM isSourceablePath >>= go p
traverse_ (loadPage . (fp </>)) | hasSuffix ".md" (takeFileName p) = loadPage (fp </> p)
| otherwise = pure ()
{- | Extract `PageInfo` about a single page and save it into `pages` in {- | Extract `PageInfo` about a single page and save it into `pages` in
- `SiteState`. -} - `SiteState`. -}
@ -147,7 +140,8 @@ sourceTemplates templdir = do
indexFilename :: FilePath -> Site FilePath indexFilename :: FilePath -> Site FilePath
indexFilename mount = do indexFilename mount = do
od <- use outputDir 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 -- | Check that the page was not rendered before, and add it to the rendered set
checkTarget :: FilePath -> Site () checkTarget :: FilePath -> Site ()
@ -157,22 +151,31 @@ checkTarget fp = do
then error $ "colliding renders for page: " ++ fp then error $ "colliding renders for page: " ++ fp
else targets %= S.insert fp else targets %= S.insert fp
-- | Prepend the root path to the given link -- | Conjure a function that transforms absolute links to pages to full rooted
rootUrl' :: FilePath -> FilePath -> FilePath -- URLs.
rootUrl' root = (root </>) . unAbsolute 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 -- | Transform a link to page to a full rooted URL
rootUrl :: FilePath -> Site FilePath rootedPageLink :: FilePath -> Site FilePath
rootUrl fp = flip rootUrl' fp <$> use urlBase rootedPageLink = (<*>) rootedPageLink' . pure
-- | Like `rootUrl'` but also appends @index.html@ for systems that don't have -- | Conjure a function that transforms absolute links to files to rooted URLs.
-- working directory indexes. rootedLink' :: Site (FilePath -> FilePath)
rootPageUrl' :: FilePath -> Bool -> FilePath -> FilePath rootedLink' = do
rootPageUrl' root index fp = bool id (</> "index.html") index $ rootUrl' root fp ub <- use urlBase
pure (ub </>)
-- | Convenient version of `rootPageUrl'` -- | Transform a link to file to a rooted URL.
rootPageUrl :: FilePath -> Site FilePath rootedLink :: FilePath -> Site FilePath
rootPageUrl fp = rootPageUrl' <$> use urlBase <*> use appendUrlIndex <*> pure fp rootedLink = (<*>) rootedLink' . pure
-- | Process a single link pointing out from a page. -- | Process a single link pointing out from a page.
processLink :: FilePath -> FilePath -> Site String processLink :: FilePath -> FilePath -> Site String
@ -181,67 +184,65 @@ processLink base l =
"#" "#"
then pure l then pure l
else if isAbsolute l else if isAbsolute l
then rootPageUrl l then rootedPageLink l
else installFile (base </> l) >>= rootUrl else installFile (base </> l) >>= rootedLink
-- | 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 -- | Like `Mu.substitute` but writes (and eventually should throw) stuff on errors
checkedSubstitute :: Mu.Template -> MT.Value -> IO T.Text checkedSubstitute :: Mu.Template -> MT.Value -> IO T.Text
checkedSubstitute t v = do checkedSubstitute t v = do
let (es, txt) = Mu.checkedSubstitute t v let (es, txt) = Mu.checkedSubstitute t v
traverse_ (putStrLn . ("Error: " ++) . show) es traverse_ (putStrLn . ("Error: " ++) . show) es
--null es `unless` error "template substitution problems" null es `unless` error "template substitution problems!"
pure txt pure txt
-- | Add global information to page metadata for rendering (at this point just the url base) -- | Add global information to page metadata for rendering (at this point just the url base)
addGlobalMeta :: Y.Value -> Site MT.Value addGlobalMeta :: Y.Value -> Site MT.Value
addGlobalMeta (Y.Object m) = do addGlobalMeta (Y.Object m) = do
r <- use urlBase r <- use urlBase
i <- use appendUrlIndex rt <- rootedLink'
em <- use extraMeta rtp <- rootedPageLink'
let l = map (\(k, v) -> (K.toText k, Mu.toMustache v)) $ KM.toList m 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) [ ("root", Mu.toMustache $ T.pack r)
, ("rawRootUrl", Mu.overText $ T.pack . rootUrl' r . T.unpack) , ("rawRootUrl", Mu.overText $ T.pack . rt . T.unpack)
, ("pageLink", Mu.overText $ T.pack . rootPageUrl' r i . T.unpack) , ("pageLink", Mu.overText $ T.pack . rtp . T.unpack)
] ]
-- | Get the expected timestamp file for a given filepath -- | Get the expected timestamp file for a given filepath
timestampFile :: FilePath -> Site FilePath metadataFile :: FilePath -> Site FilePath
timestampFile fp = do metadataFile fp = do
sfx <- use timestampSuffix sfx <- use metadataSuffix
pure . uncurry (</>) . fmap (++ sfx) . splitFileName $ fp pure . uncurry (</>) . fmap (++ sfx) . splitFileName $ fp
-- | If a timestamp file for the page exists, add the timestamp metadata. -- | If an extra-metadata file exists, patch it over the current metadata.
addTimeMeta :: PageInfo -> Y.Value -> Site Y.Value addExtraMeta :: PageInfo -> Y.Value -> Site Y.Value
addTimeMeta pi m'@(Y.Object m) addExtraMeta pi m = do
| "timestamp" `KM.member` m = pure m' -- do not overwrite the timestamp if present metaPath <- metadataFile $ pi ^. pagePath
| otherwise = do metaExists <- io $ doesFileExist metaPath
tspath <- timestampFile $ pi ^. pagePath gem <- use extraMeta
io $ objMerge gem <$>
ifM if metaExists
(doesFileExist tspath) then do
(do putStrLn $ "timestamp <- " ++ tspath em' <- io $ Y.decodeFileEither metaPath
ts <- Y.String <$> TIO.readFile tspath case em' of
pure . Y.Object $ KM.insert "timestamp" ts m) Left pe ->
(pure m') 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 -- | 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 -- expands the tags for rendering and continues by adding extra metadata via
-- and possibly other info sourced right here. -- `addExtraMeta`.
addPageMeta :: PageInfo -> Y.Value -> Site Y.Value addPageMeta :: PageInfo -> Y.Value -> Site Y.Value
addPageMeta pi (Y.Object m) = do addPageMeta pi (Y.Object m) = do
htagMeta <- htagMeta <-
traverse (makeHTagMeta tagLink) . sort $ pi ^.. pageMeta . key "tags" . traverse (htagRenderMeta tagLink) . sort $ pi ^.. pageMeta . key "tags" .
values . values .
_String . _String .
to T.unpack . to T.unpack .
to splitDirectories to splitTag
addTimeMeta pi . Y.Object $ KM.insert "htags" (Y.array htagMeta) m addExtraMeta pi . Y.Object $ KM.insert "htags" (Y.array htagMeta) m
-- | If viable for a page (by config), add the TOC field -- | If viable for a page (by config), add the TOC field
addTOC :: PageInfo -> Text.Pandoc.Definition.Pandoc -> Y.Value -> Site Y.Value addTOC :: PageInfo -> Text.Pandoc.Definition.Pandoc -> Y.Value -> Site Y.Value
@ -263,7 +264,7 @@ installPage :: FilePath -> PageInfo -> Site ()
installPage mount pi = do installPage mount pi = do
tname <- pageTemplate pi tname <- pageTemplate pi
templ <- use $ templates . to (M.! fromString tname) templ <- use $ templates . to (M.! fromString tname)
file <- pageFilename mount file <- indexFilename mount
fixedUrlDoc <- fixedUrlDoc <-
walkURLs (processLink $ pi ^. pagePath . to takeDirectory) $ pi ^. pageDoc walkURLs (processLink $ pi ^. pagePath . to takeDirectory) $ pi ^. pageDoc
checkTarget file checkTarget file
@ -282,7 +283,7 @@ installPage mount pi = do
{- | Install a simple redirect handler page. -} {- | Install a simple redirect handler page. -}
installRedirect :: FilePath -> FilePath -> Site () installRedirect :: FilePath -> FilePath -> Site ()
installRedirect target' from = do installRedirect target' from = do
target <- rootPageUrl target' target <- rootedPageLink target'
tname <- use redirectTemplate tname <- use redirectTemplate
templ <- use $ templates . to (M.! fromString tname) templ <- use $ templates . to (M.! fromString tname)
file <- indexFilename from file <- indexFilename from
@ -333,231 +334,123 @@ installFile fp = do
copy fp file copy fp file
pure loc pure loc
-- | Simply copy a strictly named asset. -- | Simply copy an explicitly named asset in the given asset dir
installAsset :: FilePath -> Site () installAsset :: FilePath -> FilePath -> Site ()
installAsset fp = do installAsset ad fp = do
od <- use outputDir od <- use outputDir
ad <- use assetDir
let [src, dst] = map (</> fp) [ad, od] let [src, dst] = map (</> fp) [ad, od]
checkTarget dst checkTarget dst
io $ do io $ do
putStrLn $ "A -> " ++ src ++ " -> " ++ dst putStrLn $ "A " ++ src ++ " -> " ++ dst
copy 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 :: Site ()
installAssets = installAssets = use assetDirs >>= traverse_ installAssetDir
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. -- | Get the destination for the tag page.
tagFilename :: FilePath -> Site FilePath tagFilename :: [String] -> Site FilePath
tagFilename tag = indexFilename $ "tag" </> tag tagFilename = indexFilename . joinPath . ("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 -- | Make a link to the tag page
tagLink :: [String] -> Site FilePath tagLink :: [String] -> Site FilePath
tagLink = rootPageUrl . ("tag" </>) . tagPath tagLink = rootedPageLink . joinPath . ("tag" :)
-- | Fold the hierarchical tag bits to a slashed path. -- | Get the destination for the tag page.
listPath :: [String] -> FilePath listFilename :: [String] -> Site FilePath
listPath = joinPath listFilename = indexFilename . joinPath . ("list" :)
-- | Make a link to the tag page -- | Make a link to the tag page
listLink :: [String] -> Site FilePath listLink :: [String] -> Site FilePath
listLink = rootPageUrl . ("list" </>) . listPath listLink = rootedPageLink . joinPath . ("list" :)
-- | 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 -- | Make metadata for printing out a link to a page
makePageLinkMeta :: FilePath -> Site Y.Value makePageLinkRenderMeta :: FilePath -> Site Y.Value
makePageLinkMeta mount = do makePageLinkRenderMeta mount = do
link <- rootPageUrl mount link <- rootedPageLink mount
meta <- use $ pages . to (M.! mount) . pageMeta 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 $ pure $
Y.object Y.object
[ ("href", fromString link) [("mount", fromString mount), ("href", fromString link), ("meta", meta)]
, ("tags", tags)
, ("htag", htagMeta)
, ("subtags", subtagsMeta)
, ("pages", pagesMeta)
, ("listhref", fromString listlink)
]
-- | Create the complete metadata structure for the template that renders a given categorical tag pages wrapPagesMeta :: Y.Value -> String -> FilePath -> Y.Value
makeTagMeta :: [String] -> Site MT.Value wrapPagesMeta x linkname link =
makeTagMeta tag = makeTagMeta' tag >>= addGlobalMeta Y.object [("pages", x), (fromString linkname, fromString link)]
-- | Make metadata for printing out a single tag as-is, without levels makeTagRenderMeta :: [String] -> Site Y.Value
makeHTagLinkMeta :: [String] -> Site Y.Value makeTagRenderMeta = htagRenderMetaWithSubtags tagLink extra makeTagRenderMeta
makeHTagLinkMeta tag = do where
link <- listLink tag extra htag = do
tags <- Y.array . map fromString <$> traverse getTagName tag meta <- exactlyTaggedPagesRenderMeta makePageLinkRenderMeta htag
pure $ Y.object [("href", fromString link), ("tags", tags)] wrapPagesMeta meta "listhref" <$> listLink htag
-- | Create the structure for rendering a complete listing of one hierarchical tag. makeListRenderMeta :: [String] -> Site Y.Value
makeListMeta :: [String] -> Site MT.Value makeListRenderMeta =
makeListMeta tag = do htagRenderMetaWithSubtags
taggedPages <- use $ ehtags . to (M.! tag) listLink
subtags <- pr
gets (htagRenderMetaWithSubtags
(^.. ehtags . to M.keys . each . filtered (not . null) . listLink
filtered ((== tag) . init)) (const $ pure (Y.object []))
htagMeta <- makeHTagMeta listLink tag (const $ pure Y.Null))
subtagsMeta <- Y.array <$> traverse makeHTagLinkMeta subtags where
pagesMeta <- Y.array <$> traverse makePageLinkMeta taggedPages pr htag = do
tl <- tagLink tag meta <- allTaggedPagesRenderMeta makePageLinkRenderMeta htag
addGlobalMeta $ wrapPagesMeta meta "taghref" <$> tagLink htag
Y.object
[ ("htag", htagMeta)
, ("subtags", subtagsMeta)
, ("pages", pagesMeta)
, ("taghref", fromString tl)
]
-- | Render a site for a given tag string. -- | Parametrized render of a listing-style site.
renderTag :: [String] -> Site () renderListing ::
renderTag tag = do String
tname <- use tagTemplate -> ([String] -> Site FilePath)
templ <- use $ templates . to (M.! fromString tname) -> ([String] -> Site MT.Value)
file <- tagFilename (tagPath tag) -> String
-> [String]
-> Site ()
renderListing templName fileName makeMeta mark htag = do
templ <- (M.! fromString templName) <$> use templates
file <- fileName htag
checkTarget file checkTarget file
meta <- makeTagMeta tag meta <- makeMeta htag
io $ do io $ do
putStrLn $ "# -> " ++ file putStrLn $ (mark ++ " -> " ++ file)
makeDirectories file makeDirectories file
checkedSubstitute templ meta >>= TIO.writeFile file checkedSubstitute templ meta >>= TIO.writeFile file
-- | Render all tag sites. renderTags = do
renderTags :: Site () lt <- use tagTemplate
renderTags = use (ehtags . to M.keys) >>= traverse_ renderTag M.keys <$> use ehtags >>=
traverse_
(renderListing lt tagFilename (makeTagRenderMeta >=> addGlobalMeta) "#")
-- | Render a site for a given tag string. renderLists = do
renderList :: [String] -> Site () lt <- use listTemplate
renderList tag = do M.keys <$> use ehtags >>=
tname <- use listTemplate traverse_
templ <- use $ templates . to (M.! fromString tname) (renderListing lt listFilename (makeListRenderMeta >=> addGlobalMeta) "*")
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 -- | Transform one mounted PageInfo to the base search data
mkSearchData :: FilePath -> PageInfo -> Site [Y.Value] makeSearchData :: FilePath -> PageInfo -> Site [Y.Value]
mkSearchData mount pi = do makeSearchData mount pi = do
link <- rootPageUrl mount link <- rootedPageLink mount
text <- io . runIOorExplode $ writePlain plainWriteOpts (pi ^. pageDoc) text <- io . runIOorExplode $ writePlain plainWriteOpts (pi ^. pageDoc)
let title = pi ^? pageMeta . key "title" . _String let name = pi ^? pageMeta . key "name" . _String
-- TODO: unify retrieval of tags -- TODO: unify retrieval of tags?
let tags = let tags =
sort $ pi ^.. pageMeta . key "tags" . values . _String . to T.unpack 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 let tagarray = Y.array . map (Y.array . map fromString) $ tagnames
if pi ^? pageMeta . key "search" . _Bool == Just False -- `off` gets parsed as bool if pi ^? pageMeta . key "search" . _Bool == Just False -- `off` gets parsed as bool
then pure [] then pure []
else pure $ else pure $
[ Y.object [ Y.object
[ ("link", fromString link) [ ("link", fromString link)
, ("title", maybe (fromString mount) Y.String title) , ("name", maybe (fromString mount) Y.String name)
, ("tags", tagarray) , ("tags", tagarray)
, ("text", Y.String text) , ("text", Y.String text)
] ]
@ -568,7 +461,7 @@ renderSearchData :: Site ()
renderSearchData = use searchDataOut >>= traverse_ go renderSearchData = use searchDataOut >>= traverse_ go
where where
go out = do go out = do
ps <- use (pages . to M.assocs) >>= traverse (uncurry mkSearchData) ps <- use (pages . to M.assocs) >>= traverse (uncurry makeSearchData)
io $ do io $ do
putStrLn $ "S -> " ++ out putStrLn $ "S -> " ++ out
AE.encodeFile out $ Y.array (concat ps) AE.encodeFile out $ Y.array (concat ps)
@ -579,7 +472,7 @@ main = do
flip runStateT init $ do flip runStateT init $ do
installAssets installAssets
use sourceDirs >>= traverse sourcePages use sourceDirs >>= traverse sourcePages
use sourceDirs >>= traverse sourceTagnames use sourceDirs >>= traverse sourceTagMeta
sourceTags sourceTags
use templateDir >>= sourceTemplates use templateDir >>= sourceTemplates
use pages >>= traverse (uncurry installPage) . M.assocs use pages >>= traverse (uncurry installPage) . M.assocs

View file

@ -34,7 +34,7 @@ lunr = require("lunr")
fs = require("fs") fs = require("fs")
if(process.argv.length !== 5) { 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); process.exit(1);
} }
@ -44,7 +44,7 @@ lunr.tokenizer.separator = /(\p{P}|\p{S}|\p{Z}|\p{C})+/u
var idx = lunr(function () { var idx = lunr(function () {
this.ref('link') this.ref('link')
this.field('title', {boost: 9}) this.field('name', {boost: 9})
this.field('tag', {boost: 3}) this.field('tag', {boost: 3})
this.field('text') 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[3], JSON.stringify(idx), {encoding: 'utf8'})
fs.writeFileSync(process.argv[4], JSON.stringify( 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'}) ), {encoding: 'utf8'})

View file

@ -1,4 +1,4 @@
#!/bin/sh #!/bin/bash
# #
# Copyright (C) 2023 University of Luxembourg # 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 find "$1" -type f -name '*.md' | grep -v "$NOT_SOURCE_REGEX" | while read file ; do
fn=`basename "$file"` fn=`basename "$file"`
dir=`dirname "$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" cd "$dir"
if [ -f "$tsfn" ] if grep -q -s "^timestamp:" "$outfn"
then echo "... but it already exists; skipping!" >> "$LOGFILE" 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 fi
) )
done done

View file

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

View file

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

View file

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

View file

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

View file

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