    {-# 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 :: String -> IO Config
    getConfigFromFile String
    fname = [String] -> IO Config
    getConfigFromFiles [String
    fname]

    -- | Get configuration from config files, or default.
    getConfigFromFiles :: [FilePath] -> IO Config
    getConfigFromFiles :: [String] -> IO Config
    getConfigFromFiles [String]
    fnames = do
      -- we start with default values from the data file
      cp <- String -> IO String
    getDataFileName String
    "data/default.conf"
      cfgmap <- foldM alterConfigMap mempty (cp : fnames)
      res <- runExceptT $ extractConfig cfgmap
      case res of
        Right Config
    conf -> Config -> IO Config
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Config
    conf
        Left String
    e -> do
          Handle -> String -> IO ()
    hPutStrLn Handle
    stderr (String
    "Error parsing config:\n" String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <> String
    e)
          ExitCode -> IO Config
    forall a. ExitCode -> IO a
    exitWith (Int -> ExitCode
    ExitFailure Int
    1)

    type ConfigMap = M.Map (Text, Text) Text

    alterConfigMap :: ConfigMap -> FilePath -> IO ConfigMap
    alterConfigMap :: ConfigMap -> String -> IO ConfigMap
    alterConfigMap ConfigMap
    cfmap String
    fname = do
      contents <- String -> IO Text
    readFileUTF8 String
    fname
      let contents' = Text
    "[DEFAULT]\n" Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    contents
      case parseConfig fname contents' of
        Left String
    msg -> do
          Handle -> String -> IO ()
    hPutStrLn Handle
    stderr (String
    "Error parsing config " String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <> String
    fname String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <> String
    ":\n" String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <> String
    msg)
          ExitCode -> IO ConfigMap
    forall a. ExitCode -> IO a
    exitWith (Int -> ExitCode
    ExitFailure Int
    1)
        Right [Section]
    secs -> ConfigMap -> IO ConfigMap
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (ConfigMap -> IO ConfigMap) -> ConfigMap -> IO ConfigMap
    forall a b. (a -> b) -> a -> b
    $ (ConfigMap -> Section -> ConfigMap)
    -> ConfigMap -> [Section] -> ConfigMap
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl' ConfigMap -> Section -> ConfigMap
    go ConfigMap
    cfmap [Section]
    secs
          where
            go :: ConfigMap -> Section -> ConfigMap
    go ConfigMap
    cfmap' (Section Text
    name [(Text, Text)]
    fields) = (ConfigMap -> (Text, Text) -> ConfigMap)
    -> ConfigMap -> [(Text, Text)] -> ConfigMap
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl' (Text -> ConfigMap -> (Text, Text) -> ConfigMap
    forall {a} {b} {a}.
    (Ord a, Ord b) =>
    a -> Map (a, b) a -> (b, a) -> Map (a, b) a
    go' Text
    name) ConfigMap
    cfmap' [(Text, Text)]
    fields
            go' :: a -> Map (a, b) a -> (b, a) -> Map (a, b) a
    go' a
    name Map (a, b) a
    cfmap' (b
    k,a
    v) = (a, b) -> a -> Map (a, b) a -> Map (a, b) a
    forall k a. Ord k => k -> a -> Map k a -> Map k a
    M.insert (a
    name, b
    k) a
    v Map (a, b) a
    cfmap'

    -- | Returns the default gitit configuration.
    getDefaultConfig :: IO Config
    getDefaultConfig :: IO Config
    getDefaultConfig = [String] -> IO Config
    getConfigFromFiles []

    data Section = Section Text [(Text, Text)]
      deriving (Int -> Section -> String -> String
    [Section] -> String -> String
    Section -> String
    (Int -> Section -> String -> String)
    -> (Section -> String)
    -> ([Section] -> String -> String)
    -> Show Section
    forall a.
    (Int -> a -> String -> String)
    -> (a -> String) -> ([a] -> String -> String) -> Show a
    $cshowsPrec :: Int -> Section -> String -> String
    showsPrec :: Int -> Section -> String -> String
    $cshow :: Section -> String
    show :: Section -> String
    $cshowList :: [Section] -> String -> String
    showList :: [Section] -> String -> String
    Show)

    parseConfig :: FilePath -> Text -> Either String [Section]
    parseConfig :: String -> Text -> Either String [Section]
    parseConfig String
    fname Text
    txt = (ParseError -> Either String [Section])
    -> ([Section] -> Either String [Section])
    -> Either ParseError [Section]
    -> Either String [Section]
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
    either (String -> Either String [Section]
    forall a b. a -> Either a b
    Left (String -> Either String [Section])
    -> (ParseError -> String) -> ParseError -> Either String [Section]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ParseError -> String
    forall a. Show a => a -> String
    show) [Section] -> Either String [Section]
    forall a b. b -> Either a b
    Right (Either ParseError [Section] -> Either String [Section])
    -> Either ParseError [Section] -> Either String [Section]
    forall a b. (a -> b) -> a -> b
    $ Parsec Text () [Section]
    -> String -> Text -> Either ParseError [Section]
    forall s t a.
    Stream s Identity t =>
    Parsec s () a -> String -> s -> Either ParseError a
    parse (ParsecT Text () Identity Section -> Parsec Text () [Section]
    forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
    many ParsecT Text () Identity Section
    pSection) String
    fname Text
    txt

    pSection :: Parsec Text () Section
    pSection :: ParsecT Text () Identity Section
    pSection = do
      ParsecT Text () Identity () -> ParsecT Text () Identity ()
    forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m ()
    skipMany (ParsecT Text () Identity ()
    pComment ParsecT Text () Identity ()
    -> ParsecT Text () Identity () -> ParsecT Text () Identity ()
    forall s u (m :: * -> *) a.
    ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
    <|> (ParsecT Text () Identity Char
    forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
    space ParsecT Text () Identity Char
    -> ParsecT Text () Identity () -> ParsecT Text () Identity ()
    forall a b.
    ParsecT Text () Identity a
    -> ParsecT Text () Identity b -> ParsecT Text () Identity b
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
    *> ParsecT Text () Identity ()
    forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
    spaces))
      Text -> [(Text, Text)] -> Section
    Section (Text -> [(Text, Text)] -> Section)
    -> ParsecT Text () Identity Text
    -> ParsecT Text () Identity ([(Text, Text)] -> Section)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> ParsecT Text () Identity Text
    pSectionName ParsecT Text () Identity ([(Text, Text)] -> Section)
    -> ParsecT Text () Identity [(Text, Text)]
    -> ParsecT Text () Identity Section
    forall a b.
    ParsecT Text () Identity (a -> b)
    -> ParsecT Text () Identity a -> ParsecT Text () Identity b
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
    <*> ParsecT Text () Identity (Text, Text)
    -> ParsecT Text () Identity [(Text, Text)]
    forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
    many ParsecT Text () Identity (Text, Text)
    pValue

    pComment :: Parsec Text () ()
    pComment :: ParsecT Text () Identity ()
    pComment = Char -> ParsecT Text () Identity Char
    forall s (m :: * -> *) u.
    Stream s m Char =>
    Char -> ParsecT s u m Char
    char Char
    '#' ParsecT Text () Identity Char
    -> ParsecT Text () Identity () -> ParsecT Text () Identity ()
    forall a b.
    ParsecT Text () Identity a
    -> ParsecT Text () Identity b -> ParsecT Text () Identity b
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
    *> ParsecT Text () Identity Char -> ParsecT Text () Identity ()
    forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m ()
    skipMany ((Char -> Bool) -> ParsecT Text () Identity Char
    forall s (m :: * -> *) u.
    Stream s m Char =>
    (Char -> Bool) -> ParsecT s u m Char
    satisfy (Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    /= Char
    '\n')) ParsecT Text () Identity ()
    -> ParsecT Text () Identity Char -> ParsecT Text () Identity ()
    forall a b.
    ParsecT Text () Identity a
    -> ParsecT Text () Identity b -> ParsecT Text () Identity a
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
    <* ParsecT Text () Identity Char
    forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
    newline

    pKeyChar :: Parsec Text () Char
    pKeyChar :: ParsecT Text () Identity Char
    pKeyChar = (Char -> Bool) -> ParsecT Text () Identity Char
    forall s (m :: * -> *) u.
    Stream s m Char =>
    (Char -> Bool) -> ParsecT s u m Char
    satisfy (\Char
    c -> Char -> Bool
    isAlphaNum Char
    c Bool -> Bool -> Bool
    || Char
    c Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '_' Bool -> Bool -> Bool
    || Char
    c Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '.' Bool -> Bool -> Bool
    || Char
    c Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '-')

    pSectionName :: Parsec Text () Text
    pSectionName :: ParsecT Text () Identity Text
    pSectionName = do
      Char -> ParsecT Text () Identity Char
    forall s (m :: * -> *) u.
    Stream s m Char =>
    Char -> ParsecT s u m Char
    char Char
    '['
      Text -> Text
    T.toUpper (Text -> Text) -> (String -> Text) -> String -> Text
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> Text
    T.pack (String -> Text)
    -> ParsecT Text () Identity String -> ParsecT Text () Identity Text
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> ParsecT Text () Identity Char
    -> ParsecT Text () Identity Char -> ParsecT Text () Identity String
    forall s (m :: * -> *) t u a end.
    Stream s m t =>
    ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
    manyTill ParsecT Text () Identity Char
    forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
    letter (Char -> ParsecT Text () Identity Char
    forall s (m :: * -> *) u.
    Stream s m Char =>
    Char -> ParsecT s u m Char
    char Char
    ']')

    pValue :: Parsec Text () (Text, Text)
    pValue :: ParsecT Text () Identity (Text, Text)
    pValue = ParsecT Text () Identity (Text, Text)
    -> ParsecT Text () Identity (Text, Text)
    forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
    try (ParsecT Text () Identity (Text, Text)
     -> ParsecT Text () Identity (Text, Text))
    -> ParsecT Text () Identity (Text, Text)
    -> ParsecT Text () Identity (Text, Text)
    forall a b. (a -> b) -> a -> b
    $ do
      ParsecT Text () Identity () -> ParsecT Text () Identity ()
    forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m ()
    skipMany (ParsecT Text () Identity ()
    pComment ParsecT Text () Identity ()
    -> ParsecT Text () Identity () -> ParsecT Text () Identity ()
    forall s u (m :: * -> *) a.
    ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
    <|> (ParsecT Text () Identity Char
    forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
    space ParsecT Text () Identity Char
    -> ParsecT Text () Identity () -> ParsecT Text () Identity ()
    forall a b.
    ParsecT Text () Identity a
    -> ParsecT Text () Identity b -> ParsecT Text () Identity b
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
    *> ParsecT Text () Identity ()
    forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
    spaces))
      k <- String -> Text
    T.pack (String -> Text)
    -> ParsecT Text () Identity String -> ParsecT Text () Identity Text
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> ParsecT Text () Identity Char
    -> ParsecT Text () Identity Char -> ParsecT Text () Identity String
    forall s (m :: * -> *) t u a end.
    Stream s m t =>
    ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
    manyTill ParsecT Text () Identity Char
    pKeyChar (Char -> ParsecT Text () Identity Char
    forall s (m :: * -> *) u.
    Stream s m Char =>
    Char -> ParsecT s u m Char
    char 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 :: ParsecT Text () Identity Text
    pMultiline = ParsecT Text () Identity Text -> ParsecT Text () Identity Text
    forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
    try (ParsecT Text () Identity Text -> ParsecT Text () Identity Text)
    -> ParsecT Text () Identity Text -> ParsecT Text () Identity Text
    forall a b. (a -> b) -> a -> b
    $ do
      ParsecT Text () Identity ()
    forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
    spaces
      Char -> ParsecT Text () Identity Char
    forall s (m :: * -> *) u.
    Stream s m Char =>
    Char -> ParsecT s u m Char
    char Char
    '>'
      ParsecT Text () Identity Char -> ParsecT Text () Identity ()
    forall s (m :: * -> *) t u a.
    Stream s m t =>
    ParsecT s u m a -> ParsecT s u m ()
    optional (Char -> ParsecT Text () Identity Char
    forall s (m :: * -> *) u.
    Stream s m Char =>
    Char -> ParsecT s u m Char
    char Char
    ' ')
      String -> Text
    T.pack (String -> Text)
    -> ParsecT Text () Identity String -> ParsecT Text () Identity Text
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> ParsecT Text () Identity Char
    -> ParsecT Text () Identity Char -> ParsecT Text () Identity String
    forall s (m :: * -> *) t u a end.
    Stream s m t =>
    ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
    manyTill ParsecT Text () Identity Char
    forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
    anyChar ParsecT Text () Identity Char
    forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
    newline

    extractConfig :: ConfigMap -> ExceptT String IO Config
    extractConfig :: ConfigMap -> ExceptT String IO Config
    extractConfig ConfigMap
    cfgmap = do
      let get :: Text -> Text -> f String
    get Text
    name Text
    field = f String -> (Text -> f String) -> Maybe Text -> f String
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe (String -> f String
    forall a. a -> f a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure String
    forall a. Monoid a => a
    mempty) (String -> f String
    forall a. a -> f a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (String -> f String) -> (Text -> String) -> Text -> f String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Text -> String
    T.unpack) (Maybe Text -> f String) -> Maybe Text -> f String
    forall a b. (a -> b) -> a -> b
    $ (Text, Text) -> ConfigMap -> Maybe Text
    forall k a. Ord k => k -> Map k a -> Maybe a
    M.lookup (Text
    name, Text
    field) ConfigMap
    cfgmap
      cfRepositoryType <- Text -> Text -> ExceptT String IO String
    forall {f :: * -> *}. Applicative f => Text -> Text -> f String
    get Text
    "DEFAULT" Text
    "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 = PageType -> String
    forall a. Show a => a -> String
    show PageType
    pt String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ if Bool
    lhs then String
    "+LHS" else String
    ""
      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 = (Char -> Char) -> String -> String
    forall a b. (a -> b) -> [a] -> [b]
    map Char -> Char
    toLower String
    cfAuthenticationMethod
      let stripTrailingSlash = String -> String
    forall a. [a] -> [a]
    reverse (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Char -> Bool) -> String -> String
    forall a. (a -> Bool) -> [a] -> [a]
    dropWhile (Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    ==Char
    '/') (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String
    forall a. [a] -> [a]
    reverse
      repotype' <- case map toLower cfRepositoryType of
                        String
    "git"       -> FileStoreType -> ExceptT String IO FileStoreType
    forall a. a -> ExceptT String IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure FileStoreType
    Git
                        String
    "darcs"     -> FileStoreType -> ExceptT String IO FileStoreType
    forall a. a -> ExceptT String IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure FileStoreType
    Darcs
                        String
    "mercurial" -> FileStoreType -> ExceptT String IO FileStoreType
    forall a. a -> ExceptT String IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure FileStoreType
    Mercurial
                        String
    x           -> String -> ExceptT String IO FileStoreType
    forall a. String -> ExceptT String IO a
    forall e (m :: * -> *) a. MonadError e m => e -> m a
    throwError (String -> ExceptT String IO FileStoreType)
    -> String -> ExceptT String IO FileStoreType
    forall a b. (a -> b) -> a -> b
    $ String
    "Unknown repository type: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    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
                                      String
    "mathml"   -> MathMethod
    MathML
                                      String
    "mathjax"  -> String -> MathMethod
    MathJax String
    cfMathjaxScript
                                      String
    "google"   -> String -> MathMethod
    WebTeX String
    "http://chart.apis.google.com/chart?cht=tx&chl="
                                      String
    _          -> MathMethod
    RawTeX
        , defaultLHS           = lhs
        , showLHSBirdTracks    = cfShowLHSBirdTracks
        , withUser             = case authMethod of
                                      String
    "form"     -> Handler -> Handler
    withUserFromSession
                                      String
    "github"   -> Handler -> Handler
    withUserFromSession
                                      String
    "http"     -> Handler -> Handler
    withUserFromHTTPAuth
                                      String
    "rpx"      -> Handler -> Handler
    withUserFromSession
                                      String
    _          -> Handler -> Handler
    forall a. a -> a
    id
        , requireAuthentication = case map toLower cfRequireAuthentication of
                                       String
    "none"    -> AuthenticationLevel
    Never
                                       String
    "modify"  -> AuthenticationLevel
    ForModify
                                       String
    "read"    -> AuthenticationLevel
    ForRead
                                       String
    _         -> AuthenticationLevel
    ForModify

        , authHandler          = case authMethod of
                                      String
    "form"     -> [Handler] -> Handler
    forall (t :: * -> *) (m :: * -> *) a.
    (Foldable t, MonadPlus m) =>
    t (m a) -> m a
    msum ([Handler] -> Handler) -> [Handler] -> Handler
    forall a b. (a -> b) -> a -> b
    $ Bool -> [Handler]
    formAuthHandlers Bool
    cfDisableRegistration
                                      String
    "github"   -> [Handler] -> Handler
    forall (t :: * -> *) (m :: * -> *) a.
    (Foldable t, MonadPlus m) =>
    t (m a) -> m a
    msum ([Handler] -> Handler) -> [Handler] -> Handler
    forall a b. (a -> b) -> a -> b
    $ GithubConfig -> [Handler]
    githubAuthHandlers GithubConfig
    ghConfig
                                      String
    "http"     -> [Handler] -> Handler
    forall (t :: * -> *) (m :: * -> *) a.
    (Foldable t, MonadPlus m) =>
    t (m a) -> m a
    msum [Handler]
    httpAuthHandlers
                                      String
    "rpx"      -> [Handler] -> Handler
    forall (t :: * -> *) (m :: * -> *) a.
    (Foldable t, MonadPlus m) =>
    t (m a) -> m a
    msum [Handler]
    rpxAuthHandlers
                                      String
    _          -> Handler
    forall a. ServerPartT (ReaderT WikiState IO) a
    forall (m :: * -> *) a. MonadPlus m => m a
    mzero
        , userFile             = cfUserFile
        , sessionTimeout       = cfSessionTimeout * 60  -- convert minutes -> seconds
        , templatesDir         = cfTemplatesDir
        , logFile              = cfLogFile
        , logLevel             = let levelString = (Char -> Char) -> String -> String
    forall a b. (a -> b) -> [a] -> [b]
    map Char -> Char
    toUpper String
    cfLogLevel
                                     levels = [String
    "DEBUG", String
    "INFO", String
    "NOTICE", String
    "WARNING", String
    "ERROR",
                                               String
    "CRITICAL", String
    "ALERT", String
    "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 :: ConfigMap -> ExceptT String IO GithubConfig
    extractGithubConfig ConfigMap
    cfgmap = do
      cfOauthClientId <- Text -> ExceptT String IO String
    getGithubProp Text
    "oauthclientid"
      cfOauthClientSecret <- getGithubProp "oauthclientsecret"
      cfOauthCallback <- getUrlProp "oauthcallback"
      cfOauthOAuthorizeEndpoint  <- getUrlProp "oauthoauthorizeendpoint"
      cfOauthAccessTokenEndpoint <- getUrlProp "oauthaccesstokenendpoint"
      cfOrg' <- getGithubProp "github-org"
      let cfOrg = if String -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null String
    cfOrg'
                    then String -> Maybe String
    forall a. a -> Maybe a
    Just String
    cfOrg'
                    else Maybe String
    forall a. Maybe a
    Nothing
      let cfgOAuth2 = OAuth2 {
                            oauth2ClientId :: Text
    oauth2ClientId = String -> Text
    T.pack String
    cfOauthClientId
                          , oauth2ClientSecret :: Text
    oauth2ClientSecret = String -> Text
    T.pack String
    cfOauthClientSecret
                          , oauth2RedirectUri :: URIRef Absolute
    oauth2RedirectUri = URIRef Absolute
    cfOauthCallback
                          , oauth2AuthorizeEndpoint :: URIRef Absolute
    oauth2AuthorizeEndpoint = URIRef Absolute
    cfOauthOAuthorizeEndpoint
                          , oauth2TokenEndpoint :: URIRef Absolute
    oauth2TokenEndpoint = URIRef Absolute
    cfOauthAccessTokenEndpoint
                          }
      return $ githubConfig cfgOAuth2 $ fmap T.pack cfOrg
     where
      get :: Text -> Text -> f String
    get Text
    name Text
    field = f String -> (Text -> f String) -> Maybe Text -> f String
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe (String -> f String
    forall a. a -> f a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure String
    forall a. Monoid a => a
    mempty) (String -> f String
    forall a. a -> f a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (String -> f String) -> (Text -> String) -> Text -> f String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Text -> String
    T.unpack) (Maybe Text -> f String) -> Maybe Text -> f String
    forall a b. (a -> b) -> a -> b
    $ (Text, Text) -> ConfigMap -> Maybe Text
    forall k a. Ord k => k -> Map k a -> Maybe a
    M.lookup (Text
    name, Text
    field) ConfigMap
    cfgmap
      getGithubProp :: Text -> ExceptT String IO String
    getGithubProp = Text -> Text -> ExceptT String IO String
    forall {f :: * -> *}. Applicative f => Text -> Text -> f String
    get Text
    "GITHUB"
      getUrlProp :: Text -> ExceptT String IO (URIRef Absolute)
    getUrlProp Text
    prop = Text -> ExceptT String IO String
    getGithubProp Text
    prop ExceptT String IO String
    -> (String -> ExceptT String IO (URIRef Absolute))
    -> ExceptT String IO (URIRef Absolute)
    forall a b.
    ExceptT String IO a
    -> (a -> ExceptT String IO b) -> ExceptT String IO b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= \String
    s ->
                          case URIParserOptions
    -> ByteString -> Either URIParseError (URIRef Absolute)
    parseURI URIParserOptions
    laxURIParserOptions (String -> ByteString
    BS.pack String
    s) of
                            Left URIParseError
    e    -> String -> ExceptT String IO (URIRef Absolute)
    forall a. String -> ExceptT String IO a
    forall e (m :: * -> *) a. MonadError e m => e -> m a
    throwError (String -> ExceptT String IO (URIRef Absolute))
    -> String -> ExceptT String IO (URIRef Absolute)
    forall a b. (a -> b) -> a -> b
    $ String
    "couldn't parse url " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    s
                                                         String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    " from (Github/" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Text -> String
    T.unpack Text
    prop
                                                         String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "): " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ URIParseError -> String
    forall a. Show a => a -> String
    show URIParseError
    e
                            Right URIRef Absolute
    uri -> URIRef Absolute -> ExceptT String IO (URIRef Absolute)
    forall a. a -> ExceptT String IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return URIRef Absolute
    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 :: String -> IO (Map String String)
    readMimeTypesFile String
    f = IO (Map String String)
    -> (SomeException -> IO (Map String String))
    -> IO (Map String String)
    forall e a. Exception e => IO a -> (e -> IO a) -> IO a
    E.catch
      ((String -> Map String String -> Map String String)
    -> Map String String -> [String] -> Map String String
    forall a b. (a -> b -> b) -> b -> [a] -> b
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr ([String] -> Map String String -> Map String String
    forall {a}. Ord a => [a] -> Map a a -> Map a a
    go ([String] -> Map String String -> Map String String)
    -> (String -> [String])
    -> String
    -> Map String String
    -> Map String String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> [String]
    words)  Map String String
    forall k a. Map k a
    M.empty ([String] -> Map String String)
    -> (Text -> [String]) -> Text -> Map String String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> [String]
    lines (String -> [String]) -> (Text -> String) -> Text -> [String]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Text -> String
    T.unpack (Text -> Map String String) -> IO Text -> IO (Map String String)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> String -> IO Text
    readFileUTF8 String
    f)
      SomeException -> IO (Map String String)
    handleMimeTypesFileNotFound
         where go :: [a] -> Map a a -> Map a a
    go []     Map a a
    m = Map a a
    m  -- skip blank lines
               go (a
    x:[a]
    xs) Map a a
    m = (a -> Map a a -> Map a a) -> Map a a -> [a] -> Map a a
    forall a b. (a -> b -> b) -> b -> [a] -> b
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr (a -> a -> Map a a -> Map a a
    forall k a. Ord k => k -> a -> Map k a -> Map k a
    `M.insert` a
    x) Map a a
    m [a]
    xs
               handleMimeTypesFileNotFound :: SomeException -> IO (Map String String)
    handleMimeTypesFileNotFound (SomeException
    e :: E.SomeException) = do
                 String -> Priority -> String -> IO ()
    logM String
    "gitit" Priority
    WARNING (String -> IO ()) -> String -> IO ()
    forall a b. (a -> b) -> a -> b
    $ String
    "Could not read mime types file: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++
                   String
    f String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "\n" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ SomeException -> String
    forall a. Show a => a -> String
    show SomeException
    e String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "\n" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "Using defaults instead."
                 Map String String -> IO (Map String String)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Map String String
    mimeTypes

    readNumber :: (Monad m, Num a, Read a) => String -> ExceptT String m a
    readNumber :: forall (m :: * -> *) a.
    (Monad m, Num a, Read a) =>
    String -> ExceptT String m a
    readNumber String
    x = case String -> Maybe a
    forall a. Read a => String -> Maybe a
    readMaybe String
    x of
                         Just a
    n -> a -> ExceptT String m a
    forall a. a -> ExceptT String m a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure a
    n
                         Maybe a
    _ -> String -> ExceptT String m a
    forall a. String -> ExceptT String m a
    forall e (m :: * -> *) a. MonadError e m => e -> m a
    throwError (String -> ExceptT String m a) -> String -> ExceptT String m a
    forall a b. (a -> b) -> a -> b
    $ String
    "Could not parse " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    x String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    " as an integer."

    readSize :: (Monad m, Num a, Read a) => String -> ExceptT String m a
    readSize :: forall (m :: * -> *) a.
    (Monad m, Num a, Read a) =>
    String -> ExceptT String m a
    readSize [] = String -> ExceptT String m a
    forall (m :: * -> *) a.
    (Monad m, Num a, Read a) =>
    String -> ExceptT String m a
    readNumber String
    ""
    readSize String
    x =
      case String -> Char
    forall a. HasCallStack => [a] -> a
    last String
    x of
           Char
    'K' -> (a -> a -> a
    forall a. Num a => a -> a -> a
    * a
    1000) (a -> a) -> ExceptT String m a -> ExceptT String m a
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> String -> ExceptT String m a
    forall (m :: * -> *) a.
    (Monad m, Num a, Read a) =>
    String -> ExceptT String m a
    readNumber (String -> String
    forall a. HasCallStack => [a] -> [a]
    init String
    x)
           Char
    'M' -> (a -> a -> a
    forall a. Num a => a -> a -> a
    * a
    1000000) (a -> a) -> ExceptT String m a -> ExceptT String m a
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> String -> ExceptT String m a
    forall (m :: * -> *) a.
    (Monad m, Num a, Read a) =>
    String -> ExceptT String m a
    readNumber (String -> String
    forall a. HasCallStack => [a] -> [a]
    init String
    x)
           Char
    'G' -> (a -> a -> a
    forall a. Num a => a -> a -> a
    *  a
    1000000000) (a -> a) -> ExceptT String m a -> ExceptT String m a
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> String -> ExceptT String m a
    forall (m :: * -> *) a.
    (Monad m, Num a, Read a) =>
    String -> ExceptT String m a
    readNumber (String -> String
    forall a. HasCallStack => [a] -> [a]
    init String
    x)
           Char
    _       -> String -> ExceptT String m a
    forall (m :: * -> *) a.
    (Monad m, Num a, Read a) =>
    String -> ExceptT String m a
    readNumber String
    x

    splitCommaList :: String -> [String]
    splitCommaList :: String -> [String]
    splitCommaList String
    l =
      let (String
    first,String
    rest) = (Char -> Bool) -> String -> (String, String)
    forall a. (a -> Bool) -> [a] -> ([a], [a])
    break (Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    ',') String
    l
          first' :: String
    first' = String -> String
    lrStrip String
    first
      in case String
    rest of
             []     -> [String
    first' | Bool -> Bool
    not (String -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null String
    first')]
             (Char
    _:String
    rs) -> String
    first' String -> [String] -> [String]
    forall a. a -> [a] -> [a]
    : String -> [String]
    splitCommaList String
    rs

    lrStrip :: String -> String
    lrStrip :: String -> String
    lrStrip = String -> String
    forall a. [a] -> [a]
    reverse (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Char -> Bool) -> String -> String
    forall a. (a -> Bool) -> [a] -> [a]
    dropWhile Char -> Bool
    isWhitespace (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String
    forall a. [a] -> [a]
    reverse (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Char -> Bool) -> String -> String
    forall a. (a -> Bool) -> [a] -> [a]
    dropWhile Char -> Bool
    isWhitespace
        where isWhitespace :: Char -> Bool
    isWhitespace = (Char -> String -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` [Char
    ' ',Char
    '\t',Char
    '\n'])

    readBool :: Monad m => String -> ExceptT String m Bool
    readBool :: forall (m :: * -> *). Monad m => String -> ExceptT String m Bool
    readBool String
    s =
      case (Char -> Char) -> String -> String
    forall a b. (a -> b) -> [a] -> [b]
    map Char -> Char
    toLower String
    s of
        String
    "yes" -> Bool -> ExceptT String m Bool
    forall a. a -> ExceptT String m a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Bool
    True
        String
    "y" -> Bool -> ExceptT String m Bool
    forall a. a -> ExceptT String m a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Bool
    True
        String
    "no" -> Bool -> ExceptT String m Bool
    forall a. a -> ExceptT String m a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Bool
    False
        String
    "n" -> Bool -> ExceptT String m Bool
    forall a. a -> ExceptT String m a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Bool
    False
        String
    "true" -> Bool -> ExceptT String m Bool
    forall a. a -> ExceptT String m a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Bool
    True
        String
    "t" -> Bool -> ExceptT String m Bool
    forall a. a -> ExceptT String m a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Bool
    True
        String
    "false" -> Bool -> ExceptT String m Bool
    forall a. a -> ExceptT String m a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Bool
    False
        String
    "f" -> Bool -> ExceptT String m Bool
    forall a. a -> ExceptT String m a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Bool
    False
        String
    _ -> String -> ExceptT String m Bool
    forall a. String -> ExceptT String m a
    forall e (m :: * -> *) a. MonadError e m => e -> m a
    throwError (String -> ExceptT String m Bool)
    -> String -> ExceptT String m Bool
    forall a b. (a -> b) -> a -> b
    $ String
    "Could not read " String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <> String
    s String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <> String
    " as boolean"