Commit b2d75687 authored by Duncan Coutts's avatar Duncan Coutts
Browse files

Merge branch 'grayjay-cabal-user-config'

parents 4e873363 cfcfb0fe
......@@ -517,20 +517,11 @@ addInfoForKnownRepos other = other
loadConfig :: Verbosity -> Flag FilePath -> IO SavedConfig
loadConfig verbosity configFileFlag = addBaseConf $ do
let sources = [
("commandline option", return . flagToMaybe $ configFileFlag),
("env var CABAL_CONFIG", lookup "CABAL_CONFIG" `liftM` getEnvironment),
("default config file", Just `liftM` defaultConfigFile) ]
getSource [] = error "no config file path candidate found."
getSource ((msg,action): xs) =
action >>= maybe (getSource xs) (return . (,) msg)
(source, configFile) <- getSource sources
(source, configFile) <- lookupConfigFile configFileFlag
minp <- readConfigFile mempty configFile
case minp of
Nothing -> do
notice verbosity $ "Config file path source is " ++ source ++ "."
notice verbosity $ "Config file path source is " ++ sourceMsg source ++ "."
notice verbosity $ "Config file " ++ configFile ++ " not found."
notice verbosity $ "Writing default configuration to " ++ configFile
commentConf <- commentSavedConfig
......@@ -553,6 +544,27 @@ loadConfig verbosity configFileFlag = addBaseConf $ do
extra <- body
return (base `mappend` extra)
sourceMsg CommandlineOption = "commandline option"
sourceMsg EnvironmentVariable = "env var CABAL_CONFIG"
sourceMsg Default = "default config file"
data ConfigFileSource = CommandlineOption
| EnvironmentVariable
| Default
lookupConfigFile :: Flag FilePath -> IO (ConfigFileSource, FilePath)
lookupConfigFile configFileFlag =
getSource sources
where
sources =
[ (CommandlineOption, return . flagToMaybe $ configFileFlag)
, (EnvironmentVariable, lookup "CABAL_CONFIG" `liftM` getEnvironment)
, (Default, Just `liftM` defaultConfigFile) ]
getSource [] = error "no config file path candidate found."
getSource ((source,action): xs) =
action >>= maybe (getSource xs) (return . (,) source)
readConfigFile :: SavedConfig -> FilePath -> IO (Maybe (ParseResult SavedConfig))
readConfigFile initial file = handleNotExists $
fmap (Just . parseConfig (ConstraintSourceMainConfig file) initial)
......@@ -1014,7 +1026,7 @@ userConfigUpdate verbosity globalFlags = do
userConfig <- loadConfig normal (globalConfigFile globalFlags)
newConfig <- liftM2 mappend baseSavedConfig initialSavedConfig
commentConf <- commentSavedConfig
cabalFile <- defaultConfigFile
(_, cabalFile) <- lookupConfigFile $ globalConfigFile globalFlags
let backup = cabalFile ++ ".backup"
notice verbosity $ "Renaming " ++ cabalFile ++ " to " ++ backup ++ "."
renameFile cabalFile backup
......
......@@ -4,21 +4,22 @@ module UnitTests.Distribution.Client.UserConfig
) where
import Control.Exception (bracket)
import Control.Monad (replicateM_)
import Data.List (sort, nub)
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid
#endif
import System.Directory (getCurrentDirectory, removeDirectoryRecursive, createDirectoryIfMissing)
import System.FilePath (takeDirectory)
import System.Directory (getCurrentDirectory)
import System.FilePath ((</>))
import Test.Tasty
import Test.Tasty.HUnit
import Distribution.Compat.Environment (lookupEnv, setEnv)
import Distribution.Client.Config
import Distribution.Utils.NubList (fromNubList)
import Distribution.Client.Setup (GlobalFlags (..), InstallFlags (..))
import Distribution.Simple.Setup (ConfigFlags (..), fromFlag)
import Distribution.Client.Utils (removeExistingFile)
import Distribution.Simple.Setup (Flag (..), ConfigFlags (..), fromFlag)
import Distribution.Verbosity (silent)
tests :: [TestTree]
......@@ -29,48 +30,44 @@ tests = [ testCase "nullDiffOnCreate" nullDiffOnCreateTest
]
nullDiffOnCreateTest :: Assertion
nullDiffOnCreateTest = bracketTest . const $ do
nullDiffOnCreateTest = bracketTest $ \configFile -> do
-- Create a new default config file in our test directory.
_ <- loadConfig silent mempty
_ <- loadConfig silent (Flag configFile)
-- Now we read it in and compare it against the default.
diff <- userConfigDiff mempty
diff <- userConfigDiff $ globalFlags configFile
assertBool (unlines $ "Following diff should be empty:" : diff) $ null diff
canDetectDifference :: Assertion
canDetectDifference = bracketTest . const $ do
canDetectDifference = bracketTest $ \configFile -> do
-- Create a new default config file in our test directory.
_ <- loadConfig silent mempty
cabalFile <- defaultConfigFile
appendFile cabalFile "verbose: 0\n"
diff <- userConfigDiff mempty
_ <- loadConfig silent (Flag configFile)
appendFile configFile "verbose: 0\n"
diff <- userConfigDiff $ globalFlags configFile
assertBool (unlines $ "Should detect a difference:" : diff) $
diff == [ "- verbose: 1", "+ verbose: 0" ]
canUpdateConfig :: Assertion
canUpdateConfig = bracketTest . const $ do
cabalFile <- defaultConfigFile
createDirectoryIfMissing True $ takeDirectory cabalFile
canUpdateConfig = bracketTest $ \configFile -> do
-- Write a trivial cabal file.
writeFile cabalFile "tests: True\n"
writeFile configFile "tests: True\n"
-- Update the config file.
userConfigUpdate silent mempty
userConfigUpdate silent $ globalFlags configFile
-- Load it again.
updated <- loadConfig silent mempty
updated <- loadConfig silent (Flag configFile)
assertBool ("Field 'tests' should be True") $
fromFlag (configTests $ savedConfigureFlags updated)
doubleUpdateConfig :: Assertion
doubleUpdateConfig = bracketTest . const $ do
doubleUpdateConfig = bracketTest $ \configFile -> do
-- Create a new default config file in our test directory.
_ <- loadConfig silent mempty
-- Update it.
userConfigUpdate silent mempty
userConfigUpdate silent mempty
_ <- loadConfig silent (Flag configFile)
-- Update it twice.
replicateM_ 2 . userConfigUpdate silent $ globalFlags configFile
-- Load it again.
updated <- loadConfig silent mempty
updated <- loadConfig silent (Flag configFile)
assertBool ("Field 'remote-repo' doesn't contain duplicates") $
listUnique (map show . fromNubList . globalRemoteRepos $ savedGlobalFlags updated)
......@@ -80,24 +77,23 @@ doubleUpdateConfig = bracketTest . const $ do
listUnique (map show . fromNubList . installSummaryFile $ savedInstallFlags updated)
globalFlags :: FilePath -> GlobalFlags
globalFlags configFile = mempty { globalConfigFile = Flag configFile }
listUnique :: Ord a => [a] -> Bool
listUnique xs =
let sorted = sort xs
in nub sorted == xs
bracketTest :: ((FilePath, FilePath) -> IO ()) -> Assertion
bracketTest :: (FilePath -> IO ()) -> Assertion
bracketTest =
bracket testSetup testTearDown
where
testSetup :: IO (FilePath, FilePath)
testSetup = do
Just oldHome <- lookupEnv "HOME"
testdir <- fmap (++ "/test-user-config") getCurrentDirectory
setEnv "HOME" testdir
return (oldHome, testdir)
testTearDown :: (FilePath, FilePath) -> IO ()
testTearDown (oldHome, testdir) = do
setEnv "HOME" oldHome
removeDirectoryRecursive testdir
testSetup :: IO FilePath
testSetup = fmap (</> "test-user-config") getCurrentDirectory
testTearDown :: FilePath -> IO ()
testTearDown configFile =
mapM_ removeExistingFile [configFile, configFile ++ ".backup"]
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment