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..dcdd57a72 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 @@ -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