gitit-0.15.1.2: src/Network/Gitit/Config.hs
{-# LANGUAGE CPP, FlexibleContexts, ScopedTypeVariables, OverloadedStrings #-}
{-
Copyright (C) 2009 John MacFarlane <jgm@berkeley.edu>
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
{- | Functions for parsing command line options and reading the config file.
-}
module Network.Gitit.Config ( getConfigFromFile
, getConfigFromFiles
, getDefaultConfig
, readMimeTypesFile )
where
import Network.Gitit.Types
import Network.Gitit.Server (mimeTypes)
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.Exit (ExitCode(..), exitWith)
import qualified Data.Map as M
import Data.List (intercalate, foldl')
import Data.Char (toLower, toUpper, 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)
import qualified Control.Exception as E
import Network.OAuth.OAuth2 (OAuth2(..))
import URI.ByteString (parseURI, laxURIParserOptions)
import qualified Data.ByteString.Char8 as BS
import Network.Gitit.Compat.Except
import Control.Monad
import Control.Monad.Trans
import Text.Parsec
import Text.Read (readMaybe)
-- | Get configuration from config file.
getConfigFromFile :: FilePath -> IO Config
getConfigFromFile fname = getConfigFromFiles [fname]
-- | Get configuration from config files, or default.
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)
res <- runExceptT $ extractConfig cfgmap
case res of
Right conf -> pure conf
Left e -> do
hPutStrLn stderr ("Error parsing config:\n" <> e)
exitWith (ExitFailure 1)
type ConfigMap = M.Map (Text, Text) Text
alterConfigMap :: ConfigMap -> FilePath -> IO ConfigMap
alterConfigMap cfmap 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'
-- | Returns the default gitit configuration.
getDefaultConfig :: IO Config
getDefaultConfig = getConfigFromFiles []
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.toUpper . 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 newline
skipMany (pComment <|> (space *> spaces))
vs <- T.unlines <$> many pMultiline
pure (T.toLower k, v <> vs)
pMultiline :: Parsec Text () Text
pMultiline = try $ do
spaces
char '>'
optional (char ' ')
T.pack <$> manyTill anyChar newline
extractConfig :: ConfigMap -> ExceptT String IO Config
extractConfig cfgmap = do
let get name field = maybe (pure mempty) (pure . T.unpack) $ M.lookup (name, field) cfgmap
cfRepositoryType <- get "DEFAULT" "repository-type"
cfRepositoryPath <- get "DEFAULT" "repository-path"
cfDefaultPageType <- get "DEFAULT" "default-page-type"
cfDefaultExtension <- get "DEFAULT" "default-extension"
cfMathMethod <- get "DEFAULT" "math"
cfMathjaxScript <- get "DEFAULT" "mathjax-script"
cfShowLHSBirdTracks <- get "DEFAULT" "show-lhs-bird-tracks" >>= readBool
cfRequireAuthentication <- get "DEFAULT" "require-authentication"
cfAuthenticationMethod <- get "DEFAULT" "authentication-method"
cfUserFile <- get "DEFAULT" "user-file"
cfSessionTimeout <- get "DEFAULT" "session-timeout" >>= readNumber
cfTemplatesDir <- get "DEFAULT" "templates-dir"
cfLogFile <- get "DEFAULT" "log-file"
cfLogLevel <- get "DEFAULT" "log-level"
cfStaticDir <- get "DEFAULT" "static-dir"
cfPlugins <- get "DEFAULT" "plugins"
cfTableOfContents <- get "DEFAULT" "table-of-contents" >>= readBool
cfMaxUploadSize <- get "DEFAULT" "max-upload-size" >>= readSize
cfMaxPageSize <- get "DEFAULT" "max-page-size" >>= readSize
cfAddress <- get "DEFAULT" "address"
cfPort <- get "DEFAULT" "port" >>= readNumber
cfDebugMode <- get "DEFAULT" "debug-mode" >>= readBool
cfFrontPage <- get "DEFAULT" "front-page"
cfNoEdit <- get "DEFAULT" "no-edit"
cfNoDelete <- get "DEFAULT" "no-delete"
cfDefaultSummary <- get "DEFAULT" "default-summary"
cfDeleteSummary <- get "DEFAULT" "delete-summary"
cfDisableRegistration <- get "DEFAULT" "disable-registration" >>= readBool
cfAccessQuestion <- get "DEFAULT" "access-question"
cfAccessQuestionAnswers <- get "DEFAULT" "access-question-answers"
cfUseRecaptcha <- get "DEFAULT" "use-recaptcha" >>= readBool
cfRecaptchaPublicKey <- get "DEFAULT" "recaptcha-public-key"
cfRecaptchaPrivateKey <- get "DEFAULT" "recaptcha-private-key"
cfRPXDomain <- get "DEFAULT" "rpx-domain"
cfRPXKey <- get "DEFAULT" "rpx-key"
cfCompressResponses <- get "DEFAULT" "compress-responses" >>= readBool
cfUseCache <- get "DEFAULT" "use-cache" >>= readBool
cfCacheDir <- get "DEFAULT" "cache-dir"
cfMimeTypesFile <- get "DEFAULT" "mime-types-file"
cfMailCommand <- get "DEFAULT" "mail-command"
cfResetPasswordMessage <- get "DEFAULT" "reset-password-message"
cfUseFeed <- get "DEFAULT" "use-feed" >>= readBool
cfBaseUrl <- get "DEFAULT" "base-url"
cfAbsoluteUrls <- get "DEFAULT" "absolute-urls" >>= readBool
cfWikiTitle <- get "DEFAULT" "wiki-title"
cfFeedDays <- get "DEFAULT" "feed-days" >>= readNumber
cfFeedRefreshTime <- get "DEFAULT" "feed-refresh-time" >>= readNumber
cfPandocUserData <- get "DEFAULT" "pandoc-user-data"
cfXssSanitize <- get "DEFAULT" "xss-sanitize" >>= readBool
cfRecentActivityDays <- get "DEFAULT" "recent-activity-days" >>= readNumber
let (pt, lhs) = parsePageType cfDefaultPageType
let markupHelpFile = show pt ++ if lhs then "+LHS" else ""
markupHelpPath <- liftIO $ getDataFileName $ "data" </> "markupHelp" </> markupHelpFile
markupHelp' <- liftIO $ readFileUTF8 markupHelpPath
markupHelpText <- liftIO $ handleError $ runPure $ do
helpDoc <- readMarkdown def{ readerExtensions = getDefaultExtensions "markdown" } markupHelp'
writeHtml5String def helpDoc
mimeMap' <- liftIO $ readMimeTypesFile cfMimeTypesFile
let authMethod = map toLower cfAuthenticationMethod
let stripTrailingSlash = reverse . dropWhile (=='/') . reverse
repotype' <- case map toLower cfRepositoryType of
"git" -> pure Git
"darcs" -> pure Darcs
"mercurial" -> pure Mercurial
x -> throwError $ "Unknown repository type: " ++ x
when (authMethod == "rpx" && cfRPXDomain == "") $
liftIO $ logM "gitit" WARNING "rpx-domain is not set"
ghConfig <- extractGithubConfig cfgmap
when (null cfUserFile) $
liftIO $ logM "gitit" ERROR "user-file is empty"
return Config{
repositoryPath = cfRepositoryPath
, repositoryType = repotype'
, defaultPageType = pt
, defaultExtension = cfDefaultExtension
, mathMethod = case map toLower cfMathMethod of
"mathml" -> MathML
"mathjax" -> MathJax cfMathjaxScript
"google" -> WebTeX "http://chart.apis.google.com/chart?cht=tx&chl="
_ -> RawTeX
, defaultLHS = lhs
, showLHSBirdTracks = cfShowLHSBirdTracks
, withUser = case authMethod of
"form" -> withUserFromSession
"github" -> withUserFromSession
"http" -> withUserFromHTTPAuth
"rpx" -> withUserFromSession
_ -> id
, requireAuthentication = case map toLower cfRequireAuthentication of
"none" -> Never
"modify" -> ForModify
"read" -> ForRead
_ -> ForModify
, authHandler = case authMethod of
"form" -> msum $ formAuthHandlers cfDisableRegistration
"github" -> msum $ githubAuthHandlers ghConfig
"http" -> msum httpAuthHandlers
"rpx" -> msum rpxAuthHandlers
_ -> mzero
, userFile = cfUserFile
, sessionTimeout = cfSessionTimeout * 60 -- convert minutes -> seconds
, templatesDir = cfTemplatesDir
, logFile = cfLogFile
, logLevel = let levelString = map toUpper cfLogLevel
levels = ["DEBUG", "INFO", "NOTICE", "WARNING", "ERROR",
"CRITICAL", "ALERT", "EMERGENCY"]
in if levelString `elem` levels
then read levelString
else error $ "Invalid log-level.\nLegal values are: " ++ intercalate ", " levels
, staticDir = cfStaticDir
, pluginModules = splitCommaList cfPlugins
, tableOfContents = cfTableOfContents
, maxUploadSize = cfMaxUploadSize
, maxPageSize = cfMaxPageSize
, address = cfAddress
, portNumber = cfPort
, debugMode = cfDebugMode
, frontPage = cfFrontPage
, noEdit = splitCommaList cfNoEdit
, noDelete = splitCommaList cfNoDelete
, defaultSummary = cfDefaultSummary
, deleteSummary = cfDeleteSummary
, disableRegistration = cfDisableRegistration
, accessQuestion = if null cfAccessQuestion
then Nothing
else Just (cfAccessQuestion,
splitCommaList cfAccessQuestionAnswers)
, useRecaptcha = cfUseRecaptcha
, recaptchaPublicKey = cfRecaptchaPublicKey
, recaptchaPrivateKey = cfRecaptchaPrivateKey
, rpxDomain = cfRPXDomain
, rpxKey = cfRPXKey
, compressResponses = cfCompressResponses
, useCache = cfUseCache
, cacheDir = cfCacheDir
, mimeMap = mimeMap'
, mailCommand = cfMailCommand
, resetPasswordMessage = cfResetPasswordMessage
, markupHelp = markupHelpText
, useFeed = cfUseFeed
, baseUrl = stripTrailingSlash cfBaseUrl
, useAbsoluteUrls = cfAbsoluteUrls
, wikiTitle = cfWikiTitle
, feedDays = cfFeedDays
, feedRefreshTime = cfFeedRefreshTime
, pandocUserData = if null cfPandocUserData
then Nothing
else Just cfPandocUserData
, xssSanitize = cfXssSanitize
, recentActivityDays = cfRecentActivityDays
, githubAuth = ghConfig
}
extractGithubConfig :: ConfigMap -> ExceptT String IO GithubConfig
extractGithubConfig cfgmap = do
cfOauthClientId <- getGithubProp "oauthclientid"
cfOauthClientSecret <- getGithubProp "oauthclientsecret"
cfOauthCallback <- getUrlProp "oauthcallback"
cfOauthOAuthorizeEndpoint <- getUrlProp "oauthoauthorizeendpoint"
cfOauthAccessTokenEndpoint <- getUrlProp "oauthaccesstokenendpoint"
cfOrg' <- getGithubProp "github-org"
let cfOrg = if null cfOrg'
then Just cfOrg'
else Nothing
let cfgOAuth2 = OAuth2 {
oauth2ClientId = T.pack cfOauthClientId
, oauth2ClientSecret = T.pack cfOauthClientSecret
, oauth2RedirectUri = cfOauthCallback
, oauth2AuthorizeEndpoint = cfOauthOAuthorizeEndpoint
, oauth2TokenEndpoint = cfOauthAccessTokenEndpoint
}
return $ githubConfig cfgOAuth2 $ fmap T.pack cfOrg
where
get name field = maybe (pure mempty) (pure . T.unpack) $ M.lookup (name, field) cfgmap
getGithubProp = get "GITHUB"
getUrlProp prop = getGithubProp prop >>= \s ->
case parseURI laxURIParserOptions (BS.pack s) of
Left e -> throwError $ "couldn't parse url " ++ s
++ " from (Github/" ++ T.unpack prop
++ "): " ++ show e
Right uri -> return uri
-- | 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
(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
readNumber :: (Monad m, Num a, Read a) => String -> ExceptT String m a
readNumber x = case readMaybe x of
Just n -> pure n
_ -> throwError $ "Could not parse " ++ x ++ " as an integer."
readSize :: (Monad m, Num a, Read a) => String -> ExceptT String m a
readSize [] = readNumber ""
readSize x =
case last x of
'K' -> (* 1000) <$> readNumber (init x)
'M' -> (* 1000000) <$> readNumber (init x)
'G' -> (* 1000000000) <$> readNumber (init x)
_ -> readNumber x
splitCommaList :: String -> [String]
splitCommaList l =
let (first,rest) = break (== ',') l
first' = lrStrip first
in case rest of
[] -> [first' | not (null first')]
(_:rs) -> first' : splitCommaList rs
lrStrip :: String -> String
lrStrip = reverse . dropWhile isWhitespace . reverse . dropWhile isWhitespace
where isWhitespace = (`elem` [' ','\t','\n'])
readBool :: Monad m => String -> ExceptT String m Bool
readBool s =
case map toLower s of
"yes" -> pure True
"y" -> pure True
"no" -> pure False
"n" -> pure False
"true" -> pure True
"t" -> pure True
"false" -> pure False
"f" -> pure False
_ -> throwError $ "Could not read " <> s <> " as boolean"