diff --git a/cabal-install/src/Distribution/Client/CmdInstall.hs b/cabal-install/src/Distribution/Client/CmdInstall.hs index cb032d2b712..5de704430f5 100644 --- a/cabal-install/src/Distribution/Client/CmdInstall.hs +++ b/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,46 @@ 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 + } + +-- | A record of install method, install directory and file path functions +-- needed by actions that either check if an install is possible or actually +-- perform an installation. This is for installation of executables only. +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 +296,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 +598,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 +626,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 +641,13 @@ installAction flags@NixStyleFlags{extraFlags = clientInstallFlags', ..} targetSt cliConfig = addLocalConfigToTargets baseCliConfig targetStrings globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig) + -- Do the install action for each executable in the install configuration. + traverseInstall :: InstallAction -> InstallCfg -> IO () + traverseInstall action cfg@InstallCfg{verbosity = v, buildCtx, installClientFlags} = do + let overwritePolicy = fromFlagOrDefault NeverOverwrite $ cinstOverwritePolicy installClientFlags + actionOnExe <- action v overwritePolicy <$> prepareExeInstall 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 +831,17 @@ 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 +-- | From an install configuration, prepare the record needed by actions that +-- will either check if an install of a single executable is possible or +-- actually perform its installation. +prepareExeInstall :: InstallCfg -> IO InstallExe +prepareExeInstall + 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 +861,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 +1004,49 @@ 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 +-- | Prepares a record containing the information needed to either symlink or +-- copy an executable. +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 +1055,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 +1097,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 diff --git a/cabal-install/src/Distribution/Client/InstallSymlink.hs b/cabal-install/src/Distribution/Client/InstallSymlink.hs index cf57c54818e..13e29a44d81 100644 --- a/cabal-install/src/Distribution/Client/InstallSymlink.hs +++ b/cabal-install/src/Distribution/Client/InstallSymlink.hs @@ -1,5 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} ----------------------------------------------------------------------------- @@ -16,8 +18,10 @@ -- -- Managing installing binaries with symlinks. module Distribution.Client.InstallSymlink - ( symlinkBinaries + ( Symlink (..) + , symlinkBinaries , symlinkBinary + , symlinkableBinary , trySymlink , promptRun ) where @@ -150,11 +154,13 @@ symlinkBinaries privateBinDir <- pkgBinDir pkg ipid ok <- symlinkBinary - overwritePolicy - publicBinDir - privateBinDir - (prettyShow publicExeName) - privateExeName + ( Symlink + overwritePolicy + publicBinDir + privateBinDir + (prettyShow publicExeName) + privateExeName + ) if ok then return Nothing else @@ -247,50 +253,80 @@ symlinkBinaries cinfo = compilerInfo comp (CompilerId compilerFlavor _) = compilerInfoId cinfo --- | Symlink binary. --- --- The paths are take in pieces, so we can make relative link when possible. -symlinkBinary - :: OverwritePolicy - -- ^ Whether to force overwrite an existing file - -> FilePath - -- ^ The canonical path of the public bin dir eg - -- @/home/user/bin@ - -> FilePath - -- ^ The canonical path of the private bin dir eg - -- @/home/user/.cabal/bin@ - -> FilePath - -- ^ The name of the executable to go in the public bin - -- dir, eg @foo@ - -> String - -- ^ The name of the executable to in the private bin - -- dir, eg @foo-1.0@ - -> IO Bool - -- ^ If creating the symlink was successful. @False@ if - -- there was another file there already that we did - -- not own. Other errors like permission errors just - -- propagate as exceptions. -symlinkBinary overwritePolicy publicBindir privateBindir publicName privateName = do +-- | A record needed to either check if a symlink is possible or to create a +-- symlink. Also used if copying instead of symlinking. +data Symlink = Symlink + { overwritePolicy :: OverwritePolicy + -- ^ Whether to force overwrite an existing file. + , publicBindir :: FilePath + -- ^ The canonical path of the public bin dir eg @/home/user/bin@. + , privateBindir :: FilePath + -- ^ The canonical path of the private bin dir eg @/home/user/.cabal/bin@. + , publicName :: FilePath + -- ^ The name of the executable to go in the public bin dir, eg @foo@. + , privateName :: String + -- ^ The name of the executable to in the private bin dir, eg @foo-1.0@. + } + +-- | After checking if a target is writeable given the overwrite policy, +-- dispatch to an appropriate action; +-- * @onMissing@ if the target doesn't exist +-- * @onOverwrite@ if the target exists and we are allowed to overwrite it +-- * @onNever@ if the target exists and we are never allowed to overwrite it +-- * @onPrompt@ if the target exists and we are allowed to overwrite after prompting +onSymlinkBinary + :: IO a + -- ^ Missing action + -> IO a + -- ^ Overwrite action + -> IO a + -- ^ Never action + -> IO a + -- ^ Prompt action + -> Symlink + -> IO a +onSymlinkBinary onMissing onOverwrite onNever onPrompt Symlink{..} = do ok <- targetOkToOverwrite (publicBindir publicName) (privateBindir privateName) case ok of - NotExists -> mkLink - OkToOverwrite -> overwrite + NotExists -> onMissing + OkToOverwrite -> onOverwrite NotOurFile -> case overwritePolicy of - NeverOverwrite -> return False - AlwaysOverwrite -> overwrite - PromptOverwrite -> maybeOverwrite + NeverOverwrite -> onNever + AlwaysOverwrite -> onOverwrite + PromptOverwrite -> onPrompt + +-- | Can we symlink a binary? +-- +-- @True@ if creating the symlink would be succeed, being optimistic that the user will +-- agree if prompted to overwrite. +symlinkableBinary :: Symlink -> IO Bool +symlinkableBinary = onSymlinkBinary (return True) (return True) (return False) (return True) + +-- | Symlink binary. +-- +-- The paths are take in pieces, so we can make relative link when possible. +-- @True@ if creating the symlink was successful. @False@ if there was another +-- file there already that we did not own. Other errors like permission errors +-- just propagate as exceptions. +symlinkBinary :: Symlink -> IO Bool +symlinkBinary inputs@Symlink{publicBindir, privateBindir, publicName, privateName} = do + onSymlinkBinary mkLink overwrite (return False) maybeOverwrite inputs where relativeBindir = makeRelative publicBindir privateBindir + mkLink :: IO Bool mkLink = True <$ createFileLink (relativeBindir privateName) (publicBindir publicName) + rmLink :: IO Bool rmLink = True <$ removeFile (publicBindir publicName) + overwrite :: IO Bool overwrite = rmLink *> mkLink + maybeOverwrite :: IO Bool maybeOverwrite = promptRun diff --git a/cabal-testsuite/PackageTests/WarnEarlyOverwrite/WarnEarlyOverwrite.cabal b/cabal-testsuite/PackageTests/WarnEarlyOverwrite/WarnEarlyOverwrite.cabal new file mode 100644 index 00000000000..a630a95551e --- /dev/null +++ b/cabal-testsuite/PackageTests/WarnEarlyOverwrite/WarnEarlyOverwrite.cabal @@ -0,0 +1,16 @@ +cabal-version: 3.0 +name: WarnEarlyOverwrite +version: 0.1.0.0 +license: BSD-3-Clause +author: Phil de Joux +build-type: Simple + +common warnings + ghc-options: -Wall + +executable warn-early-overwrite + import: warnings + main-is: Main.hs + build-depends: base + hs-source-dirs: app + default-language: Haskell2010 diff --git a/cabal-testsuite/PackageTests/WarnEarlyOverwrite/app/Main.hs b/cabal-testsuite/PackageTests/WarnEarlyOverwrite/app/Main.hs new file mode 100644 index 00000000000..9e6d506d89d --- /dev/null +++ b/cabal-testsuite/PackageTests/WarnEarlyOverwrite/app/Main.hs @@ -0,0 +1,4 @@ +module Main where + +main :: IO () +main = putStrLn "Early warning" diff --git a/cabal-testsuite/PackageTests/WarnEarlyOverwrite/cabal.project b/cabal-testsuite/PackageTests/WarnEarlyOverwrite/cabal.project new file mode 100644 index 00000000000..5356e76f67c --- /dev/null +++ b/cabal-testsuite/PackageTests/WarnEarlyOverwrite/cabal.project @@ -0,0 +1 @@ +packages: . \ No newline at end of file diff --git a/cabal-testsuite/PackageTests/WarnEarlyOverwrite/clean-install-by-copy.out b/cabal-testsuite/PackageTests/WarnEarlyOverwrite/clean-install-by-copy.out new file mode 100644 index 00000000000..16279ab51e4 --- /dev/null +++ b/cabal-testsuite/PackageTests/WarnEarlyOverwrite/clean-install-by-copy.out @@ -0,0 +1,12 @@ +# cabal v2-install +Wrote tarball sdist to /clean-install-by-copy.dist/work/./dist/sdist/WarnEarlyOverwrite-0.1.0.0.tar.gz +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - WarnEarlyOverwrite-0.1.0.0 (exe:warn-early-overwrite) (requires build) +Configuring executable 'warn-early-overwrite' for WarnEarlyOverwrite-0.1.0.0... +Preprocessing executable 'warn-early-overwrite' for WarnEarlyOverwrite-0.1.0.0... +Building executable 'warn-early-overwrite' for WarnEarlyOverwrite-0.1.0.0... +Installing executable warn-early-overwrite in +Warning: The directory /ghc-/incoming/new-/ghc-/-/bin is not in the system search path. +Copying 'warn-early-overwrite' to '/warn-early-overwrite' diff --git a/cabal-testsuite/PackageTests/WarnEarlyOverwrite/clean-install-by-copy.test.hs b/cabal-testsuite/PackageTests/WarnEarlyOverwrite/clean-install-by-copy.test.hs new file mode 100644 index 00000000000..af7d6f33625 --- /dev/null +++ b/cabal-testsuite/PackageTests/WarnEarlyOverwrite/clean-install-by-copy.test.hs @@ -0,0 +1,13 @@ +import Test.Cabal.Prelude + +main = withShorterPathForNewBuildStore $ \storeDir -> cabalTest $ do + let options = ["--store-dir=" ++ storeDir, "--installdir=" ++ storeDir] + -- Use install method copy that should surely work on Windows too but our + -- path normalization for testing is not good enough yet as can be seen in + -- this CI failure snippet diff: + -- -Warning: The directory /ghc-/incoming/new-/ghc-/-/bin is not in the system search path. + -- -Copying 'warn-early-overwrite' to '/warn-early-overwrite' + -- +Warning: The directory /incoming/new-2448/Users/RUNNER~1/AppData/Local/Temp/cabal-test-store-28260/ghc-/WarnEarlyOver_-0.1.0.0-4c19059e06a32b93b2812983631117e77a2d3833/bin is not in the system search path. + -- +Copying 'warn-early-overwrite' to '' + skipIfWindows + cabalG options "v2-install" ["--install-method=copy"] \ No newline at end of file diff --git a/cabal-testsuite/PackageTests/WarnEarlyOverwrite/clean-install-by-symlink.out b/cabal-testsuite/PackageTests/WarnEarlyOverwrite/clean-install-by-symlink.out new file mode 100644 index 00000000000..ad487891384 --- /dev/null +++ b/cabal-testsuite/PackageTests/WarnEarlyOverwrite/clean-install-by-symlink.out @@ -0,0 +1,12 @@ +# cabal v2-install +Wrote tarball sdist to /clean-install-by-symlink.dist/work/./dist/sdist/WarnEarlyOverwrite-0.1.0.0.tar.gz +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - WarnEarlyOverwrite-0.1.0.0 (exe:warn-early-overwrite) (requires build) +Configuring executable 'warn-early-overwrite' for WarnEarlyOverwrite-0.1.0.0... +Preprocessing executable 'warn-early-overwrite' for WarnEarlyOverwrite-0.1.0.0... +Building executable 'warn-early-overwrite' for WarnEarlyOverwrite-0.1.0.0... +Installing executable warn-early-overwrite in +Warning: The directory /ghc-/incoming/new-/ghc-/-/bin is not in the system search path. +Symlinking 'warn-early-overwrite' to '/warn-early-overwrite' diff --git a/cabal-testsuite/PackageTests/WarnEarlyOverwrite/clean-install-by-symlink.test.hs b/cabal-testsuite/PackageTests/WarnEarlyOverwrite/clean-install-by-symlink.test.hs new file mode 100644 index 00000000000..1fa303cb2bc --- /dev/null +++ b/cabal-testsuite/PackageTests/WarnEarlyOverwrite/clean-install-by-symlink.test.hs @@ -0,0 +1,7 @@ +import Test.Cabal.Prelude + +main = withShorterPathForNewBuildStore $ \storeDir -> cabalTest $ do + -- The default install method is symlink that may not work on Windows. + skipIfWindows + let options = ["--store-dir=" ++ storeDir, "--installdir=" ++ storeDir] + cabalG options "v2-install" [] \ No newline at end of file diff --git a/cabal-testsuite/PackageTests/WarnEarlyOverwrite/dirty-install.out b/cabal-testsuite/PackageTests/WarnEarlyOverwrite/dirty-install.out new file mode 100644 index 00000000000..3a813eebf45 --- /dev/null +++ b/cabal-testsuite/PackageTests/WarnEarlyOverwrite/dirty-install.out @@ -0,0 +1,20 @@ +# cabal v2-install +Wrote tarball sdist to /dirty-install.dist/work/./dist/sdist/WarnEarlyOverwrite-0.1.0.0.tar.gz +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - WarnEarlyOverwrite-0.1.0.0 (exe:warn-early-overwrite) (requires build) +Error: [Cabal-7149] +Path '/warn-early-overwrite' already exists. Use --overwrite-policy=always to overwrite. +# cabal v2-install +Wrote tarball sdist to /dirty-install.dist/work/./dist/sdist/WarnEarlyOverwrite-0.1.0.0.tar.gz +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - WarnEarlyOverwrite-0.1.0.0 (exe:warn-early-overwrite) (requires build) +Configuring executable 'warn-early-overwrite' for WarnEarlyOverwrite-0.1.0.0... +Preprocessing executable 'warn-early-overwrite' for WarnEarlyOverwrite-0.1.0.0... +Building executable 'warn-early-overwrite' for WarnEarlyOverwrite-0.1.0.0... +Installing executable warn-early-overwrite in +Warning: The directory /ghc-/incoming/new-/ghc-/-/bin is not in the system search path. +Symlinking 'warn-early-overwrite' to '/warn-early-overwrite' diff --git a/cabal-testsuite/PackageTests/WarnEarlyOverwrite/dirty-install.test.hs b/cabal-testsuite/PackageTests/WarnEarlyOverwrite/dirty-install.test.hs new file mode 100644 index 00000000000..6578a891c0d --- /dev/null +++ b/cabal-testsuite/PackageTests/WarnEarlyOverwrite/dirty-install.test.hs @@ -0,0 +1,13 @@ +import Test.Cabal.Prelude + +import System.FilePath + +main = withShorterPathForNewBuildStore $ \storeDir -> cabalTest $ do + -- Windows does not natively include a touch command. + -- SEE: https://stackoverflow.com/questions/30011267/create-an-empty-file-on-the-commandline-in-windows-like-the-linux-touch-command + skipIfWindows + let options = ["--store-dir=" ++ storeDir, "--installdir=" ++ storeDir] + -- Touch the target to see if the warning is made early before the build. + _ <- runM "touch" [storeDir "warn-early-overwrite"] Nothing + fails $ cabalG options "v2-install" [] + cabalG options "v2-install" ["--overwrite-policy=always"] \ No newline at end of file diff --git a/changelog.d/issue-5993 b/changelog.d/issue-5993 new file mode 100644 index 00000000000..47580dd57cb --- /dev/null +++ b/changelog.d/issue-5993 @@ -0,0 +1,9 @@ +synopsis: Warn early that overwrite policy is needed +description: + Waiting for a long build and then seeing the install fail because a flag was + missing is frustrating. With this change we skip the wait and warn early, + before the build, that an overwrite policy flag would be needed for the + install to succeed. +packages: cabal-install +prs: #9268 +issues: #5993