{- DisTract ------------------------------------------------------\
 |                                                                 |
 | Copyright (c) 2007, Matthew Sackman (matthew@wellquite.org)     |
 |                                                                 |
 | DisTract is freely distributable under the terms of a 3-Clause  |
 | BSD-style license. For details, see the DisTract web site:      |
 |   http://distract.wellquite.org/                                |
 |                                                                 |
 \-----------------------------------------------------------------}

{-# LANGUAGE TemplateHaskell #-}

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

-- ok, chuck defaults in here. Try hard to find
-- defaults that are non-fatal
-- remember that all the errors here are lazy, thus if we replace them
-- later they disappear
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" -- searches $PATH
         ; 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

-- augment defaults with contents of config file
-- in the prefs dir
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

-- check that the branch in the prefs dir is a .prefs.$user branch
-- and that we know the private key for $user
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