From 5304dd384c12280ba5e920905cc84e877f2df8d2 Mon Sep 17 00:00:00 2001 From: Mirek Kratochvil Date: Fri, 13 Oct 2023 20:45:36 +0200 Subject: [PATCH 01/11] generalize the options a bit, allow assets from multiple directories --- Types.hs | 21 +++++++++------------ reploy.cabal | 2 +- reploy.hs | 21 ++++++++++++--------- 3 files changed, 22 insertions(+), 22 deletions(-) diff --git a/Types.hs b/Types.hs index 17be93e..74bfec3 100644 --- a/Types.hs +++ b/Types.hs @@ -22,7 +22,6 @@ module Types where 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 @@ -66,7 +65,7 @@ data SiteState = , _templates :: M.Map FilePath Mu.Template , _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 , _templateDir :: FilePath -- ^ Path to template directory @@ -101,23 +100,21 @@ 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)" _templateDir <- strOption $ long "template-directory" <> @@ -126,7 +123,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 $ diff --git a/reploy.cabal b/reploy.cabal index a518163..d6656ae 100644 --- a/reploy.cabal +++ b/reploy.cabal @@ -3,7 +3,7 @@ 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 diff --git a/reploy.hs b/reploy.hs index ca1b663..3a7e6a8 100644 --- a/reploy.hs +++ b/reploy.hs @@ -18,7 +18,7 @@ -- | The main site deployment executable. module Main where -import Control.Monad ((>=>), filterM, join, unless, when) +import Control.Monad (filterM, join, unless, when) import Control.Monad.Extra (ifM, whenM) import Control.Monad.Trans.State.Lazy import qualified Data.Aeson as AE @@ -333,22 +333,25 @@ 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 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) +installAssets = use assetdirs >>= traverse installAssetDir -- | Load tag names from a directory and add them to `tagNames`. sourceTagnames :: FilePath -> Site () From 711ae4d941c2e085260f062f737d3f89b6a5ef4d Mon Sep 17 00:00:00 2001 From: Mirek Kratochvil Date: Fri, 13 Oct 2023 20:47:09 +0200 Subject: [PATCH 02/11] it is a suffix not prefix --- Types.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Types.hs b/Types.hs index 74bfec3..6e83304 100644 --- a/Types.hs +++ b/Types.hs @@ -142,7 +142,7 @@ siteOptions' = do value "list.html" <> showDefault _timestampSuffix <- strOption $ - long "timestamp-prefix" <> + long "timestamp-suffix" <> help "Timestamp file suffix for markdowns" <> value ".timestamp" <> showDefault _extraMeta <- From eeb4696a91788a560d6097472099a658ad9918d4 Mon Sep 17 00:00:00 2001 From: Mirek Kratochvil Date: Fri, 13 Oct 2023 22:37:09 +0200 Subject: [PATCH 03/11] implement ingesting the extra metadata from files, reorganize a bit --- AesonUtils.hs | 25 +++++++++++++++++++++++++ Types.hs | 32 +++++++++++++++----------------- reploy.cabal | 2 +- reploy.hs | 48 ++++++++++++++++++++++++------------------------ 4 files changed, 65 insertions(+), 42 deletions(-) create mode 100644 AesonUtils.hs diff --git a/AesonUtils.hs b/AesonUtils.hs new file mode 100644 index 0000000..f7b19ad --- /dev/null +++ b/AesonUtils.hs @@ -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 diff --git a/Types.hs b/Types.hs index 6e83304..4e1e037 100644 --- a/Types.hs +++ b/Types.hs @@ -29,6 +29,7 @@ import Lens.Micro.TH import Options.Applicative import qualified Text.Mustache as Mu import qualified Text.Pandoc.Definition +import AesonUtils -- | Information about a single deployed page (with metadata etc). data PageInfo = @@ -73,8 +74,8 @@ data SiteState = , _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. , _urlBase :: FilePath -- ^ "Root route" to prepend to all absolute links. , _appendUrlIndex :: Bool -- ^ Append full @index.html@ to all page URLs , _dumpFinalState :: Bool -- ^ Triggers printing out the structure when the processing finishes. @@ -140,26 +141,23 @@ siteOptions' = do long "list-template" <> help "Template for making tag-listing pages" <> value "list.html" <> showDefault - _timestampSuffix <- + _metadataSuffix <- strOption $ - long "timestamp-suffix" <> - 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 overriden by metadata specified directly in the markdown header." <> + 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) - 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 $ + case Y.decodeEither' $ Data.ByteString.UTF8.fromString opt of + Right v -> v + Left err -> + error $ + "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:'. 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" <> diff --git a/reploy.cabal b/reploy.cabal index d6656ae..7e92364 100644 --- a/reploy.cabal +++ b/reploy.cabal @@ -10,7 +10,7 @@ license-file: LICENSE executable reploy main-is: reploy.hs - other-modules: Types, Utils, FormatOpts + other-modules: Types, AesonUtils, Utils, FormatOpts build-depends: base == 4.* , aeson ^>= 2.1 , bytestring diff --git a/reploy.hs b/reploy.hs index 3a7e6a8..caf51d9 100644 --- a/reploy.hs +++ b/reploy.hs @@ -19,7 +19,7 @@ module Main where import Control.Monad (filterM, join, unless, when) -import Control.Monad.Extra (ifM, whenM) +import Control.Monad.Extra (whenM) import Control.Monad.Trans.State.Lazy import qualified Data.Aeson as AE import qualified Data.Aeson.Key as K @@ -66,6 +66,7 @@ import qualified Text.Parsec.Error import FormatOpts import Types import Utils +import AesonUtils -- | Check if a given path should be sourced or not isSourceablePath :: FilePath -> Site Bool @@ -202,37 +203,36 @@ addGlobalMeta :: Y.Value -> Site MT.Value addGlobalMeta (Y.Object m) = do r <- use urlBase i <- use appendUrlIndex - em <- use extraMeta 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) ] -- | 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 <- @@ -241,7 +241,7 @@ addPageMeta pi (Y.Object m) = do _String . to T.unpack . to splitDirectories - 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 addTOC :: PageInfo -> Text.Pandoc.Definition.Pandoc -> Y.Value -> Site Y.Value @@ -351,7 +351,7 @@ installAssetDir ad = -- | Copy all files from the asset directories. installAssets :: Site () -installAssets = use assetdirs >>= traverse installAssetDir +installAssets = use assetDirs >>= traverse_ installAssetDir -- | Load tag names from a directory and add them to `tagNames`. sourceTagnames :: FilePath -> Site () @@ -370,7 +370,7 @@ sourceTagnameFile fp = do Y.decodeFileEither fp case yml' of Left err -> - error $ "Failed to load tagnames from " ++ fp ++ ": " ++ show err + error $ "Failed to load tagnames from " ++ fp ++ ": " ++ Y.prettyPrintParseException err Right yml -> traverse_ add $ KM.toList (yml :: KM.KeyMap String) where add :: (KM.Key, String) -> Site () add (k, v) = From 402107a237a7039b0aa2028f6c21939e53c98dc4 Mon Sep 17 00:00:00 2001 From: Mirek Kratochvil Date: Sun, 15 Oct 2023 22:22:18 +0200 Subject: [PATCH 04/11] support tag metadata, make much everything nicer --- Tags.hs | 171 ++++++++++++++++++++++ Types.hs | 50 ++++--- Utils.hs | 20 ++- reploy.cabal | 2 +- reploy.hs | 346 +++++++++++++++----------------------------- templates/list.html | 9 +- templates/tag.html | 25 ++-- 7 files changed, 353 insertions(+), 270 deletions(-) create mode 100644 Tags.hs diff --git a/Tags.hs b/Tags.hs new file mode 100644 index 0000000..15d4b89 --- /dev/null +++ b/Tags.hs @@ -0,0 +1,171 @@ +{-# 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) +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 ((), 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 [("title", 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 . (>>= title) . (M.!? htag) <$> use tagMeta + where + title :: Y.Value -> Maybe String + title obj = obj ^? key "title" . _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) + ] + +-- | 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 <$> traverse makePageMeta (maybe [] id $ tagmap M.!? htag) -- TODO sort page listings here + +-- | 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 + subtags <- + filter ((== htag) . init) . filter (not . null) . M.keys <$> use ehtags + {- TODO sort tag listings here -} + em <- extraMeta htag + subtagMetas <- Y.array . filter (/= Y.Null) <$> traverse subtagMeta subtags + pure $ meta `objMerge` Y.object [("subtags", subtagMetas)] `objMerge` em diff --git a/Types.hs b/Types.hs index 4e1e037..e164d00 100644 --- a/Types.hs +++ b/Types.hs @@ -20,6 +20,7 @@ -- | 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 qualified Data.Map as M @@ -29,7 +30,6 @@ import Lens.Micro.TH import Options.Applicative import qualified Text.Mustache as Mu import qualified Text.Pandoc.Definition -import AesonUtils -- | Information about a single deployed page (with metadata etc). data PageInfo = @@ -45,30 +45,20 @@ 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) , _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 @@ -76,8 +66,9 @@ data SiteState = , _listTemplate :: FilePath -- ^ Name of the template for listing pages , _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) @@ -116,6 +107,11 @@ siteOptions' = do long "exclude-source-directory" <> help "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" <> @@ -144,7 +140,8 @@ siteOptions' = do _metadataSuffix <- strOption $ 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 overriden by metadata specified directly in the markdown header." <> + 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 -> Y.Value @@ -153,7 +150,8 @@ siteOptions' = do Right v -> v Left err -> error $ - "cannot parse YAML in --extra-metadata: " ++ Y.prettyPrintParseException err + "cannot parse YAML in --extra-metadata: " ++ + Y.prettyPrintParseException err in fmap (foldl objMerge Y.Null . map processKeyVal) . many . strOption $ long "extra-metadata" <> help @@ -162,6 +160,10 @@ siteOptions' = do 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" <> @@ -178,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 diff --git a/Utils.hs b/Utils.hs index 4426b68..07cc7b2 100644 --- a/Utils.hs +++ b/Utils.hs @@ -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 ((), takeDirectory, splitDirectories) import Text.Pandoc.Definition import qualified Text.Pandoc.Walk import Types @@ -116,6 +117,23 @@ 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 () diff --git a/reploy.cabal b/reploy.cabal index 7e92364..dbf10aa 100644 --- a/reploy.cabal +++ b/reploy.cabal @@ -10,7 +10,7 @@ license-file: LICENSE executable reploy main-is: reploy.hs - other-modules: Types, AesonUtils, Utils, FormatOpts + other-modules: Types, AesonUtils, Utils, Tags, FormatOpts build-depends: base == 4.* , aeson ^>= 2.1 , bytestring diff --git a/reploy.hs b/reploy.hs index caf51d9..3d934f3 100644 --- a/reploy.hs +++ b/reploy.hs @@ -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 ((>=>), 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,24 +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 -import AesonUtils - --- | 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`. -} @@ -148,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 () @@ -158,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 pure (ub ) + else do + idxf <- use indexFile + pure $ \x -> ub x idxf --- | 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 @@ -182,32 +184,28 @@ 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 + rt <- rootedLink' + rtp <- rootedPageLink' let l = map (\(k, v) -> (K.toText k, Mu.toMustache v)) $ KM.toList m pure . Mu.object $ l ++ [ ("root", Mu.toMustache $ T.pack r) - , ("rawRootUrl", Mu.overText $ T.pack . 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 @@ -222,13 +220,16 @@ 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 + 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 and continues by adding extra metadata via @@ -236,11 +237,11 @@ addExtraMeta pi m = do 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 + to splitTag addExtraMeta pi . Y.Object $ KM.insert "htags" (Y.array htagMeta) m -- | If viable for a page (by config), add the TOC field @@ -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 @@ -340,7 +341,7 @@ installAsset ad fp = do 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 a given asset directory. @@ -353,207 +354,96 @@ installAssetDir ad = installAssets :: Site () installAssets = use assetDirs >>= traverse_ installAssetDir --- | 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 ++ ": " ++ Y.prettyPrintParseException err - Right yml -> traverse_ add $ KM.toList (yml :: KM.KeyMap String) - where add :: (KM.Key, String) -> Site () - add (k, v) = - let go (Just ov) = - if v == ov - then Just ov - else error - ("conflicting tag names for tag " ++ K.toString k) - go Nothing = Just v - in tagNames %= M.alter go (K.toString k) - --- | Find the humanized name for a tag piece -getTagName :: String -> Site String -getTagName t = handleEmpty . maybe t id <$> use (tagNames . to (M.!? t)) - where - handleEmpty "" = "all" - handleEmpty x = x - --- | Get all tags from the pages of the site. -sourceTags :: Site () -sourceTags = do - sgat <- - map - (second $ map splitDirectories . - (^.. pageMeta . key "tags" . values . _String . to T.unpack)) . - M.assocs <$> - use pages - ehtags .= M.fromList (invExpandTags sgat) - htags .= M.fromList (invTags sgat) - --- | Organize a list of pages with hierarchical tags to a list with --- hierarchical tags with pages attached; with tags implying parents. -invExpandTags :: [(FilePath, [[String]])] -> [([String], [FilePath])] -invExpandTags x = - map (fmap nub) $ groupSort [(t, p) | (p, htl) <- x, ht <- htl, t <- inits ht] - --- | Like `invExpandTags` but without the expansion. -invTags :: [(FilePath, [[String]])] -> [([String], [FilePath])] -invTags x = map (fmap nub) $ groupSort [(t, p) | (p, htl) <- x, t <- htl] - -- | Get the destination for the tag page. -tagFilename :: FilePath -> Site FilePath -tagFilename tag = indexFilename $ "tag" tag - --- | Get the destination for the tag page. -listFilename :: FilePath -> Site FilePath -listFilename tag = indexFilename $ "list" tag - --- | Fold the hierarchical tag bits to a slashed path. -tagPath :: [String] -> FilePath -tagPath = joinPath +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 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 [] @@ -571,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) @@ -582,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 diff --git a/templates/list.html b/templates/list.html index 5ae7db0..8fe58e4 100644 --- a/templates/list.html +++ b/templates/list.html @@ -4,26 +4,23 @@ {{> header.html}}

-{{?htag}} Category listing: {{#htag}} - {{^tag}}all{{/tag}} - {{?tag}}» {{tag}}{{/tag}} + {{?name}}» {{name}}{{/name}} {{/htag}} -{{/htag}}

See the hierarchical view of this category.

{{?subtags}}

Sub-categories

{{/subtags}} {{?pages}} -

Cards

+

Pages

    {{#pages}}
  • {{meta.title}}
    • diff --git a/templates/tag.html b/templates/tag.html index cb79591..8e8fb09 100644 --- a/templates/tag.html +++ b/templates/tag.html @@ -4,13 +4,12 @@ {{> header.html}}

    -Pages in category: -{{#htag}} - - {{^tag}}all{{/tag}} - {{?tag}}» {{tag}}{{/tag}} - -{{/htag}} + Pages in category: + {{#htag}} + + {{?name}}» {{name}}{{/name}} + + {{/htag}}

    See the complete listing of all pages in this category.

      @@ -22,7 +21,8 @@ Pages in category: {{?subtags}} {{#subtags}}
    • - {{#tags}} » {{.}} {{/tags}} + {{name}} + ({{#htag}} » {{name}} {{/htag}})
        {{?pages}} {{#pages}} @@ -32,7 +32,8 @@ Pages in category: {{?subtags}} {{#subtags}}
      • - {{#tags}} » {{.}} {{/tags}} + {{name}} + ({{#htag}} » {{name}} {{/htag}}) From 53aa481aace0a59579846fddba8de41a465654ea Mon Sep 17 00:00:00 2001 From: Mirek Kratochvil Date: Sun, 15 Oct 2023 22:23:03 +0200 Subject: [PATCH 05/11] stop everything on template substitution errors we're not a circus --- reploy.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/reploy.hs b/reploy.hs index 3d934f3..12d7a57 100644 --- a/reploy.hs +++ b/reploy.hs @@ -192,7 +192,7 @@ 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) From 1f2ab58478925481d5cf273d38e30fc06e96e69e Mon Sep 17 00:00:00 2001 From: Mirek Kratochvil Date: Sun, 15 Oct 2023 23:06:59 +0200 Subject: [PATCH 06/11] stabilize and parametrize sorting of stuff, get rid of "title" --- Tags.hs | 44 +++++++++++++++++++++++++++++++++---------- Utils.hs | 5 +++-- pages/index.md | 2 +- pages/search.md | 2 +- reploy.hs | 6 +++--- templates/head.html | 7 ++++--- templates/header.html | 2 +- templates/list.html | 2 +- templates/tag.html | 6 +++--- 9 files changed, 51 insertions(+), 25 deletions(-) diff --git a/Tags.hs b/Tags.hs index 15d4b89..1a55453 100644 --- a/Tags.hs +++ b/Tags.hs @@ -5,7 +5,7 @@ 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) +import Data.List (inits, nub, sortOn) import Data.List.Extra (groupSort) import qualified Data.Map as M import Data.String (fromString) @@ -14,7 +14,7 @@ import qualified Data.Yaml as Y import Lens.Micro import Lens.Micro.Aeson import Lens.Micro.Mtl -import System.FilePath ((), splitDirectories, takeFileName) +import System.FilePath ((), joinPath, splitDirectories, takeFileName) import AesonUtils import Types @@ -53,7 +53,7 @@ sourceTagMetaFile fp = do kx = splitTag ks v | Y.String t <- v' = - Y.Object $ KM.fromList [("title", Y.String t)] + Y.Object $ KM.fromList [("name", Y.String t)] | Y.Object _ <- v' = v' | otherwise = error ("invalid definition of tag " ++ ks ++ " in " ++ fp) @@ -69,10 +69,10 @@ sourceTagMetaFile fp = do -- | Find a good display name for the _last_ hierarchical part of the htag. getTagGroupName :: [String] -> Site String getTagGroupName htag = - handleEmpty . maybe backup id . (>>= title) . (M.!? htag) <$> use tagMeta + handleEmpty . maybe backup id . (>>= name) . (M.!? htag) <$> use tagMeta where - title :: Y.Value -> Maybe String - title obj = obj ^? key "title" . _String . to T.unpack + name :: Y.Value -> Maybe String + name obj = obj ^? key "name" . _String . to T.unpack backup | null htag = "" | null (last htag) = "(unnamed)" @@ -129,6 +129,21 @@ htagRenderMeta makeLink htag = do 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) @@ -136,7 +151,12 @@ genericTaggedPagesRenderMeta :: -> M.Map [String] [FilePath] -> Site Y.Value genericTaggedPagesRenderMeta makePageMeta htag tagmap = - Y.array <$> traverse makePageMeta (maybe [] id $ tagmap M.!? htag) -- TODO sort page listings here + 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). @@ -163,9 +183,13 @@ htagRenderMetaWithSubtags :: -> 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 - {- TODO sort tag listings here -} - em <- extraMeta htag - subtagMetas <- Y.array . filter (/= Y.Null) <$> traverse subtagMeta subtags + 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 diff --git a/Utils.hs b/Utils.hs index 07cc7b2..9c901cc 100644 --- a/Utils.hs +++ b/Utils.hs @@ -28,7 +28,7 @@ import System.Directory , doesDirectoryExist , getDirectoryContents ) -import System.FilePath ((), takeDirectory, splitDirectories) +import System.FilePath ((), splitDirectories, takeDirectory) import Text.Pandoc.Definition import qualified Text.Pandoc.Walk import Types @@ -132,7 +132,8 @@ sourcePaths fp process = do | null ds = False | last ds `elem` notSource = True | otherwise = False - io (getRecursiveContents (pure . ignoreDir . splitDirectories) fp) >>= foldMapM process + 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.) diff --git a/pages/index.md b/pages/index.md index 38a87df..5fedf2c 100644 --- a/pages/index.md +++ b/pages/index.md @@ -2,7 +2,7 @@ mount: / redirects: - also_index -title: Home +name: Home toc: off timestamp: null --- diff --git a/pages/search.md b/pages/search.md index 42713f0..9214e51 100644 --- a/pages/search.md +++ b/pages/search.md @@ -1,6 +1,6 @@ --- mount: /search -title: Search +name: Search template: search.html search: off toc: off diff --git a/reploy.hs b/reploy.hs index 12d7a57..8f1cd73 100644 --- a/reploy.hs +++ b/reploy.hs @@ -439,8 +439,8 @@ 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 getTagGroupName . inits . splitTag) tags @@ -450,7 +450,7 @@ makeSearchData mount pi = do 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) ] diff --git a/templates/head.html b/templates/head.html index 59bbfa0..17fe88d 100644 --- a/templates/head.html +++ b/templates/head.html @@ -1,12 +1,13 @@ - {{?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}} diff --git a/templates/header.html b/templates/header.html index 8fa2cc6..1afc80e 100644 --- a/templates/header.html +++ b/templates/header.html @@ -10,7 +10,7 @@ Categories: {{/htags}} diff --git a/templates/list.html b/templates/list.html index 8fe58e4..4c173f5 100644 --- a/templates/list.html +++ b/templates/list.html @@ -23,7 +23,7 @@

        Pages

        {{/pages}} diff --git a/templates/tag.html b/templates/tag.html index 8e8fb09..600e050 100644 --- a/templates/tag.html +++ b/templates/tag.html @@ -15,7 +15,7 @@
          {{?pages}} {{#pages}} -
        • {{meta.title}}
          • +
        • {{meta.name}}
          • {{/pages}} {{/pages}} {{?subtags}} @@ -26,7 +26,7 @@
            {{?pages}} {{#pages}} -
          • {{meta.title}}
            • +
          • {{meta.name}}
            • {{/pages}} {{/pages}} {{?subtags}} @@ -37,7 +37,7 @@
              {{?pages}} {{#pages}} -
            • {{meta.title}}
              • +
            • {{meta.name}}
              • {{/pages}} {{/pages}} {{?subtags}} From 45a95ef439342b0b5d823ce5d476a22325dc7338 Mon Sep 17 00:00:00 2001 From: Mirek Kratochvil Date: Sun, 15 Oct 2023 23:19:13 +0200 Subject: [PATCH 07/11] switch title to name in search machinery --- scripts/make-search-index.js | 4 ++-- templates/searchresults.html | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/scripts/make-search-index.js b/scripts/make-search-index.js index f923b54..70df953 100644 --- a/scripts/make-search-index.js +++ b/scripts/make-search-index.js @@ -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'}) diff --git a/templates/searchresults.html b/templates/searchresults.html index 5ced869..0077c73 100644 --- a/templates/searchresults.html +++ b/templates/searchresults.html @@ -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 Date: Sun, 15 Oct 2023 23:22:41 +0200 Subject: [PATCH 08/11] add docs --- README.md | 35 ++++++++++++++++++++++++++--------- 1 file changed, 26 insertions(+), 9 deletions(-) diff --git a/README.md b/README.md index 8f09a6e..9d8776e 100644 --- a/README.md +++ b/README.md @@ -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 `.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 From 318d603c51a730a9d55f0f44b2ffff5874cfb5cb Mon Sep 17 00:00:00 2001 From: Mirek Kratochvil Date: Sun, 15 Oct 2023 23:29:19 +0200 Subject: [PATCH 09/11] fixup the timestamp-sourcing script --- scripts/source-timestamps.sh | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/scripts/source-timestamps.sh b/scripts/source-timestamps.sh index 5bce4de..ce30cf9 100755 --- a/scripts/source-timestamps.sh +++ b/scripts/source-timestamps.sh @@ -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 From 4f380f6b801d08fb6499b64f0eb18a8211189acd Mon Sep 17 00:00:00 2001 From: Mirek Kratochvil Date: Mon, 16 Oct 2023 11:31:16 +0200 Subject: [PATCH 10/11] fix reversed append-url-index test --- reploy.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/reploy.hs b/reploy.hs index 8f1cd73..c29a81b 100644 --- a/reploy.hs +++ b/reploy.hs @@ -158,10 +158,10 @@ rootedPageLink' = do ub <- use urlBase app <- use appendUrlIndex if app - then pure (ub ) - else do + then do idxf <- use indexFile pure $ \x -> ub x idxf + else pure (ub ) -- | Transform a link to page to a full rooted URL rootedPageLink :: FilePath -> Site FilePath From 005b69dd472811d7a8e623c3761d476b5584b92c Mon Sep 17 00:00:00 2001 From: Mirek Kratochvil Date: Mon, 16 Oct 2023 11:36:57 +0200 Subject: [PATCH 11/11] fix help string --- scripts/make-search-index.js | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/scripts/make-search-index.js b/scripts/make-search-index.js index 70df953..38ed214 100644 --- a/scripts/make-search-index.js +++ b/scripts/make-search-index.js @@ -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); }