diff options
| -rw-r--r-- | AesonUtils.hs | 25 | ||||
| -rw-r--r-- | Types.hs | 32 | ||||
| -rw-r--r-- | reploy.cabal | 2 | ||||
| -rw-r--r-- | reploy.hs | 48 |
4 files changed, 65 insertions, 42 deletions
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 @@ -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" <> 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 @@ -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) = |