gitit 0.15.1.1 → 0.15.1.2
raw patch · 11 files changed
+325/−283 lines, 11 filesdep −ConfigFiledep ~happstack-serverdep ~hoauth2dep ~jsonPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies removed: ConfigFile
Dependency ranges changed: happstack-server, hoauth2, json, skylighting
API changes (from Hackage documentation)
+ Network.Gitit.Config: instance GHC.Show.Show Network.Gitit.Config.Section
- Network.Gitit.Compat.Except: data ExceptT e (m :: Type -> Type) a
+ Network.Gitit.Compat.Except: data () => ExceptT e (m :: Type -> Type) a
- Network.Gitit.Interface: data Request
+ Network.Gitit.Interface: data () => Request
Files
- CHANGES +17/−0
- gitit.cabal +7/−7
- gitit.hs +1/−1
- src/Network/Gitit.hs +1/−0
- src/Network/Gitit/Authentication/Github.hs +1/−0
- src/Network/Gitit/Config.hs +291/−272
- src/Network/Gitit/ContentTransformer.hs +1/−0
- src/Network/Gitit/Handlers.hs +1/−0
- src/Network/Gitit/Server.hs +1/−1
- src/Network/Gitit/State.hs +2/−0
- src/Network/Gitit/Types.hs +2/−2
CHANGES view
@@ -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.
gitit.cabal view
@@ -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,
gitit.hs view
@@ -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)
src/Network/Gitit.hs view
@@ -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
src/Network/Gitit/Authentication/Github.hs view
@@ -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)
src/Network/Gitit/Config.hs view
@@ -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"
src/Network/Gitit/ContentTransformer.hs view
@@ -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)
src/Network/Gitit/Handlers.hs view
@@ -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
src/Network/Gitit/Server.hs view
@@ -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
src/Network/Gitit/State.hs view
@@ -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)
src/Network/Gitit/Types.hs view
@@ -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)