diff --git a/CHANGES b/CHANGES --- a/CHANGES +++ b/CHANGES @@ -1,3 +1,20 @@ +Version 0.15.1.2 released 27 Jan 2024 + + * Allow happstack-server 7.9. + + * Test on ghc 9.6, remove testing for 8.8. + + * Remove dependency on the unmaintained Config package (#696). + Instead, we implement a simple config file parser in + parsec. The format of the config file is identical, and there should + not be major differences in the behavior of the parser. + + * Allow building with Stackage LTS-22 (sternenseemann). + + * .cabal: move doc files to extra-doc-files (Jens Petersen). + Only README.markdown is needed at runtime, so move CHANGES + and extra license files to extra-doc-files + Version 0.15.1.1 released 03 Jul 2023 * Allow latest aeson. diff --git a/gitit.cabal b/gitit.cabal --- a/gitit.cabal +++ b/gitit.cabal @@ -1,6 +1,6 @@ cabal-version: 2.0 name: gitit -version: 0.15.1.1 +version: 0.15.1.2 build-type: Simple synopsis: Wiki using happstack, git or darcs, and pandoc. description: Gitit is a wiki backed by a git, darcs, or mercurial @@ -43,6 +43,7 @@ data/static/js/jquery-ui.droppable-1.6rc2.js data/static/js/jquery-ui.draggable-1.6rc2.js data/static/js/jquery-ui.tabs-1.6rc2.js +extra-doc-files: CHANGES, YUI-LICENSE, BLUETRIP-LICENSE, TANGOICONS data-files: data/static/css/screen.css, data/static/css/print.css, data/static/css/ie.css, data/static/css/highlighting.css, data/static/css/reset-fonts-grids.css, @@ -92,7 +93,7 @@ plugins/ShowUser.hs, plugins/Signature.hs, plugins/Subst.hs, - CHANGES, README.markdown, YUI-LICENSE, BLUETRIP-LICENSE, TANGOICONS + README.markdown Source-repository head type: git @@ -135,7 +136,7 @@ temporary, pandoc >= 2.9 && < 2.20 || >= 3.0 && < 3.2, pandoc-types >= 1.20 && < 1.24, - skylighting >= 0.8.2.3 && < 0.14, + skylighting >= 0.8.2.3 && < 0.15, bytestring, text, random, @@ -149,20 +150,19 @@ filestore >= 0.6.5 && < 0.7, zlib >= 0.5 && < 0.7, url >= 2.1, - happstack-server >= 7.5 && < 7.9, + happstack-server >= 7.5 && < 7.10, 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, tagsoup >= 0.13 && < 0.15, blaze-html >= 0.4 && < 0.10, - json >= 0.4 && < 0.11, + json >= 0.4 && < 0.12, uri-bytestring >= 0.2.3.3, split, - hoauth2 >= 2.3.0 && < 2.9, + hoauth2 >= 2.3.0 && < 2.11, xml-conduit >= 1.5 && < 1.10, http-conduit >= 2.1.6 && < 2.4, http-client-tls >= 0.2.2 && < 0.4, diff --git a/gitit.hs b/gitit.hs --- a/gitit.hs +++ b/gitit.hs @@ -26,7 +26,7 @@ import Data.Maybe (isNothing) import Data.Text.Encoding (encodeUtf8) import Network.Gitit.Compat.Except() -import Control.Monad.Reader +import Control.Monad import System.Log.Logger (Priority(..), setLevel, setHandlers, getLogger, saveGlobalLogger) import System.Log.Handler.Simple (fileHandler) diff --git a/src/Network/Gitit.hs b/src/Network/Gitit.hs --- a/src/Network/Gitit.hs +++ b/src/Network/Gitit.hs @@ -121,6 +121,7 @@ import Network.Gitit.Page import Network.Gitit.Authentication (loginUserForm) import Paths_gitit (getDataFileName) +import Control.Monad import Control.Monad.Reader import Prelude hiding (readFile) import qualified Data.ByteString.Char8 as B diff --git a/src/Network/Gitit/Authentication/Github.hs b/src/Network/Gitit/Authentication/Github.hs --- a/src/Network/Gitit/Authentication/Github.hs +++ b/src/Network/Gitit/Authentication/Github.hs @@ -23,6 +23,7 @@ import Data.Text (Text, pack, unpack) import Data.Text.Encoding (encodeUtf8) import Control.Applicative +import Control.Monad ((>=>)) import Control.Monad.Trans (liftIO) import Data.UUID (toString) import Data.UUID.V4 (nextRandom) diff --git a/src/Network/Gitit/Config.hs b/src/Network/Gitit/Config.hs --- a/src/Network/Gitit/Config.hs +++ b/src/Network/Gitit/Config.hs @@ -31,11 +31,13 @@ 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.ConfigFile hiding (readfile) -import Data.List (intercalate) -import Data.Char (toLower, toUpper, isDigit) +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) @@ -46,278 +48,282 @@ 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 +import Text.Read (readMaybe) -- | 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 + -- 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) -getConfigParserFromFiles :: [FilePath] -> - IO ConfigParser -getConfigParserFromFiles (fname:fnames) = do - cp <- getConfigParserFromFiles fnames - config <- readfile cp fname - return $ forceEither config -getConfigParserFromFiles [] = getDefaultConfigParser +type ConfigMap = M.Map (Text, Text) Text --- | 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 +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' -extractConfig :: ConfigParser -> IO Config -extractConfig cp = do - config' <- runExceptT $ do - cfRepositoryType <- get cp "DEFAULT" "repository-type" - cfRepositoryPath <- get cp "DEFAULT" "repository-path" - cfDefaultPageType <- get cp "DEFAULT" "default-page-type" - cfDefaultExtension <- get cp "DEFAULT" "default-extension" - cfMathMethod <- get cp "DEFAULT" "math" - cfMathjaxScript <- get cp "DEFAULT" "mathjax-script" - cfShowLHSBirdTracks <- get cp "DEFAULT" "show-lhs-bird-tracks" - cfRequireAuthentication <- get cp "DEFAULT" "require-authentication" - cfAuthenticationMethod <- get cp "DEFAULT" "authentication-method" - cfUserFile <- get cp "DEFAULT" "user-file" - cfSessionTimeout <- get cp "DEFAULT" "session-timeout" - cfTemplatesDir <- get cp "DEFAULT" "templates-dir" - cfLogFile <- get cp "DEFAULT" "log-file" - cfLogLevel <- get cp "DEFAULT" "log-level" - cfStaticDir <- get cp "DEFAULT" "static-dir" - cfPlugins <- get cp "DEFAULT" "plugins" - cfTableOfContents <- get cp "DEFAULT" "table-of-contents" - cfMaxUploadSize <- get cp "DEFAULT" "max-upload-size" - cfMaxPageSize <- get cp "DEFAULT" "max-page-size" - cfAddress <- get cp "DEFAULT" "address" - cfPort <- get cp "DEFAULT" "port" - cfDebugMode <- get cp "DEFAULT" "debug-mode" - cfFrontPage <- get cp "DEFAULT" "front-page" - cfNoEdit <- get cp "DEFAULT" "no-edit" - cfNoDelete <- get cp "DEFAULT" "no-delete" - cfDefaultSummary <- get cp "DEFAULT" "default-summary" - cfDeleteSummary <- get cp "DEFAULT" "delete-summary" - cfDisableRegistration <- get cp "DEFAULT" "disable-registration" - cfAccessQuestion <- get cp "DEFAULT" "access-question" - cfAccessQuestionAnswers <- get cp "DEFAULT" "access-question-answers" - cfUseRecaptcha <- get cp "DEFAULT" "use-recaptcha" - cfRecaptchaPublicKey <- get cp "DEFAULT" "recaptcha-public-key" - cfRecaptchaPrivateKey <- get cp "DEFAULT" "recaptcha-private-key" - cfRPXDomain <- get cp "DEFAULT" "rpx-domain" - cfRPXKey <- get cp "DEFAULT" "rpx-key" - cfCompressResponses <- get cp "DEFAULT" "compress-responses" - cfUseCache <- get cp "DEFAULT" "use-cache" - cfCacheDir <- get cp "DEFAULT" "cache-dir" - cfMimeTypesFile <- get cp "DEFAULT" "mime-types-file" - cfMailCommand <- get cp "DEFAULT" "mail-command" - cfResetPasswordMessage <- get cp "DEFAULT" "reset-password-message" - cfUseFeed <- get cp "DEFAULT" "use-feed" - cfBaseUrl <- get cp "DEFAULT" "base-url" - cfAbsoluteUrls <- get cp "DEFAULT" "absolute-urls" - cfWikiTitle <- get cp "DEFAULT" "wiki-title" - cfFeedDays <- get cp "DEFAULT" "feed-days" - cfFeedRefreshTime <- get cp "DEFAULT" "feed-refresh-time" - cfPandocUserData <- get cp "DEFAULT" "pandoc-user-data" - cfXssSanitize <- get cp "DEFAULT" "xss-sanitize" - cfRecentActivityDays <- get cp "DEFAULT" "recent-activity-days" - 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 +-- | Returns the default gitit configuration. +getDefaultConfig :: IO Config +getDefaultConfig = getConfigFromFiles [] - mimeMap' <- liftIO $ readMimeTypesFile cfMimeTypesFile - let authMethod = map toLower cfAuthenticationMethod - let stripTrailingSlash = reverse . dropWhile (=='/') . reverse - let repotype' = case map toLower cfRepositoryType of - "git" -> Git - "darcs" -> Darcs - "mercurial" -> Mercurial - x -> error $ "Unknown repository type: " ++ x - when (authMethod == "rpx" && cfRPXDomain == "") $ - liftIO $ logM "gitit" WARNING "rpx-domain is not set" - ghConfig <- extractGithubConfig cp +data Section = Section Text [(Text, Text)] + deriving (Show) - when (null cfUserFile) $ - liftIO $ logM "gitit" ERROR "user-file is empty" +parseConfig :: FilePath -> Text -> Either String [Section] +parseConfig fname txt = either (Left . show) Right $ parse (many pSection) fname txt - 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 +pSection :: Parsec Text () Section +pSection = do + skipMany (pComment <|> (space *> spaces)) + Section <$> pSectionName <*> many pValue - , authHandler = case authMethod of - "form" -> msum $ formAuthHandlers cfDisableRegistration - "github" -> msum $ githubAuthHandlers ghConfig - "http" -> msum httpAuthHandlers - "rpx" -> msum rpxAuthHandlers - _ -> mzero - , userFile = cfUserFile - , sessionTimeout = readNumber "session-timeout" 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 = readSize "max-upload-size" cfMaxUploadSize - , maxPageSize = readSize "max-page-size" cfMaxPageSize - , address = cfAddress - , portNumber = readNumber "port" 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 = fromQuotedMultiline cfResetPasswordMessage - , markupHelp = markupHelpText - , useFeed = cfUseFeed - , baseUrl = stripTrailingSlash cfBaseUrl - , useAbsoluteUrls = cfAbsoluteUrls - , wikiTitle = cfWikiTitle - , feedDays = readNumber "feed-days" cfFeedDays - , feedRefreshTime = readNumber "feed-refresh-time" cfFeedRefreshTime - , pandocUserData = if null cfPandocUserData - then Nothing - else Just cfPandocUserData - , xssSanitize = cfXssSanitize - , recentActivityDays = cfRecentActivityDays - , githubAuth = ghConfig - } - case config' of - Left (ParseError e, e') -> error $ "Parse error: " ++ e ++ "\n" ++ e' - Left e -> error (show e) - Right c -> return c +pComment :: Parsec Text () () +pComment = char '#' *> skipMany (satisfy (/= '\n')) <* newline -extractGithubConfig :: (Functor m, MonadError CPError m) => ConfigParser - -> m GithubConfig -extractGithubConfig cp = do - cfOauthClientId <- getGithubProp "oauthClientId" - cfOauthClientSecret <- getGithubProp "oauthClientSecret" - cfOauthCallback <- getUrlProp "oauthCallback" - cfOauthOAuthorizeEndpoint <- getUrlProp "oauthOAuthorizeEndpoint" - cfOauthAccessTokenEndpoint <- getUrlProp "oauthAccessTokenEndpoint" - cfOrg <- if hasGithubProp "github-org" - then fmap Just (getGithubProp "github-org") - else return 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 getGithubProp = get cp "Github" - hasGithubProp = has_option cp "Github" - getUrlProp prop = getGithubProp prop >>= \s -> - case parseURI laxURIParserOptions (BS.pack s) of - Left e -> throwError (ParseError $ "couldn't parse url " ++ s - ++ " from (Github/" ++ prop ++ "): " - ++ (show e) - , "getUrlProp") - Right uri -> return uri +pKeyChar :: Parsec Text () Char +pKeyChar = satisfy (\c -> isAlphaNum c || c == '_' || c == '.' || c == '-') -fromQuotedMultiline :: String -> String -fromQuotedMultiline = unlines . map doline . lines . dropWhile (`elem` [' ','\t','\n']) - where doline = dropWhile (`elem` [' ','\t']) . dropGt - dropGt ('>':' ':xs) = xs - dropGt ('>':xs) = xs - dropGt x = x +pSectionName :: Parsec Text () Text +pSectionName = do + char '[' + T.toUpper . T.pack <$> manyTill letter (char ']') -readNumber :: (Num a, Read a) => String -> String -> a -readNumber _ x | all isDigit x = read x -readNumber opt _ = error $ opt ++ " must be a number." +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) -readSize :: (Num a, Read a) => String -> String -> a -readSize opt x = - case reverse x of - ('K':_) -> readNumber opt (init x) * 1000 - ('M':_) -> readNumber opt (init x) * 1000000 - ('G':_) -> readNumber opt (init x) * 1000000000 - _ -> readNumber opt x +pMultiline :: Parsec Text () Text +pMultiline = try $ do + spaces + char '>' + optional (char ' ') + T.pack <$> manyTill anyChar newline -splitCommaList :: String -> [String] -splitCommaList l = - let (first,rest) = break (== ',') l - first' = lrStrip first - in case rest of - [] -> if null first' then [] else [first'] - (_:rs) -> first' : splitCommaList rs +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 -lrStrip :: String -> String -lrStrip = reverse . dropWhile isWhitespace . reverse . dropWhile isWhitespace - where isWhitespace = (`elem` [' ','\t','\n']) + 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" -getDefaultConfigParser :: IO ConfigParser -getDefaultConfigParser = do - cp <- getDataFileName "data/default.conf" >>= readfile emptyCP - return $ forceEither cp + ghConfig <- extractGithubConfig cfgmap --- | Returns the default gitit configuration. -getDefaultConfig :: IO Config -getDefaultConfig = getDefaultConfigParser >>= extractConfig + 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 - (liftM (foldr (go . words) M.empty . lines . T.unpack) $ readFileUTF8 f) + (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 @@ -326,28 +332,41 @@ 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")] --} +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" diff --git a/src/Network/Gitit/ContentTransformer.hs b/src/Network/Gitit/ContentTransformer.hs --- a/src/Network/Gitit/ContentTransformer.hs +++ b/src/Network/Gitit/ContentTransformer.hs @@ -69,6 +69,7 @@ where import qualified Control.Exception as E +import Control.Monad import Control.Monad.State import Control.Monad.Reader (ask) import Control.Monad.Except (throwError) diff --git a/src/Network/Gitit/Handlers.hs b/src/Network/Gitit/Handlers.hs --- a/src/Network/Gitit/Handlers.hs +++ b/src/Network/Gitit/Handlers.hs @@ -72,6 +72,7 @@ import Data.Maybe (fromMaybe, mapMaybe, isJust, catMaybes) import Data.Ord (comparing) import Data.Char (toLower, isSpace) +import Control.Monad import Control.Monad.Reader import qualified Data.ByteString.Lazy as B import qualified Data.ByteString as S diff --git a/src/Network/Gitit/Server.hs b/src/Network/Gitit/Server.hs --- a/src/Network/Gitit/Server.hs +++ b/src/Network/Gitit/Server.hs @@ -37,7 +37,7 @@ import Happstack.Server import Happstack.Server.Compression (compressedResponseFilter) import Network.Socket (getAddrInfo, defaultHints, addrAddress) -import Control.Monad.Reader +import Control.Monad (liftM) import Data.ByteString.UTF8 as U hiding (lines) withExpiresHeaders :: ServerMonad m => m Response -> m Response diff --git a/src/Network/Gitit/State.hs b/src/Network/Gitit/State.hs --- a/src/Network/Gitit/State.hs +++ b/src/Network/Gitit/State.hs @@ -28,6 +28,8 @@ import qualified Data.ByteString.Lazy.UTF8 as L (fromString) import Data.IORef import System.IO.Unsafe (unsafePerformIO) +import Control.Monad (liftM, replicateM) +import Control.Monad.IO.Class import Control.Monad.Reader import Data.FileStore import Data.List (intercalate) diff --git a/src/Network/Gitit/Types.hs b/src/Network/Gitit/Types.hs --- a/src/Network/Gitit/Types.hs +++ b/src/Network/Gitit/Types.hs @@ -65,9 +65,9 @@ , org , githubConfig) where -import Control.Monad.Reader (ReaderT, runReaderT, mplus) +import Control.Monad.Reader (ReaderT, runReaderT) import Control.Monad.State (StateT, runStateT, get, modify) -import Control.Monad (liftM) +import Control.Monad (liftM, mplus) import System.Log.Logger (Priority(..)) import Text.Pandoc.Definition (Pandoc) import Text.XHtml (Html)