Commit 6d530dd4 authored by Erik de Castro Lopo's avatar Erik de Castro Lopo

cabal-install : Add a 'user-config' command.

The 'user-config' command allows pseudo-diff-ing and updating of the
user's ~/.cabal/config file. The diff is against what cabal would
generated if the user config file did not exist and the update
command overlays the user's existing settings over the current
version of the default settings and writes it back to ~/.cabal/config.

Closes: #2159
parent a256fb18
......@@ -33,7 +33,9 @@ module Distribution.Client.Config (
haddockFlagsFields,
installDirsFields,
withProgramsFields,
withProgramOptionsFields
withProgramOptionsFields,
userConfigDiff,
userConfigUpdate
) where
import Distribution.Client.Types
......@@ -86,13 +88,13 @@ import Distribution.Verbosity
( Verbosity, normal )
import Data.List
( partition, find )
( partition, find, foldl' )
import Data.Maybe
( fromMaybe )
import Data.Monoid
( Monoid(..) )
import Control.Monad
( unless, foldM, liftM )
( unless, foldM, liftM, liftM2 )
import qualified Distribution.Compat.ReadP as Parse
( option )
import qualified Text.PrettyPrint as Disp
......@@ -115,6 +117,9 @@ import qualified Paths_cabal_install
( version )
import Data.Version
( showVersion )
import Data.Char
( isSpace )
import qualified Data.Map as M
--
-- * Configuration saved in the config file
......@@ -637,3 +642,60 @@ withProgramOptionsFields :: [FieldDescr [(String, [String])]]
withProgramOptionsFields =
map viewAsFieldDescr $
programConfigurationOptions defaultProgramConfiguration ParseArgs id (++)
-- | Get the differences (as a pseudo code diff) between the user's
-- '~/.cabal/config' and the one that cabal would generate if it didn't exist.
userConfigDiff :: GlobalFlags -> IO [String]
userConfigDiff globalFlags = do
userConfig <- loadConfig normal (globalConfigFile globalFlags) mempty
testConfig <- liftM2 mappend baseSavedConfig initialSavedConfig
return $ reverse . foldl' createDiff [] . M.toList
$ M.unionWith combine
(M.fromList . map justFst $ filterShow testConfig)
(M.fromList . map justSnd $ filterShow userConfig)
where
justFst (a, b) = (a, (Just b, Nothing))
justSnd (a, b) = (a, (Nothing, Just b))
combine (Nothing, Just b) (Just a, Nothing) = (Just a, Just b)
combine (Just a, Nothing) (Nothing, Just b) = (Just a, Just b)
combine x y = error $ "Can't happen : userConfigDiff " ++ show x ++ " " ++ show y
createDiff :: [String] -> (String, (Maybe String, Maybe String)) -> [String]
createDiff acc (key, (Just a, Just b))
| a == b = acc
| otherwise = ("+ " ++ key ++ ": " ++ b) : ("- " ++ key ++ ": " ++ a) : acc
createDiff acc (key, (Nothing, Just b)) = ("+ " ++ key ++ ": " ++ b) : acc
createDiff acc (key, (Just a, Nothing)) = ("- " ++ key ++ ": " ++ a) : acc
createDiff acc (_, (Nothing, Nothing)) = acc
filterShow :: SavedConfig -> [(String, String)]
filterShow cfg = map keyValueSplit
. filter (\s -> not (null s) && any (== ':') s)
. map nonComment
. lines
$ showConfig cfg
nonComment [] = []
nonComment ('-':'-':_) = []
nonComment (x:xs) = x : nonComment xs
topAndTail = reverse . dropWhile isSpace . reverse . dropWhile isSpace
keyValueSplit s =
let (left, right) = break (== ':') s
in (topAndTail left, topAndTail (drop 1 right))
-- | Update the user's ~/.cabal/config' keeping the user's customizations.
userConfigUpdate :: Verbosity -> GlobalFlags -> IO ()
userConfigUpdate verbosity globalFlags = do
userConfig <- loadConfig normal (globalConfigFile globalFlags) mempty
newConfig <- liftM2 mappend baseSavedConfig initialSavedConfig
commentConf <- commentSavedConfig
cabalFile <- defaultConfigFile
let backup = cabalFile ++ ".backup"
notice verbosity $ "Renaming " ++ cabalFile ++ " to " ++ backup ++ "."
renameFile cabalFile backup
notice verbosity $ "Writing merged config to " ++ cabalFile ++ "."
writeConfigFile cabalFile commentConf (newConfig `mappend` userConfig)
......@@ -35,6 +35,7 @@ module Distribution.Client.Setup
, win32SelfUpgradeCommand, Win32SelfUpgradeFlags(..)
, sandboxCommand, defaultSandboxLocation, SandboxFlags(..)
, execCommand, ExecFlags(..)
, userConfigCommand, UserConfigFlags(..)
, parsePackageArgs
--TODO: stop exporting these:
......@@ -1723,6 +1724,43 @@ instance Monoid ExecFlags where
}
where combine field = field a `mappend` field b
-- ------------------------------------------------------------
-- * UserConfig flags
-- ------------------------------------------------------------
data UserConfigFlags = UserConfigFlags {
userConfigVerbosity :: Flag Verbosity
}
instance Monoid UserConfigFlags where
mempty = UserConfigFlags {
userConfigVerbosity = toFlag normal
}
mappend a b = UserConfigFlags {
userConfigVerbosity = combine userConfigVerbosity
}
where combine field = field a `mappend` field b
userConfigCommand :: CommandUI UserConfigFlags
userConfigCommand = CommandUI {
commandName = "user-config",
commandSynopsis = "Manipulate the user's ~/.cabal/config file.",
commandDescription = Just $ \_ ->
"Allows pseudo-diff-ing and updating of the user's ~/.cabal/config "
++ "file. The\ndiff is against what cabal would generate if the user "
++ "config file did not\nexist. The update command overlays the user's "
++ "existing settings over the\ncurrent version of the default settings "
++ "and writes it back to ~/.cabal/config.\n",
commandUsage = \ pname ->
"Usage: " ++ pname ++ " user-config diff\n"
++ " " ++ pname ++ " user-config update\n",
commandDefaultFlags = mempty,
commandOptions = \ _ -> [
optionVerbosity userConfigVerbosity (\v flags -> flags { userConfigVerbosity = v })
]
}
-- ------------------------------------------------------------
-- * GetOpt Utils
-- ------------------------------------------------------------
......
......@@ -39,6 +39,7 @@ import Distribution.Client.Setup
, Win32SelfUpgradeFlags(..), win32SelfUpgradeCommand
, SandboxFlags(..), sandboxCommand
, ExecFlags(..), execCommand
, UserConfigFlags(..), userConfigCommand
, reportCommand
)
import Distribution.Simple.Setup
......@@ -56,7 +57,8 @@ import Distribution.Simple.Setup
import Distribution.Client.SetupWrapper
( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions )
import Distribution.Client.Config
( SavedConfig(..), loadConfig, defaultConfigFile )
( SavedConfig(..), loadConfig, defaultConfigFile, userConfigDiff
, userConfigUpdate )
import Distribution.Client.Targets
( readUserTargets )
import qualified Distribution.Client.List as List
......@@ -233,6 +235,7 @@ mainWorker args = topHandler $
,sandboxCommand `commandAddAction` sandboxAction
,haddockCommand `commandAddAction` haddockAction
,execCommand `commandAddAction` execAction
,userConfigCommand `commandAddAction` userConfigAction
,wrapperAction copyCommand
copyVerbosity copyDistPref
,wrapperAction cleanCommand
......@@ -1062,6 +1065,17 @@ execAction execFlags extraArgs globalFlags = do
(comp, platform, conf) <- configCompilerAux' configFlags
exec verbosity useSandbox comp platform conf extraArgs
userConfigAction :: UserConfigFlags -> [String] -> GlobalFlags -> IO ()
userConfigAction ucflags extraArgs globalFlags = do
let verbosity = fromFlag (userConfigVerbosity ucflags)
case extraArgs of
("diff":_) -> mapM_ putStrLn =<< userConfigDiff globalFlags
("update":_) -> userConfigUpdate verbosity globalFlags
-- Error handling.
[] -> die $ "Please specify a subcommand (see 'help user-config')"
_ -> die $ "Unknown 'user-config' subcommand: " ++ unwords extraArgs
-- | See 'Distribution.Client.Install.withWin32SelfUpgrade' for details.
--
win32SelfUpgradeAction :: Win32SelfUpgradeFlags -> [String] -> GlobalFlags
......
......@@ -179,6 +179,7 @@ Test-Suite unit-tests
UnitTests.Distribution.Client.Targets
UnitTests.Distribution.Client.Dependency.Modular.PSQ
UnitTests.Distribution.Client.Sandbox
UnitTests.Distribution.Client.UserConfig
build-depends:
base,
array,
......
......@@ -4,12 +4,15 @@ module Main
import Test.Framework
import qualified UnitTests.Distribution.Client.Sandbox
import qualified UnitTests.Distribution.Client.UserConfig
import qualified UnitTests.Distribution.Client.Targets
import qualified UnitTests.Distribution.Client.Dependency.Modular.PSQ
tests :: [Test]
tests = [
testGroup "Distribution.Client.Sandbox"
testGroup "UnitTests.Distribution.Client.UserConfig"
UnitTests.Distribution.Client.UserConfig.tests
,testGroup "Distribution.Client.Sandbox"
UnitTests.Distribution.Client.Sandbox.tests
,testGroup "Distribution.Client.Targets"
UnitTests.Distribution.Client.Targets.tests
......
module UnitTests.Distribution.Client.UserConfig
( tests
) where
import Control.Exception (bracket)
import Data.List (sort, nub)
import Data.Monoid
import System.Directory (getCurrentDirectory, removeDirectoryRecursive, createDirectoryIfMissing)
import System.FilePath (takeDirectory)
import Test.Framework as TF (Test)
import Test.Framework.Providers.HUnit (testCase)
import Test.HUnit (Assertion, assertBool)
import Distribution.Client.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.Verbosity (silent)
tests :: [TF.Test]
tests = [ testCase "nullDiffOnCreate" nullDiffOnCreateTest
, testCase "canDetectDifference" canDetectDifference
, testCase "canUpdateConfig" canUpdateConfig
, testCase "doubleUpdateConfig" doubleUpdateConfig
]
nullDiffOnCreateTest :: Assertion
nullDiffOnCreateTest = bracketTest . const $ do
-- Create a new default config file in our test directory.
_ <- loadConfig silent mempty mempty
-- Now we read it in and compare it against the default.
diff <- userConfigDiff mempty
assertBool (unlines $ "Following diff should be empty:" : diff) $ null diff
canDetectDifference :: Assertion
canDetectDifference = bracketTest . const $ do
-- Create a new default config file in our test directory.
_ <- loadConfig silent mempty mempty
cabalFile <- defaultConfigFile
appendFile cabalFile "verbose: 0\n"
diff <- userConfigDiff mempty
assertBool (unlines $ "Should detect a difference:" : diff) $
diff == [ "- verbose: 1", "+ verbose: 0" ]
canUpdateConfig :: Assertion
canUpdateConfig = bracketTest . const $ do
cabalFile <- defaultConfigFile
createDirectoryIfMissing True $ takeDirectory cabalFile
-- Write a trivial cabal file.
writeFile cabalFile "tests: True\n"
-- Update the config file.
userConfigUpdate silent mempty
-- Load it again.
updated <- loadConfig silent mempty mempty
assertBool ("Field 'tests' should be True") $
fromFlag (configTests $ savedConfigureFlags updated)
doubleUpdateConfig :: Assertion
doubleUpdateConfig = bracketTest . const $ do
-- Create a new default config file in our test directory.
_ <- loadConfig silent mempty mempty
-- Update it.
userConfigUpdate silent mempty
userConfigUpdate silent mempty
-- Load it again.
updated <- loadConfig silent mempty mempty
assertBool ("Field 'remote-repo' doesn't contain duplicates") $
listUnique (map show . fromNubList . globalRemoteRepos $ savedGlobalFlags updated)
assertBool ("Field 'extra-prog-path' doesn't contain duplicates") $
listUnique (map show . fromNubList . configProgramPathExtra $ savedConfigureFlags updated)
assertBool ("Field 'build-summary' doesn't contain duplicates") $
listUnique (map show . fromNubList . installSummaryFile $ savedInstallFlags updated)
listUnique :: Ord a => [a] -> Bool
listUnique xs =
let sorted = sort xs
in nub sorted == xs
bracketTest :: ((FilePath, 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
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