diff --git a/gitit.cabal b/gitit.cabal index 80af74a9d..1b55c37dc 100644 --- a/gitit.cabal +++ b/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, diff --git a/src/Network/Gitit/Config.hs b/src/Network/Gitit/Config.hs index 588046a08..3dcfa8782 100644 --- a/src/Network/Gitit/Config.hs +++ b/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")] -}