Add install-method, put new-install flags in config

Add an --install-method=symlink|copy flag which specifies how to perform
the installation.

* --symlink-bindir is now gone, replaced by --installdir
* --install-method=copy is useful in Windows where symlinking is not
supported

All new-install flags can now be configured in ~/.cabal/config

* NewInstallFlags changed to ClientInstallFlags (more descriptive than
InstallExFlags (like ConfigExFlags))
* ClientInstallFlags is now part of SavedConfig

cabal-install/Distribution/Client/CmdBench.hs

@@ -117,7 +117,9 @@ benchAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags)
     verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
     cliConfig = commandLineFlagsToProjectConfig
                   globalFlags configFlags configExFlags
-                  installFlags haddockFlags testFlags
+                  installFlags
+                  mempty -- ClientInstallFlags, not needed here
+                  haddockFlags testFlags
 
 -- | This defines what a 'TargetSelector' means for the @bench@ command.
 -- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,

cabal-install/Distribution/Client/CmdBuild.hs

@@ -157,7 +157,9 @@ buildAction
     verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
     cliConfig = commandLineFlagsToProjectConfig
                   globalFlags configFlags configExFlags
-                  installFlags haddockFlags testFlags
+                  installFlags
+                  mempty -- ClientInstallFlags, not needed here
+                  haddockFlags testFlags
 
 -- | This defines what a 'TargetSelector' means for the @bench@ command.
 -- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,

cabal-install/Distribution/Client/CmdConfigure.hs

@@ -121,5 +121,7 @@ configureAction (configFlags, configExFlags, installFlags, haddockFlags, testFla
     verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
     cliConfig = commandLineFlagsToProjectConfig
                   globalFlags configFlags configExFlags
-                  installFlags haddockFlags testFlags
+                  installFlags
+                  mempty -- ClientInstallFlags, not needed here
+                  haddockFlags testFlags
 

cabal-install/Distribution/Client/CmdExec.hs

@@ -194,7 +194,9 @@ execAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags)
     verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
     cliConfig = commandLineFlagsToProjectConfig
                   globalFlags configFlags configExFlags
-                  installFlags haddockFlags testFlags
+                  installFlags
+                  mempty -- ClientInstallFlags, not needed here
+                  haddockFlags testFlags
     withOverrides env args program = program
       { programOverrideEnv = programOverrideEnv program ++ env
       , programDefaultArgs = programDefaultArgs program ++ args}

cabal-install/Distribution/Client/CmdFreeze.hs

@@ -130,7 +130,9 @@ freezeAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags)
     verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
     cliConfig = commandLineFlagsToProjectConfig
                   globalFlags configFlags configExFlags
-                  installFlags haddockFlags testFlags
+                  installFlags
+                  mempty -- ClientInstallFlags, not needed here
+                  haddockFlags testFlags
 
 
 

cabal-install/Distribution/Client/CmdHaddock.hs

@@ -111,7 +111,9 @@ haddockAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags
     verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
     cliConfig = commandLineFlagsToProjectConfig
                   globalFlags configFlags configExFlags
-                  installFlags haddockFlags testFlags
+                  installFlags
+                  mempty -- ClientInstallFlags, not needed here
+                  haddockFlags testFlags
 
 -- | This defines what a 'TargetSelector' means for the @haddock@ command.
 -- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,

cabal-install/Distribution/Client/CmdInstall.hs

@@ -20,11 +20,15 @@ module Distribution.Client.CmdInstall (
 
 import Prelude ()
 import Distribution.Client.Compat.Prelude
+import Distribution.Compat.Directory
+         ( doesPathExist )
 
 import Distribution.Client.ProjectOrchestration
 import Distribution.Client.CmdErrorMessages
 import Distribution.Client.CmdSdist
 
+import Distribution.Client.CmdInstall.ClientInstallFlags
+
 import Distribution.Client.Setup
          ( GlobalFlags(..), ConfigFlags(..), ConfigExFlags, InstallFlags(..)
          , configureExOptions, haddockOptions, installOptions, testOptions
@@ -51,7 +55,7 @@ import Distribution.Simple.Program.Db
 import Distribution.Simple.Program.Find
          ( ProgramSearchPathEntry(..) )
 import Distribution.Client.Config
-         ( getCabalDir )
+         ( getCabalDir, loadConfig, SavedConfig(..) )
 import qualified Distribution.Simple.PackageIndex as PI
 import Distribution.Solver.Types.PackageIndex
          ( lookupPackageName, searchByName )
@@ -78,15 +82,11 @@ import Distribution.Client.RebuildMonad
 import Distribution.Client.InstallSymlink
          ( OverwritePolicy(..), symlinkBinary )
 import Distribution.Simple.Setup
-         ( Flag(..), HaddockFlags, TestFlags, fromFlagOrDefault, flagToMaybe
-         , trueArg, flagToList, toFlag )
+         ( Flag(..), HaddockFlags, TestFlags, fromFlagOrDefault, flagToMaybe )
 import Distribution.Solver.Types.SourcePackage
          ( SourcePackage(..) )
-import Distribution.ReadE
-         ( ReadE(..), succeedReadE )
 import Distribution.Simple.Command
-         ( CommandUI(..), ShowOrParseArgs(..), OptionField(..)
-         , option, usageAlternatives, reqArg )
+         ( CommandUI(..), OptionField(..), usageAlternatives )
 import Distribution.Simple.Configure
          ( configCompilerEx )
 import Distribution.Simple.Compiler
@@ -128,52 +128,14 @@ import Distribution.Utils.NubList
          ( fromNubList )
 import System.Directory
          ( getHomeDirectory, doesFileExist, createDirectoryIfMissing
-         , getTemporaryDirectory, makeAbsolute, doesDirectoryExist )
+         , getTemporaryDirectory, makeAbsolute, doesDirectoryExist
+         , removeFile, removeDirectory, copyFile )
 import System.FilePath
          ( (</>), takeDirectory, takeBaseName )
 
-data NewInstallFlags = NewInstallFlags
-  { ninstInstallLibs :: Flag Bool
-  , ninstEnvironmentPath :: Flag FilePath
-  , ninstOverwritePolicy :: Flag OverwritePolicy
-  }
-
-defaultNewInstallFlags :: NewInstallFlags
-defaultNewInstallFlags = NewInstallFlags
-  { ninstInstallLibs = toFlag False
-  , ninstEnvironmentPath = mempty
-  , ninstOverwritePolicy = toFlag NeverOverwrite
-  }
-
-newInstallOptions :: ShowOrParseArgs -> [OptionField NewInstallFlags]
-newInstallOptions _ =
-  [ option [] ["lib"]
-    "Install libraries rather than executables from the target package."
-    ninstInstallLibs (\v flags -> flags { ninstInstallLibs = v })
-    trueArg
-  , option [] ["package-env", "env"]
-    "Set the environment file that may be modified."
-    ninstEnvironmentPath (\pf flags -> flags { ninstEnvironmentPath = pf })
-    (reqArg "ENV" (succeedReadE Flag) flagToList)
-  , option [] ["overwrite-policy"]
-    "How to handle already existing symlinks."
-    ninstOverwritePolicy (\v flags -> flags { ninstOverwritePolicy = v })
-    $ reqArg
-        "always|never"
-        readOverwritePolicyFlag
-        showOverwritePolicyFlag
-  ]
-  where
-    readOverwritePolicyFlag = ReadE $ \case
-      "always" -> Right $ Flag AlwaysOverwrite
-      "never"  -> Right $ Flag NeverOverwrite
-      policy   -> Left  $ "'" <> policy <> "' isn't a valid overwrite policy"
-    showOverwritePolicyFlag (Flag AlwaysOverwrite) = ["always"]
-    showOverwritePolicyFlag (Flag NeverOverwrite)  = ["never"]
-    showOverwritePolicyFlag NoFlag                 = []
 
 installCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags
-                            , HaddockFlags, TestFlags, NewInstallFlags
+                            , HaddockFlags, TestFlags, ClientInstallFlags
                             )
 installCommand = CommandUI
   { commandName         = "v2-install"
@@ -182,8 +144,8 @@ installCommand = CommandUI
                           "v2-install" [ "[TARGETS] [FLAGS]" ]
   , commandDescription  = Just $ \_ -> wrapText $
     "Installs one or more packages. This is done by installing them "
-    ++ "in the store and symlinking the executables in the directory "
-    ++ "specified by the --symlink-bindir flag (`~/.cabal/bin/` by default). "
+    ++ "in the store and symlinking/copying the executables in the directory "
+    ++ "specified by the --installdir flag (`~/.cabal/bin/` by default). "
     ++ "If you want the installed executables to be available globally, "
     ++ "make sure that the PATH environment variable contains that directory. "
     ++ "\n\n"
@@ -211,9 +173,10 @@ installCommand = CommandUI
                  . optionName) $ configureOptions showOrParseArgs)
      ++ liftOptions get2 set2 (configureExOptions showOrParseArgs ConstraintSourceCommandlineFlag)
      ++ liftOptions get3 set3
-        -- hide "target-package-db" flag from the
+        -- hide "target-package-db" and "symlink-bindir" flags from the
         -- install options.
-        (filter ((`notElem` ["target-package-db"])
+        -- "symlink-bindir" is obsoleted by "installdir" in ClientInstallFlags
+        (filter ((`notElem` ["target-package-db", "symlink-bindir"])
                  . optionName) $
                                installOptions showOrParseArgs)
        ++ liftOptions get4 set4
@@ -223,8 +186,8 @@ installCommand = CommandUI
                   . optionName) $
                                 haddockOptions showOrParseArgs)
      ++ liftOptions get5 set5 (testOptions showOrParseArgs)
-     ++ liftOptions get6 set6 (newInstallOptions showOrParseArgs)
-  , commandDefaultFlags = (mempty, mempty, mempty, mempty, mempty, defaultNewInstallFlags)
+     ++ liftOptions get6 set6 (clientInstallOptions showOrParseArgs)
+  , commandDefaultFlags = (mempty, mempty, mempty, mempty, mempty, defaultClientInstallFlags)
   }
   where
     get1 (a,_,_,_,_,_) = a; set1 a (_,b,c,d,e,f) = (a,b,c,d,e,f)
@@ -241,7 +204,7 @@ installCommand = CommandUI
 --   install command, except that now conflicts between separate runs of the
 --   command are impossible thanks to the store.
 --   Exes are installed in the store like a normal dependency, then they are
---   symlinked uin the directory specified by --symlink-bindir.
+--   symlinked/copied in the directory specified by --installdir.
 --   To do this we need a dummy projectBaseContext containing the targets as
 --   estra packages and using a temporary dist directory.
 -- * libraries
@@ -252,9 +215,9 @@ installCommand = CommandUI
 -- For more details on how this works, see the module
 -- "Distribution.Client.ProjectOrchestration"
 --
-installAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags, NewInstallFlags)
+installAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags, ClientInstallFlags)
             -> [String] -> GlobalFlags -> IO ()
-installAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags, newInstallFlags)
+installAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags, clientInstallFlags')
             targetStrings globalFlags = do
   -- We never try to build tests/benchmarks for remote packages.
   -- So we set them as disabled by default and error if they are explicitly
@@ -266,6 +229,14 @@ installAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags
     die' verbosity $ "--enable-benchmarks was specified, but benchmarks can't "
                   ++ "be enabled in a remote package"
 
+  -- We cannot use establishDummyProjectBaseContext to get these flags, since
+  -- it requires one of them as an argument. Normal establishProjectBaseContext
+  -- does not, and this is why this is done only for the install command
+  clientInstallFlags <- do
+    let configFileFlag = globalConfigFile globalFlags
+    savedConfig <- loadConfig verbosity configFileFlag
+    pure $ savedClientInstallFlags savedConfig `mappend` clientInstallFlags'
+
   let
     withProject = do
       let verbosity' = lessVerbose verbosity
@@ -485,7 +456,7 @@ installAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags
       GhcEnvFilePackageId _ -> True
       _ -> False
 
-  envFile <- case flagToMaybe (ninstEnvironmentPath newInstallFlags) of
+  envFile <- case flagToMaybe (cinstEnvironmentPath clientInstallFlags) of
     Just spec
       -- Is spec a bare word without any "pathy" content, then it refers to
       -- a named global environment.
@@ -571,52 +542,53 @@ installAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags
     -- First, figure out if / what parts we want to install:
     let
       dryRun = buildSettingDryRun $ buildSettings baseCtx
-      installLibs = fromFlagOrDefault False (ninstInstallLibs newInstallFlags)
+      installLibs = fromFlagOrDefault False (cinstInstallLibs clientInstallFlags)
 
     -- Then, install!
     when (not dryRun) $
       if installLibs
       then installLibraries verbosity buildCtx compiler packageDbs progDb envFile envEntries'
-      else installExes verbosity baseCtx buildCtx compiler newInstallFlags
+      else installExes verbosity baseCtx buildCtx compiler clientInstallFlags
   where
     configFlags' = disableTestsBenchsByDefault configFlags
     verbosity = fromFlagOrDefault normal (configVerbosity configFlags')
     cliConfig = commandLineFlagsToProjectConfig
                   globalFlags configFlags' configExFlags
-                  installFlags haddockFlags testFlags
+                  installFlags clientInstallFlags'
+                  haddockFlags testFlags
     globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig)
 
--- | Install any built exe by symlinking it
+-- | Install any built exe by symlinking/copying it
 installExes :: Verbosity
             -> ProjectBaseContext
             -> ProjectBuildContext
             -> Compiler
-            -> NewInstallFlags
+            -> ClientInstallFlags
             -> IO ()
-installExes verbosity baseCtx buildCtx compiler newInstallFlags = do
+installExes verbosity baseCtx buildCtx compiler clientInstallFlags = do
+  -- XXX The comment in InstallSymlink.hs (pkgBinDir) says this is too naive (and it is)
   let mkPkgBinDir = (</> "bin") .
                     storePackageDirectory
                        (cabalStoreDirLayout $ cabalDirLayout baseCtx)
                        (compilerId compiler)
-      symlinkBindirUnknown =
-        "symlink-bindir is not defined. Set it in your cabal config file "
-        ++ "or use --symlink-bindir=<path>"
-  symlinkBindir <- fromFlagOrDefault (die' verbosity symlinkBindirUnknown)
-                $ fmap makeAbsolute
-                $ projectConfigSymlinkBinDir
-                $ projectConfigBuildOnly
-                $ projectConfig baseCtx
-  createDirectoryIfMissingVerbose verbosity False symlinkBindir
+      installdirUnknown =
+        "installdir is not defined. Set it in your cabal config file "
+        ++ "or use --installdir=<path>"
+  installdir <- fromFlagOrDefault (die' verbosity installdirUnknown)
+              $ pure <$> cinstInstalldir clientInstallFlags
+  createDirectoryIfMissingVerbose verbosity False installdir
   warnIfNoExes verbosity buildCtx
   let
-    doSymlink = symlinkBuiltPackage
+    doInstall = installPackageExes
                   verbosity
                   overwritePolicy
-                  mkPkgBinDir symlinkBindir
-    in traverse_ doSymlink $ Map.toList $ targetsMap buildCtx
+                  mkPkgBinDir installdir installMethod
+    in traverse_ doInstall $ Map.toList $ targetsMap buildCtx
   where
     overwritePolicy = fromFlagOrDefault NeverOverwrite
-                        $ ninstOverwritePolicy newInstallFlags
+                        $ cinstOverwritePolicy clientInstallFlags
+    installMethod    = fromFlagOrDefault InstallMethodSymlink
+                        $ cinstInstallMethod clientInstallFlags
 
 -- | Install any built library by adding it to the default ghc environment
 installLibraries :: Verbosity
@@ -700,49 +672,78 @@ disableTestsBenchsByDefault configFlags =
   configFlags { configTests = Flag False <> configTests configFlags
               , configBenchmarks = Flag False <> configBenchmarks configFlags }
 
--- | Symlink every exe from a package from the store to a given location
-symlinkBuiltPackage :: Verbosity
-                    -> OverwritePolicy -- ^ Whether to overwrite existing files
-                    -> (UnitId -> FilePath) -- ^ A function to get an UnitId's
-                                            -- store directory
-                    -> FilePath -- ^ Where to put the symlink
-                    -> ( UnitId
-                        , [(ComponentTarget, [TargetSelector])] )
-                     -> IO ()
-symlinkBuiltPackage verbosity overwritePolicy
-                    mkSourceBinDir destDir
-                    (pkg, components) =
-  traverse_ symlinkAndWarn exes
+-- | Symlink/copy every exe from a package from the store to a given location
+installPackageExes :: Verbosity
+                   -> OverwritePolicy -- ^ Whether to overwrite existing files
+                   -> (UnitId -> FilePath) -- ^ A function to get an UnitId's
+                                           -- store directory
+                   -> FilePath
+                   -> InstallMethod
+                   -> ( UnitId
+                       , [(ComponentTarget, [TargetSelector])] )
+                   -> IO ()
+installPackageExes verbosity overwritePolicy
+                   mkSourceBinDir
+                   installdir installMethod
+                   (pkg, components) =
+  traverse_ installAndWarn exes
   where
     exes = catMaybes $ (exeMaybe . fst) <$> components
     exeMaybe (ComponentTarget (CExeName exe) _) = Just exe
     exeMaybe _ = Nothing
-    symlinkAndWarn exe = do
-      success <- symlinkBuiltExe
+    installAndWarn exe = do
+      success <- installBuiltExe
                    verbosity overwritePolicy
-                   (mkSourceBinDir pkg) destDir exe
+                   (mkSourceBinDir pkg) exe
+                   installdir installMethod
       let errorMessage = case overwritePolicy of
                   NeverOverwrite ->
-                    "Path '" <> (destDir </> prettyShow exe) <> "' already exists. "
+                    "Path '" <> (installdir </> prettyShow exe) <> "' already exists. "
                     <> "Use --overwrite-policy=always to overwrite."
                   -- This shouldn't even be possible, but we keep it in case
-                  -- symlinking logic changes
-                  AlwaysOverwrite -> "Symlinking '" <> prettyShow exe <> "' failed."
+                  -- symlinking/copying logic changes
+                  AlwaysOverwrite -> case installMethod of
+                                       InstallMethodSymlink -> "Symlinking"
+                                       InstallMethodCopy    -> "Copying"
+                                  <> " '" <> prettyShow exe <> "' failed."
       unless success $ die' verbosity errorMessage
 
--- | Symlink a specific exe.
-symlinkBuiltExe :: Verbosity -> OverwritePolicy
-                -> FilePath -> FilePath
+-- | Install a specific exe.
+installBuiltExe :: Verbosity -> OverwritePolicy
+                -> FilePath
                 -> UnqualComponentName
+                -> FilePath
+                -> InstallMethod
                 -> IO Bool
-symlinkBuiltExe verbosity overwritePolicy sourceDir destDir exe = do
+installBuiltExe verbosity overwritePolicy
+                sourceDir exe
+                installdir InstallMethodSymlink = do
   notice verbosity $ "Symlinking '" <> prettyShow exe <> "'"
   symlinkBinary
     overwritePolicy
-    destDir
+    installdir
     sourceDir
     exe
     $ unUnqualComponentName exe
+installBuiltExe verbosity overwritePolicy
+                sourceDir exe
+                installdir InstallMethodCopy = do
+  notice verbosity $ "Copying '" <> prettyShow exe <> "'"
+  exists <- doesPathExist destination
+  case (exists, overwritePolicy) of
+    (True , NeverOverwrite ) -> pure False
+    (True , AlwaysOverwrite) -> remove >> copy
+    (False, _              ) -> copy
+  where
+    exeName = unUnqualComponentName exe
+    source = sourceDir </> exeName
+    destination = installdir </> exeName
+    remove = do
+      isDir <- doesDirectoryExist destination
+      if isDir
+      then removeDirectory destination
+      else removeFile      destination
+    copy = copyFile source destination >> pure True
 
 -- | Create 'GhcEnvironmentFileEntry's for packages with exposed libraries.
 entriesForLibraryComponents :: TargetsMap -> [GhcEnvironmentFileEntry]

cabal-install/Distribution/Client/CmdInstall/ClientInstallFlags.hs

+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE LambdaCase #-}
+module Distribution.Client.CmdInstall.ClientInstallFlags
+( InstallMethod(..)
+, ClientInstallFlags(..)
+, defaultClientInstallFlags
+, clientInstallOptions
+) where
+
+import Distribution.Client.Compat.Prelude
+
+import Distribution.ReadE
+         ( ReadE(..), succeedReadE )
+import Distribution.Simple.Command
+         ( ShowOrParseArgs(..), OptionField(..), option, reqArg )
+import Distribution.Simple.Setup
+         ( Flag(..), trueArg, flagToList, toFlag )
+
+import Distribution.Client.InstallSymlink
+         ( OverwritePolicy(..) )
+
+
+data InstallMethod = InstallMethodCopy
+                   | InstallMethodSymlink
+  deriving (Eq, Show, Generic, Bounded, Enum)
+
+instance Binary InstallMethod
+
+data ClientInstallFlags = ClientInstallFlags
+  { cinstInstallLibs :: Flag Bool
+  , cinstEnvironmentPath :: Flag FilePath
+  , cinstOverwritePolicy :: Flag OverwritePolicy
+  , cinstInstallMethod :: Flag InstallMethod
+  , cinstInstalldir :: Flag FilePath
+  } deriving (Eq, Show, Generic)
+
+instance Monoid ClientInstallFlags where
+  mempty = gmempty
+  mappend = (<>)
+
+instance Semigroup ClientInstallFlags where
+  (<>) = gmappend
+
+instance Binary ClientInstallFlags
+
+defaultClientInstallFlags :: ClientInstallFlags
+defaultClientInstallFlags = ClientInstallFlags
+  { cinstInstallLibs = toFlag False
+  , cinstEnvironmentPath = mempty
+  , cinstOverwritePolicy = toFlag NeverOverwrite
+  , cinstInstallMethod = toFlag InstallMethodSymlink
+  , cinstInstalldir = mempty
+  }
+
+clientInstallOptions :: ShowOrParseArgs -> [OptionField ClientInstallFlags]
+clientInstallOptions _ =
+  [ option [] ["lib"]
+    "Install libraries rather than executables from the target package."
+    cinstInstallLibs (\v flags -> flags { cinstInstallLibs = v })
+    trueArg
+  , option [] ["package-env", "env"]
+    "Set the environment file that may be modified."
+    cinstEnvironmentPath (\pf flags -> flags { cinstEnvironmentPath = pf })
+    (reqArg "ENV" (succeedReadE Flag) flagToList)
+  , option [] ["overwrite-policy"]
+    "How to handle already existing symlinks."