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

cabal-install/Distribution/Client/Config.hs

@@ -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)

cabal-install/Distribution/Client/Setup.hs

@@ -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
 -- ------------------------------------------------------------

cabal-install/Main.hs

@@ -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

cabal-install/cabal-install.cabal

@@ -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,

cabal-install/tests/UnitTests.hs

@@ -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

cabal-install/tests/UnitTests/Distribution/Client/UserConfig.hs

+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