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