Warn early overwrite expanded

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

@@ -53,8 +53,10 @@ import Distribution.Client.IndexUtils
   )
 import qualified Distribution.Client.InstallPlan as InstallPlan
 import Distribution.Client.InstallSymlink
-  ( promptRun
+  ( Symlink (..)
+  , promptRun
   , symlinkBinary
+  , symlinkableBinary
   , trySymlink
   )
 import Distribution.Client.NixStyleOptions
@@ -242,6 +244,43 @@ import System.FilePath
   , (</>)
   )
 
+-- | Check or check then install an exe. The check is to see if the overwrite
+-- policy allows installation.
+data InstallCheck
+  = -- | Only check if install is permitted.
+    InstallCheckOnly
+  | -- | Actually install but check first if permitted.
+    InstallCheckInstall
+
+type InstallAction =
+  Verbosity
+  -> OverwritePolicy
+  -> InstallExe
+  -> (UnitId, [(ComponentTarget, NonEmpty TargetSelector)])
+  -> IO ()
+
+data InstallCfg = InstallCfg
+  { verbosity :: Verbosity
+  , baseCtx :: ProjectBaseContext
+  , buildCtx :: ProjectBuildContext
+  , platform :: Platform
+  , compiler :: Compiler
+  , installConfigFlags :: ConfigFlags
+  , installClientFlags :: ClientInstallFlags
+  }
+
+data InstallExe = InstallExe
+  { installMethod :: InstallMethod
+  , installDir :: FilePath
+  , mkSourceBinDir :: UnitId -> FilePath
+  -- ^ A function to get an UnitId's store directory.
+  , mkExeName :: UnqualComponentName -> FilePath
+  -- ^ A function to get an exe's filename.
+  , mkFinalExeName :: UnqualComponentName -> FilePath
+  -- ^ A function to get an exe's final possibly different to the name in the
+  -- store.
+  }
+
 installCommand :: CommandUI (NixStyleFlags ClientInstallFlags)
 installCommand =
   CommandUI
@@ -254,7 +293,7 @@ installCommand =
     , commandDescription = Just $ \_ ->
         wrapText $
           "Installs one or more packages. This is done by installing them "
-            ++ "in the store and symlinking/copying the executables in the directory "
+            ++ "in the store and symlinking or copying the executables in the directory "
             ++ "specified by the --installdir flag (`~/.local/bin/` by default). "
             ++ "If you want the installed executables to be available globally, "
             ++ "make sure that the PATH environment variable contains that directory. "
@@ -556,18 +595,23 @@ installAction flags@NixStyleFlags{extraFlags = clientInstallFlags', ..} targetSt
     buildCtx <- constructProjectBuildContext verbosity (baseCtx{installedPackages = Just installedIndex'}) targetSelectors
 
     printPlan verbosity baseCtx buildCtx
+    let installCfg = InstallCfg verbosity baseCtx buildCtx platform compiler configFlags clientInstallFlags
 
-    buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx
-    runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes
-
-    -- Now that we built everything we can do the installation part.
-    -- First, figure out if / what parts we want to install:
     let
       dryRun =
         buildSettingDryRun (buildSettings baseCtx)
           || buildSettingOnlyDownload (buildSettings baseCtx)
 
-    -- Then, install!
+    -- Before building, check if we could install any built exe by symlinking or
+    -- copying it?
+    unless
+      (dryRun || installLibs)
+      (traverseInstall (installCheckUnitExes InstallCheckOnly) installCfg)
+
+    buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx
+    runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes
+
+    -- Having built everything, do the install.
     unless dryRun $
       if installLibs
         then
@@ -579,15 +623,9 @@ installAction flags@NixStyleFlags{extraFlags = clientInstallFlags', ..} targetSt
             packageDbs
             envFile
             nonGlobalEnvEntries'
-        else
-          installExes
-            verbosity
-            baseCtx
-            buildCtx
-            platform
-            compiler
-            configFlags
-            clientInstallFlags
+        else -- Install any built exe by symlinking or copying it we don't use
+        -- BuildOutcomes because we also need the component names
+          traverseInstall (installCheckUnitExes InstallCheckInstall) installCfg
   where
     configFlags' = disableTestsBenchsByDefault configFlags
     verbosity = fromFlagOrDefault normal (configVerbosity configFlags')
@@ -600,6 +638,12 @@ installAction flags@NixStyleFlags{extraFlags = clientInstallFlags', ..} targetSt
     cliConfig = addLocalConfigToTargets baseCliConfig targetStrings
     globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig)
 
+    traverseInstall :: InstallAction -> InstallCfg -> IO ()
+    traverseInstall action cfg@InstallCfg{verbosity = v, buildCtx, installClientFlags} = do
+      let overwritePolicy = fromFlagOrDefault NeverOverwrite $ cinstOverwritePolicy installClientFlags
+      actionOnExe <- action v overwritePolicy <$> installExesPrep cfg
+      traverse_ actionOnExe . Map.toList $ targetsMap buildCtx
+
 -- | Treat all direct targets of install command as local packages: #8637
 addLocalConfigToTargets :: ProjectConfig -> [String] -> ProjectConfig
 addLocalConfigToTargets config targetStrings =
@@ -783,30 +827,14 @@ constructProjectBuildContext verbosity baseCtx targetSelectors = do
 
     return (prunedElaboratedPlan, targets)
 
--- | Install any built exe by symlinking/copying it
--- we don't use BuildOutcomes because we also need the component names
-installExes
-  :: Verbosity
-  -> ProjectBaseContext
-  -> ProjectBuildContext
-  -> Platform
-  -> Compiler
-  -> ConfigFlags
-  -> ClientInstallFlags
-  -> IO ()
-installExes
-  verbosity
-  baseCtx
-  buildCtx
-  platform
-  compiler
-  configFlags
-  clientInstallFlags = do
+installExesPrep :: InstallCfg -> IO InstallExe
+installExesPrep
+  InstallCfg{verbosity, baseCtx, buildCtx, platform, compiler, installConfigFlags, installClientFlags} = do
     installPath <- defaultInstallPath
     let storeDirLayout = cabalStoreDirLayout $ cabalDirLayout baseCtx
 
-        prefix = fromFlagOrDefault "" (fmap InstallDirs.fromPathTemplate (configProgPrefix configFlags))
-        suffix = fromFlagOrDefault "" (fmap InstallDirs.fromPathTemplate (configProgSuffix configFlags))
+        prefix = fromFlagOrDefault "" (fmap InstallDirs.fromPathTemplate (configProgPrefix installConfigFlags))
+        suffix = fromFlagOrDefault "" (fmap InstallDirs.fromPathTemplate (configProgSuffix installConfigFlags))
 
         mkUnitBinDir :: UnitId -> FilePath
         mkUnitBinDir =
@@ -826,42 +854,24 @@ installExes
     installdir <-
       fromFlagOrDefault
         (warn verbosity installdirUnknown >> pure installPath)
-        $ pure <$> cinstInstalldir clientInstallFlags
+        $ pure <$> cinstInstalldir installClientFlags
     createDirectoryIfMissingVerbose verbosity True installdir
     warnIfNoExes verbosity buildCtx
 
-    installMethod <-
-      flagElim defaultMethod return $
-        cinstInstallMethod clientInstallFlags
+    -- This is in IO as we will make environment checks, to decide which install
+    -- method is best.
+    let defaultMethod :: IO InstallMethod
+        defaultMethod
+          -- Try symlinking in temporary directory, if it works default to
+          -- symlinking even on windows.
+          | buildOS == Windows = do
+              symlinks <- trySymlink verbosity
+              return $ if symlinks then InstallMethodSymlink else InstallMethodCopy
+          | otherwise = return InstallMethodSymlink
 
-    let
-      doInstall =
-        installUnitExes
-          verbosity
-          overwritePolicy
-          mkUnitBinDir
-          mkExeName
-          mkFinalExeName
-          installdir
-          installMethod
-     in
-      traverse_ doInstall $ Map.toList $ targetsMap buildCtx
-    where
-      overwritePolicy =
-        fromFlagOrDefault NeverOverwrite $
-          cinstOverwritePolicy clientInstallFlags
-      isWindows = buildOS == Windows
-
-      -- This is in IO as we will make environment checks,
-      -- to decide which method is best
-      defaultMethod :: IO InstallMethod
-      defaultMethod
-        -- Try symlinking in temporary directory, if it works default to
-        -- symlinking even on windows
-        | isWindows = do
-            symlinks <- trySymlink verbosity
-            return $ if symlinks then InstallMethodSymlink else InstallMethodCopy
-        | otherwise = return InstallMethodSymlink
+    installMethod <- flagElim defaultMethod return $ cinstInstallMethod installClientFlags
+
+    return $ InstallExe installMethod installdir mkUnitBinDir mkExeName mkFinalExeName
 
 -- | Install any built library by adding it to the default ghc environment
 installLibraries
@@ -987,41 +997,47 @@ disableTestsBenchsByDefault configFlags =
     , configBenchmarks = Flag False <> configBenchmarks configFlags
     }
 
--- | Symlink/copy every exe from a package from the store to a given location
-installUnitExes
-  :: Verbosity
-  -> OverwritePolicy
-  -- ^ Whether to overwrite existing files
-  -> (UnitId -> FilePath)
-  -- ^ A function to get an UnitId's
-  -- ^ store directory
-  -> (UnqualComponentName -> FilePath)
-  -- ^ A function to get an
-  -- ^ exe's filename
-  -> (UnqualComponentName -> FilePath)
-  -- ^ A function to get an
-  -- ^ exe's final possibly
-  -- ^ different to the name in the store.
-  -> FilePath
-  -> InstallMethod
-  -> ( UnitId
-     , [(ComponentTarget, NonEmpty TargetSelector)]
-     )
-  -> IO ()
-installUnitExes
+symlink :: OverwritePolicy -> InstallExe -> UnitId -> UnqualComponentName -> Symlink
+symlink
+  overwritePolicy
+  InstallExe{installDir, mkSourceBinDir, mkExeName, mkFinalExeName}
+  unit
+  exe =
+    Symlink
+      overwritePolicy
+      installDir
+      (mkSourceBinDir unit)
+      (mkExeName exe)
+      (mkFinalExeName exe)
+
+-- |
+-- -- * When 'InstallCheckOnly', warn if install would fail overwrite policy
+--      checks but don't install anything.
+-- -- * When 'InstallCheckInstall', try to symlink or copy every package exe
+--      from the store to a given location. When not permitted by the overwrite
+--      policy, stop with a message.
+installCheckUnitExes :: InstallCheck -> InstallAction
+installCheckUnitExes
+  installCheck
   verbosity
   overwritePolicy
-  mkSourceBinDir
-  mkExeName
-  mkFinalExeName
-  installdir
-  installMethod
-  (unit, components) =
-    traverse_ installAndWarn exes
+  installExe@InstallExe{installMethod, installDir, mkSourceBinDir, mkExeName, mkFinalExeName}
+  (unit, components) = do
+    symlinkables :: [Bool] <- traverse (symlinkableBinary . symlink overwritePolicy installExe unit) exes
+    case installCheck of
+      InstallCheckOnly -> traverse_ warnAbout (zip symlinkables exes)
+      InstallCheckInstall ->
+        if and symlinkables
+          then traverse_ installAndWarn exes
+          else traverse_ warnAbout (zip symlinkables exes)
     where
       exes = catMaybes $ (exeMaybe . fst) <$> components
       exeMaybe (ComponentTarget (CExeName exe) _) = Just exe
       exeMaybe _ = Nothing
+
+      warnAbout (True, _) = return ()
+      warnAbout (False, exe) = dieWithException verbosity $ InstallUnitExes (errorMessage installDir exe)
+
       installAndWarn exe = do
         success <-
           installBuiltExe
@@ -1030,22 +1046,22 @@ installUnitExes
             (mkSourceBinDir unit)
             (mkExeName exe)
             (mkFinalExeName exe)
-            installdir
+            installDir
             installMethod
-        let errorMessage = case overwritePolicy of
-              NeverOverwrite ->
-                "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/copying logic changes
-              _ ->
-                case installMethod of
-                  InstallMethodSymlink -> "Symlinking"
-                  InstallMethodCopy ->
-                    "Copying" <> " '" <> prettyShow exe <> "' failed."
-        unless success $ dieWithException verbosity $ InstallUnitExes errorMessage
+        unless success $ dieWithException verbosity $ InstallUnitExes (errorMessage installDir exe)
+
+      errorMessage installdir exe = case overwritePolicy of
+        NeverOverwrite ->
+          "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 or
+        -- copying logic changes.
+        _ ->
+          case installMethod of
+            InstallMethodSymlink -> "Symlinking"
+            InstallMethodCopy -> "Copying" <> " '" <> prettyShow exe <> "' failed."
 
 -- | Install a specific exe.
 installBuiltExe
@@ -1072,11 +1088,13 @@ installBuiltExe
   InstallMethodSymlink = do
     notice verbosity $ "Symlinking '" <> exeName <> "' to '" <> destination <> "'"
     symlinkBinary
-      overwritePolicy
-      installdir
-      sourceDir
-      finalExeName
-      exeName
+      ( Symlink
+          overwritePolicy
+          installdir
+          sourceDir
+          finalExeName
+          exeName
+      )
     where
       destination = installdir </> finalExeName
 installBuiltExe