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.

Author: Profpatsch

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.
 

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,

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 <[email protected]>
 
@@ -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
@@ -50,6 +65,7 @@ import Control.Monad
 import Control.Monad.Trans
 import Text.Parsec
 import Text.Read (readMaybe)
+import Control.Monad.Except (ExceptT(ExceptT))
 
 -- | Get configuration from config file.
 getConfigFromFile :: FilePath -> IO Config
@@ -60,7 +76,7 @@ getConfigFromFiles :: [FilePath] -> IO Config
 getConfigFromFiles fnames = do
   -- we start with default values from the data file
   cp <- getDataFileName "data/default.conf"
-  cfgmap <- foldM alterConfigMap mempty (cp : fnames)
+  cfgmap <- foldM alterConfigMapByNewFile mempty (cp : fnames)
   res <- runExceptT $ extractConfig cfgmap
   case res of
     Right conf -> pure conf
@@ -70,18 +86,67 @@ getConfigFromFiles fnames = do
 
 type ConfigMap = M.Map (Text, Text) Text
 
-alterConfigMap :: ConfigMap -> FilePath -> IO ConfigMap
-alterConfigMap cfmap fname = do
+-- | 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
+--   }
+-- }
+-- @
+
+alterConfigMapByNewFile :: ConfigMap -> FilePath -> IO ConfigMap
+alterConfigMapByNewFile cfmap fname = do
+  eJsonVal <- readJsonValueFromFile 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 $ alterConfigMap cfmap secs
+
+alterConfigMap :: ConfigMap -> [Section] -> ConfigMap
+alterConfigMap = foldl' go
+  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
+
+readJsonValueFromFile :: FilePath -> IO (Either String Json.Value)
+readJsonValueFromFile 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
@@ -92,6 +157,62 @@ 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 <$> 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
+pSectionJson _ = Left "The toplevel json value has to be a json object."
+
+-- section key starts with [ and ends with ]
+asSectionKey :: KeyMap.Key -> Maybe Text
+asSectionKey k = case Key.toString k of
+  (x : (hasEnd ']' -> Just k')) | x == '[' -> Just $ k' & T.pack & T.toUpper
+  _ -> Nothing
+hasEnd :: Eq a => a -> [a] -> Maybe [a]
+hasEnd _ [] = Nothing
+hasEnd e xs
+  | last xs == e = Just (init xs)
+  | otherwise = Nothing
+
+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 :: Text -> 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 & T.unpack) <> ": 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 & T.unpack) <> " has to be a json object." ]
 
 pSection :: Parsec Text () Section
 pSection = do