module DisTract.Config
(buildConfig,
buildConfigFromArgs,
defaultConfig,
package_name,
package_version
)
where
import DisTract.Layout
import DisTract.Types
import DisTract.Monotone.Types
import DisTract.Monotone.Interaction
import DisTract.Config.Parser
import DisTract.Bug.Field
import qualified Data.Map as M
import System.IO
import System.FilePath
import System.Directory
import Data.Maybe
import Control.Monad
import System.Environment
import System.Exit
import DisTract.Version
$(getNameVersionFromCabal "DisTract.cabal")
defaultMtnDb :: FilePath -> FilePath
defaultMtnDb base = combine base "db.mtn"
sortOutBaseDir :: FilePath -> IO FilePath
sortOutBaseDir base
= if isRel
then do { cwd <- getCurrentDirectory
; baseRel <- makeRelativeToCurrentDirectory base
; return $ combine cwd baseRel
}
else return base
where
isRel = isRelative base
defaultConfig :: FilePath -> [String] -> IO Config
defaultConfig base' args
= do { base <- sortOutBaseDir base'
; if isRelative base
then error $ "Unable to discover absolute path to base directory at " ++ base'
else return ()
; mtnExec <- findExecutable "mtn"
; let mtnExec' = fromMaybe (error "Can't find mtn executable") mtnExec
; dbExists <- doesFileExist $ defaultMtnDb base
; let db = if dbExists
then defaultMtnDb base
else error "Can't find mtn database"
; let user = error "Can't find user"
; return $ Config { mtnExecutable = mtnExec',
mtnDb = db,
user = user,
baseDir = addTrailingPathSeparator base,
fieldDfns = M.empty,
args = args,
verbose = False,
mtnVersion = undefined,
logger = StdOutLog,
packageName = package_name,
packageVersion = package_version
}
}
buildConfigFromArgs :: [String] -> IO Config
buildConfigFromArgs [] = error "No base dir supplied"
buildConfigFromArgs (version:_)
| version == "-v" || version == "--version"
= do { putStrLn $ package_name ++ ": Version " ++ package_version
; exitWith ExitSuccess
}
buildConfigFromArgs (base:rest)
= do { putStrLn $ "Using base at " ++ base
; defConfig <- defaultConfig base rest
; let configFile = combine (prefsDir base) "config"
; configContents <- readFile configFile
; let config = buildConfig' defConfig configContents
; version <- mtnFindVersion config
; let config' = config { mtnVersion = version }
; (_, privateKeys) <- mtnLsKeys config'
; branch <- mtnFindCurrentBranch config' prefs
; let user = findUserInPrefsBranch branch
; let config'' = findUser config' privateKeys user
; fields <- loadFieldDfns config''
; return $ config''{fieldDfns = fields}
}
buildConfig :: IO Config
buildConfig = getArgs >>= buildConfigFromArgs
buildConfig' :: Config -> String -> Config
buildConfig' config@(Config{mtnExecutable = defaultMtnExecutable,
mtnDb = defaultMtnDb,
verbose = defaultVerbose,
logger = defaultLogger
}
)
text
= config { mtnExecutable = lookup "mtn" defaultMtnExecutable,
mtnDb = lookup "db" defaultMtnDb,
verbose = read $ lookup "verbose" (show defaultVerbose),
logger = log
}
where
log = maybe defaultLogger FileLog $ M.lookup "log" parsedMap
parsedMap = parseConfig text
lookup :: String -> String -> String
lookup key def = M.findWithDefault def key parsedMap
findUser :: Config -> [Key] -> String -> Config
findUser config keys userFromBranch
= config {user = userChecked}
where
userChecked = if any keyMatch keys
then userFromBranch
else error ("Cannot find private key for user branch in prefs dir '" ++
userFromBranch ++ "'\n" ++ (show keys))
keyMatch :: Key -> Bool
keyMatch (PrivateKey str _) = str == userFromBranch
keyMatch _ = False