{-# 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"