From f649c90fa34e03e465922db670708ecd7b9695c8 Mon Sep 17 00:00:00 2001 From: Profpatsch Date: Mon, 13 Jan 2025 16:57:04 +0100 Subject: [PATCH] feat(Config): Add json config format option In order to make it easier to generate gitit configuration, we add the ability for config files to be json values in addition to the custom config format parser. This should be 100% backward-compatible, with the error messages being reasonably clear about the fallback mechanism. Json strings, numbers and booleans are supported as-is, and the default section also works (sections are distinguished by their name being in `[brackets]`). Potentially a bit more documentation might be needed. --- data/default.conf | 10 +++ gitit.cabal | 1 + src/Network/Gitit/Config.hs | 128 ++++++++++++++++++++++++++++++++++-- 3 files changed, 133 insertions(+), 6 deletions(-) diff --git a/data/default.conf b/data/default.conf index cd528f994..79e6aa28a 100644 --- a/data/default.conf +++ b/data/default.conf @@ -1,5 +1,15 @@ # gitit wiki configuration file +# NOTE: you can also use a json syntax for configuration files. Create a toplevel object, and nest sections as objects within that object. For example: +# { +# "redirect": "yes", +# "address": "0.0.0.0", +# "[Github]": { +# "oauthclientid": "01239456789abcdef012", +# "oauthclientsecret": "01239456789abcdef01239456789abcdef012394", +# } +# } + address: 0.0.0.0 # sets the IP address on which the web server will listen. diff --git a/gitit.cabal b/gitit.cabal index 4f7da1e9e..b9432d727 100644 --- a/gitit.cabal +++ b/gitit.cabal @@ -157,6 +157,7 @@ Library feed >= 1.0 && < 1.4, xml-types >= 0.3, xss-sanitize >= 0.3 && < 0.4, + scientific >= 0.3 && < 0.4, tagsoup >= 0.13 && < 0.15, blaze-html >= 0.4 && < 0.10, json >= 0.4 && < 0.12, diff --git a/src/Network/Gitit/Config.hs b/src/Network/Gitit/Config.hs index 2fd24e035..7c2e58f97 100644 --- a/src/Network/Gitit/Config.hs +++ b/src/Network/Gitit/Config.hs @@ -1,4 +1,8 @@ {-# LANGUAGE CPP, FlexibleContexts, ScopedTypeVariables, OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE MultiWayIf #-} {- Copyright (C) 2009 John MacFarlane @@ -33,12 +37,23 @@ import Network.Gitit.Util (parsePageType, readFileUTF8) import System.Log.Logger (logM, Priority(..)) import System.IO (hPutStrLn, stderr) import System.Exit (ExitCode(..), exitWith) +import Data.Either (partitionEithers) +import Data.Function ((&)) +import Data.Functor ((<&>)) import qualified Data.Map as M +import qualified Data.Aeson as Json +import qualified Data.Aeson.Key as Key +import qualified Data.Aeson.KeyMap as KeyMap import Data.List (intercalate, foldl') import Data.Char (toLower, toUpper, isAlphaNum) +import qualified Data.Scientific as Scientific import qualified Data.Text as T import Data.Text (Text) import Paths_gitit (getDataFileName) +import qualified Data.Text.Lazy.Builder as T.Builder +import qualified Data.Text.Lazy as T.Lazy +import qualified Data.Text.Lazy.Builder.Int as T.Builder.Int +import qualified Data.Text.Lazy.Builder.Scientific as Scientific import System.FilePath (()) import Text.Pandoc hiding (ERROR, WARNING, MathJax, MathML, WebTeX, getDataFileName) import qualified Control.Exception as E @@ -70,18 +85,64 @@ getConfigFromFiles fnames = do type ConfigMap = M.Map (Text, Text) Text +-- | Parse the config file and return a map from section/field to value. +-- The config file is first checked to see if it’s a valid json value. +-- +-- If yes, use the json parser, otherwise use the old style parser for backwards compatibility. +-- +-- The JSON format mirrors the old style format. +-- Any key that is in the outer object is put into the [DEFAULT] section. +-- Any key that is surrounded by `[` and `]` is a section name, and the keys inside are the fields in the section. +-- +-- Example: +-- +-- @ +-- { +-- "repository-type": "git", +-- "[GitHub]": { +-- "oauthclientid": "clientid", +-- "oauthclientsecret": "client +-- } +-- } +-- @ + alterConfigMap :: ConfigMap -> FilePath -> IO ConfigMap alterConfigMap cfmap fname = do + eJsonVal <- pIsJsonValue fname + secs <- case eJsonVal of + Right val -> + case pSectionJson val of + Left err -> do + hPutStrLn stderr ("Error parsing gitit json config " <> fname <> ":\n" <> err) + exitWith (ExitFailure 1) + Right secs -> pure secs + Left _jsonErr -> do + eSecs <- readOldStyleConfig fname + case eSecs of + Left errOld -> do + hPutStrLn stderr ("Cannot parse " <> fname <> " as valid json value; tried parsing it as old-style gitit config instead but failed:\n" <> errOld) + exitWith (ExitFailure 1) + Right secs -> pure secs + pure $ foldl' go cfmap secs + where + go cfmap' (Section name fields) = foldl' (go' name) cfmap' fields + go' name cfmap' (k,v) = M.insert (name, k) v cfmap' + +readOldStyleConfig :: FilePath -> IO (Either String [Section]) +readOldStyleConfig fname = do contents <- readFileUTF8 fname let contents' = "[DEFAULT]\n" <> contents case parseConfig fname contents' of Left msg -> do - hPutStrLn stderr ("Error parsing config " <> fname <> ":\n" <> msg) - exitWith (ExitFailure 1) - Right secs -> pure $ foldl' go cfmap secs - where - go cfmap' (Section name fields) = foldl' (go' name) cfmap' fields - go' name cfmap' (k,v) = M.insert (name, k) v cfmap' + pure $ Left msg + Right secs -> pure $ Right secs + +pIsJsonValue :: FilePath -> IO (Either String Json.Value) +pIsJsonValue fname = do + mval <- Json.eitherDecodeFileStrict fname + pure $ case mval of + Left err -> Left $ "Could not parse file as syntactically valid json value: " <> err + Right val -> Right val -- | Returns the default gitit configuration. getDefaultConfig :: IO Config @@ -93,6 +154,61 @@ data Section = Section Text [(Text, Text)] parseConfig :: FilePath -> Text -> Either String [Section] parseConfig fname txt = either (Left . show) Right $ parse (many pSection) fname txt +data SectionJson = + DefaultSection Text Text + | ThisSection Text [(Text, Text)] + + +pSectionJson :: Json.Value -> Either String [Section] +pSectionJson (Json.Object obj) = obj & KeyMap.toList + <&> (\case + (asSectionKey -> Just k, v) -> ThisSection (k & Key.toText) <$> pSectionFields k v + (k, asJsonScalarText -> Just t) -> Right $ DefaultSection (k & Key.toText) t + (k, v) -> Left ["The value of field " <> (k & Key.toString) <> " has to be a string, but was: " <> show v] + ) + & partitionEithers + & \case + ([], secs) -> secs & foldr go M.empty & M.toList <&> (\(name, fields) -> Section name fields) & Right + where + go (ThisSection name fields) acc = M.insert name fields acc + go (DefaultSection k v) acc = M.insertWith (++) "DEFAULT" [(k, v)] acc + + (errs, _) -> Left $ intercalate "\n" $ concat errs + where + -- section key starts with [ and ends with ] + asSectionKey k = case Key.toString k of + (x:xs) | x == '[' && (xs & hasEnd ']') -> Just k + _ -> Nothing + hasEnd _ [] = False + hasEnd e xs = last xs == e +pSectionJson _ = Left "The toplevel json value has to be a json object." + +asJsonScalarText :: Json.Value -> Maybe Text +asJsonScalarText (Json.String t) = Just t +asJsonScalarText (Json.Number n) = Just $ T.Lazy.toStrict $ T.Builder.toLazyText formatNumber + where + -- The scientific builder always adds a decimal point, which we don’t want for e.g. port numbers :) + formatNumber = if + | Scientific.isInteger n + , Just i <- Scientific.toBoundedInteger @Int n -> T.Builder.Int.decimal i + | otherwise -> n & Scientific.scientificBuilder +asJsonScalarText (Json.Bool True) = Just "true" +asJsonScalarText (Json.Bool False) = Just "false" +asJsonScalarText _ = Nothing + +pSectionFields :: Json.Key -> Json.Value -> Either [String] [(Text, Text)] +pSectionFields sec (Json.Object obj) = obj + & KeyMap.toList + <&> (\case + (k, asJsonScalarText -> Just t) -> Right (k & Key.toText, t) + (k, v) -> Left $ "In Section " <> (sec & Key.toString) <> ": The value of field " <> (k & Key.toString) <> " has to be a string, but was: " <> show v + ) + & partitionEithers + & \case + ([], fields) -> Right fields + (errs, _) -> Left errs +pSectionFields sec _ = Left [ "The section " <> (sec & Key.toString) <> " has to be a json object." ] + pSection :: Parsec Text () Section pSection = do skipMany (pComment <|> (space *> spaces))