Skeleton for new config file parser.

gitit.cabal

@@ -154,7 +154,6 @@ Library
                      base64-bytestring >= 0.1,
                      xml >= 1.3.5,
                      hslogger >= 1,
-                     ConfigFile >= 1,
                      feed >= 1.0 && < 1.4,
                      xml-types >= 0.3,
                      xss-sanitize >= 0.3 && < 0.4,

src/Network/Gitit/Config.hs

@@ -31,11 +31,14 @@ import Network.Gitit.Framework
 import Network.Gitit.Authentication (formAuthHandlers, rpxAuthHandlers, httpAuthHandlers, githubAuthHandlers)
 import Network.Gitit.Util (parsePageType, readFileUTF8)
 import System.Log.Logger (logM, Priority(..))
+import System.IO (hPutStrLn, stderr)
+import System.Directory (doesFileExist)
+import System.Exit (ExitCode(..), exitWith)
 import qualified Data.Map as M
-import Data.ConfigFile hiding (readfile)
 import Data.List (intercalate)
-import Data.Char (toLower, toUpper, isDigit)
+import Data.Char (toLower, toUpper, isDigit, isAlphaNum)
 import qualified Data.Text as T
+import Data.Text (Text)
 import Paths_gitit (getDataFileName)
 import System.FilePath ((</>))
 import Text.Pandoc hiding (ERROR, WARNING, MathJax, MathML, WebTeX, getDataFileName)
@@ -46,39 +49,158 @@ import qualified Data.ByteString.Char8 as BS
 import Network.Gitit.Compat.Except
 import Control.Monad
 import Control.Monad.Trans
-
-
-forceEither :: Show e => Either e a -> a
-forceEither = either (error . show) id
+import Text.Parsec
 
 -- | Get configuration from config file.
 getConfigFromFile :: FilePath -> IO Config
-getConfigFromFile fname = do
-  cp <- getDefaultConfigParser
-  readfile cp fname >>= extractConfig . forceEither
+getConfigFromFile fname = getConfigFromFiles [fname]
 
--- | Get configuration from config files.
+-- | Get configuration from config files, or default.
 getConfigFromFiles :: [FilePath] -> IO Config
 getConfigFromFiles fnames = do
-  config <- getConfigParserFromFiles fnames
-  extractConfig config
-
-getConfigParserFromFiles :: [FilePath] ->
-                            IO ConfigParser
-getConfigParserFromFiles (fname:fnames) = do
-  cp <- getConfigParserFromFiles fnames
-  config <- readfile cp fname
-  return $ forceEither config
-getConfigParserFromFiles [] = getDefaultConfigParser
-
--- | A version of readfile that treats the file as UTF-8.
-readfile :: MonadError CPError m
-          => ConfigParser
-          -> FilePath
-          -> IO (m ConfigParser)
-readfile cp path' = do
-  contents <- readFileUTF8 path'
-  return $ readstring cp $ T.unpack contents
+  defconfig <- getDefaultConfig
+  foldM getConfigFromFileWithDefaults defconfig fnames
+
+getConfigFromFileWithDefaults :: Config -> FilePath -> IO Config
+getConfigFromFileWithDefaults defconfig fname = do
+  contents <- readFileUTF8 fname
+  let contents' = "[DEFAULT]\n" <> contents
+  case parseConfig fname contents' >>= extractConfig defconfig of
+    Left msg -> do
+      hPutStrLn stderr ("Error parsing config " <> fname <> ":\n" <> msg)
+      exitWith (ExitFailure 1)
+    Right conf -> pure conf
+
+-- | Returns the default gitit configuration.
+getDefaultConfig :: IO Config
+getDefaultConfig = do
+  cp <- getDataFileName "data/default.conf"
+  exists <- doesFileExist cp
+  if exists
+     then getConfigFromFileWithDefaults defaultConfig cp
+     else pure defaultConfig
+
+data Section = Section Text [(Text, Text)]
+  deriving (Show)
+
+parseConfig :: FilePath -> Text -> Either String [Section]
+parseConfig fname txt = either (Left . show) Right $ parse (many pSection) fname txt
+
+pSection :: Parsec Text () Section
+pSection = do
+  skipMany (pComment <|> (space *> spaces))
+  Section <$> pSectionName <*> many pValue
+
+pComment :: Parsec Text () ()
+pComment = char '#' *> skipMany (satisfy (/= '\n')) <* newline
+
+pKeyChar :: Parsec Text () Char
+pKeyChar = satisfy (\c -> isAlphaNum c || c == '_' || c == '.' || c == '-')
+
+pSectionName :: Parsec Text () Text
+pSectionName = do
+  char '['
+  T.pack <$> manyTill letter (char ']')
+
+pValue :: Parsec Text () (Text, Text)
+pValue = try $ do
+  skipMany (pComment <|> (space *> spaces))
+  k <- T.pack <$> manyTill pKeyChar (char ':')
+  skipMany (oneOf " \t")
+  v <- T.pack <$> manyTill anyChar (char '#' <|> newline)
+  skipMany (pComment <|> (space *> spaces))
+  vs <- mconcat <$> many pMultiline
+  pure (k,v <> vs)
+
+pMultiline :: Parsec Text () Text
+pMultiline = try $ do
+  spaces
+  char '>'
+  optional (char ' ')
+  T.pack <$> manyTill anyChar newline
+
+extractConfig :: Config -> [Section] -> Either String Config
+extractConfig = foldM goSec
+ where
+   goSec cf (Section name fields) =
+    foldM (go name) cf fields
+   go "DEFAULT" cf ("repository-path", t) =
+     Right $ cf{ repositoryPath = T.unpack t }
+   go name _ (k,_) =
+     Left $ "Unknown config field in [" <> T.unpack name <> "] section: " <> T.unpack k
+
+defaultConfig :: Config
+defaultConfig =
+  Config {
+    repositoryPath       = "wikidata",
+    repositoryType       = Git,
+    defaultPageType      = Markdown,
+    defaultExtension     = "page",
+    mathMethod           = MathML,
+    defaultLHS           = False,
+    showLHSBirdTracks    = False,
+    withUser             = withUserFromSession,
+    requireAuthentication = ForModify,
+    authHandler          = msum (formAuthHandlers False),
+    userFile             = "gitit-users",
+    sessionTimeout       = 60,
+    templatesDir         = "templates",
+    logFile              = "gitit.log",
+    logLevel             = WARNING,
+    staticDir            = "static",
+    pluginModules        = [],
+    tableOfContents      = True,
+    maxUploadSize        = 100000,
+    maxPageSize          = 100000,
+    address              = "0.0.0.0",
+    portNumber           = 5001,
+    debugMode            = False,
+    frontPage            = "Front Page",
+    noEdit               = ["Help"],
+    noDelete             = ["Front Page", "Help"],
+    defaultSummary       = "",
+    deleteSummary        = "Deleted using web interface",
+    accessQuestion       = Nothing,
+    disableRegistration  = False,
+    useRecaptcha         = False,
+    recaptchaPublicKey   = "",
+    recaptchaPrivateKey  = "",
+    rpxDomain            = "",
+    rpxKey               = "",
+    compressResponses    = True,
+    useCache             = False,
+    cacheDir             = "cache",
+    mimeMap              = M.empty,
+    mailCommand          = "sendmail %s",
+    resetPasswordMessage = "",
+    markupHelp           = "",
+    useFeed              = False,
+    baseUrl              = "",
+    useAbsoluteUrls      = False,
+    wikiTitle            = "Wiki",
+    feedDays             = 14,
+    feedRefreshTime      = 60,
+    pandocUserData       = Nothing,
+    xssSanitize          = True,
+    recentActivityDays   = 30,
+    githubAuth           = undefined
+  }
+
+-- | Read a file associating mime types with extensions, and return a
+-- map from extensions to types. Each line of the file consists of a
+-- mime type, followed by space, followed by a list of zero or more
+-- extensions, separated by spaces. Example: text/plain txt text
+readMimeTypesFile :: FilePath -> IO (M.Map String String)
+readMimeTypesFile f = E.catch
+  (liftM (foldr (go . words)  M.empty . lines . T.unpack) $ readFileUTF8 f)
+  handleMimeTypesFileNotFound
+     where go []     m = m  -- skip blank lines
+           go (x:xs) m = foldr (`M.insert` x) m xs
+           handleMimeTypesFileNotFound (e :: E.SomeException) = do
+             logM "gitit" WARNING $ "Could not read mime types file: " ++
+               f ++ "\n" ++ show e ++ "\n" ++ "Using defaults instead."
+             return mimeTypes
+{-
 
 extractConfig :: ConfigParser -> IO Config
 extractConfig cp = do
@@ -302,52 +424,4 @@ lrStrip :: String -> String
 lrStrip = reverse . dropWhile isWhitespace . reverse . dropWhile isWhitespace
     where isWhitespace = (`elem` [' ','\t','\n'])
 
-getDefaultConfigParser :: IO ConfigParser
-getDefaultConfigParser = do
-  cp <- getDataFileName "data/default.conf" >>= readfile emptyCP
-  return $ forceEither cp
-
--- | Returns the default gitit configuration.
-getDefaultConfig :: IO Config
-getDefaultConfig = getDefaultConfigParser >>= extractConfig
-
--- | Read a file associating mime types with extensions, and return a
--- map from extensions to types. Each line of the file consists of a
--- mime type, followed by space, followed by a list of zero or more
--- extensions, separated by spaces. Example: text/plain txt text
-readMimeTypesFile :: FilePath -> IO (M.Map String String)
-readMimeTypesFile f = E.catch
-  (liftM (foldr (go . words)  M.empty . lines . T.unpack) $ readFileUTF8 f)
-  handleMimeTypesFileNotFound
-     where go []     m = m  -- skip blank lines
-           go (x:xs) m = foldr (`M.insert` x) m xs
-           handleMimeTypesFileNotFound (e :: E.SomeException) = do
-             logM "gitit" WARNING $ "Could not read mime types file: " ++
-               f ++ "\n" ++ show e ++ "\n" ++ "Using defaults instead."
-             return mimeTypes
-
-{-
--- | Ready collection of common mime types. (Copied from
--- Happstack.Server.HTTP.FileServe.)
-mimeTypes :: M.Map String String
-mimeTypes = M.fromList
-        [("xml","application/xml")
-        ,("xsl","application/xml")
-        ,("js","text/javascript")
-        ,("html","text/html")
-        ,("htm","text/html")
-        ,("css","text/css")
-        ,("gif","image/gif")
-        ,("jpg","image/jpeg")
-        ,("png","image/png")
-        ,("txt","text/plain")
-        ,("doc","application/msword")
-        ,("exe","application/octet-stream")
-        ,("pdf","application/pdf")
-        ,("zip","application/zip")
-        ,("gz","application/x-gzip")
-        ,("ps","application/postscript")
-        ,("rtf","application/rtf")
-        ,("wav","application/x-wav")
-        ,("hs","text/plain")]
 -}