implement ingesting the extra metadata from files, reorganize a bit

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

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:<yaml>'. May be specified multiple times."
+          "Extra metadata to add to pages rendering in YAML format. May be specified multiple times."
   _urlBase <-
     strOption $
     long "url-base" <>

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

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