feat(Config): Add json config format option

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,66 @@ 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 +156,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