From 09c04e9aca5de2ca391eb859a5b295fdd617f5c6 Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Sat, 16 Sep 2023 21:21:49 -0400 Subject: [PATCH 1/5] Check if install possible before building * Add symlinkableBinary * Extract installExesPrep * Add data InstallExe and data Symlink * Replace symlinkable with symlink taking InstallExe * Replace symlink/copy as symlink or copy * Improve a haddock, from check to try and stop * Get rid of duplication between install*Exes * Add InstallCfg * Drop the cfg prefix * Make errorMessage a where nested local * Add haddocks to InstallCheck --- .../src/Distribution/Client/CmdInstall.hs | 256 ++++++++++-------- .../src/Distribution/Client/InstallSymlink.hs | 110 +++++--- 2 files changed, 208 insertions(+), 158 deletions(-) diff --git a/cabal-install/src/Distribution/Client/CmdInstall.hs b/cabal-install/src/Distribution/Client/CmdInstall.hs index cb032d2b712..0917eb6b54b 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,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 diff --git a/cabal-install/src/Distribution/Client/InstallSymlink.hs b/cabal-install/src/Distribution/Client/InstallSymlink.hs index cf57c54818e..8025153531a 100644 --- a/cabal-install/src/Distribution/Client/InstallSymlink.hs +++ b/cabal-install/src/Distribution/Client/InstallSymlink.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE NamedFieldPuns #-} ----------------------------------------------------------------------------- @@ -16,8 +17,10 @@ -- -- Managing installing binaries with symlinks. module Distribution.Client.InstallSymlink - ( symlinkBinaries + ( Symlink (..) + , symlinkBinaries , symlinkBinary + , symlinkableBinary , trySymlink , promptRun ) where @@ -150,11 +153,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 +252,77 @@ symlinkBinaries cinfo = compilerInfo comp (CompilerId compilerFlavor _) = compilerInfoId cinfo +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@. + } + +-- | How to handle symlinking a binary. +onSymlinkBinary + :: IO a + -- ^ Missing action + -> IO a + -- ^ Overwrite action + -> IO a + -- ^ Never action + -> IO a + -> Symlink + -> IO a +onSymlinkBinary + onMissing + onOverwrite + onNever + onPrompt + Symlink{overwritePolicy, publicBindir, privateBindir, publicName, privateName} = do + ok <- + targetOkToOverwrite + (publicBindir publicName) + (privateBindir privateName) + case ok of + NotExists -> onMissing + OkToOverwrite -> onOverwrite + NotOurFile -> + case overwritePolicy of + 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. -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 - ok <- - targetOkToOverwrite - (publicBindir publicName) - (privateBindir privateName) - case ok of - NotExists -> mkLink - OkToOverwrite -> overwrite - NotOurFile -> - case overwritePolicy of - NeverOverwrite -> return False - AlwaysOverwrite -> overwrite - PromptOverwrite -> maybeOverwrite +-- @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 From 255e2e08c41bedfb43bdc3ffefc6b8263d30849c Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Sat, 21 Oct 2023 14:56:25 -0400 Subject: [PATCH 2/5] Add dirty and clean install tests * Add project to avoid solver errors * SkipIfWindows for warn early overwrite tests * Windows does not natively include a touch command * Skip symlink install on windows * Add install by copy test and skip symlink install for Windows --- .../WarnEarlyOverwrite.cabal | 16 +++++++++++++++ .../WarnEarlyOverwrite/app/Main.hs | 4 ++++ .../WarnEarlyOverwrite/cabal.project | 1 + .../clean-install-by-copy.out | 12 +++++++++++ .../clean-install-by-copy.test.hs | 13 ++++++++++++ .../clean-install-by-symlink.out | 12 +++++++++++ .../clean-install-by-symlink.test.hs | 7 +++++++ .../WarnEarlyOverwrite/dirty-install.out | 20 +++++++++++++++++++ .../WarnEarlyOverwrite/dirty-install.test.hs | 13 ++++++++++++ 9 files changed, 98 insertions(+) create mode 100644 cabal-testsuite/PackageTests/WarnEarlyOverwrite/WarnEarlyOverwrite.cabal create mode 100644 cabal-testsuite/PackageTests/WarnEarlyOverwrite/app/Main.hs create mode 100644 cabal-testsuite/PackageTests/WarnEarlyOverwrite/cabal.project create mode 100644 cabal-testsuite/PackageTests/WarnEarlyOverwrite/clean-install-by-copy.out create mode 100644 cabal-testsuite/PackageTests/WarnEarlyOverwrite/clean-install-by-copy.test.hs create mode 100644 cabal-testsuite/PackageTests/WarnEarlyOverwrite/clean-install-by-symlink.out create mode 100644 cabal-testsuite/PackageTests/WarnEarlyOverwrite/clean-install-by-symlink.test.hs create mode 100644 cabal-testsuite/PackageTests/WarnEarlyOverwrite/dirty-install.out create mode 100644 cabal-testsuite/PackageTests/WarnEarlyOverwrite/dirty-install.test.hs 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 From 4606c3519ddaad5c544763f23e2c55776dc69e4e Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Sun, 17 Sep 2023 09:47:05 -0400 Subject: [PATCH 3/5] Add changelog entry --- changelog.d/issue-5993 | 9 +++++++++ 1 file changed, 9 insertions(+) create mode 100644 changelog.d/issue-5993 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 From eb46bdca48798d2b6ea3784018919351058cda84 Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Tue, 12 Dec 2023 14:52:42 -0500 Subject: [PATCH 4/5] Add symlink and install exe haddocks As requested in review --- .../src/Distribution/Client/CmdInstall.hs | 15 ++++++++++++--- .../src/Distribution/Client/InstallSymlink.hs | 10 +++++++++- 2 files changed, 21 insertions(+), 4 deletions(-) diff --git a/cabal-install/src/Distribution/Client/CmdInstall.hs b/cabal-install/src/Distribution/Client/CmdInstall.hs index 0917eb6b54b..5de704430f5 100644 --- a/cabal-install/src/Distribution/Client/CmdInstall.hs +++ b/cabal-install/src/Distribution/Client/CmdInstall.hs @@ -269,6 +269,9 @@ data InstallCfg = InstallCfg , 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 @@ -638,10 +641,11 @@ 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 <$> installExesPrep cfg + actionOnExe <- action v overwritePolicy <$> prepareExeInstall cfg traverse_ actionOnExe . Map.toList $ targetsMap buildCtx -- | Treat all direct targets of install command as local packages: #8637 @@ -827,8 +831,11 @@ constructProjectBuildContext verbosity baseCtx targetSelectors = do return (prunedElaboratedPlan, targets) -installExesPrep :: InstallCfg -> IO InstallExe -installExesPrep +-- | 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 @@ -997,6 +1004,8 @@ disableTestsBenchsByDefault configFlags = , configBenchmarks = Flag False <> configBenchmarks configFlags } +-- | Prepares a record containing the information needed to either symlink or +-- copy an executable. symlink :: OverwritePolicy -> InstallExe -> UnitId -> UnqualComponentName -> Symlink symlink overwritePolicy diff --git a/cabal-install/src/Distribution/Client/InstallSymlink.hs b/cabal-install/src/Distribution/Client/InstallSymlink.hs index 8025153531a..f453bc15d14 100644 --- a/cabal-install/src/Distribution/Client/InstallSymlink.hs +++ b/cabal-install/src/Distribution/Client/InstallSymlink.hs @@ -252,6 +252,8 @@ symlinkBinaries cinfo = compilerInfo comp (CompilerId compilerFlavor _) = compilerInfoId cinfo +-- | 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. @@ -265,7 +267,12 @@ data Symlink = Symlink -- ^ The name of the executable to in the private bin dir, eg @foo-1.0@. } --- | How to handle symlinking a binary. +-- | 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 @@ -274,6 +281,7 @@ onSymlinkBinary -> IO a -- ^ Never action -> IO a + -- ^ Prompt action -> Symlink -> IO a onSymlinkBinary From 729c659d2adc9549af5d5d88f4b6fb3dfc164fc2 Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Tue, 12 Dec 2023 15:13:16 -0500 Subject: [PATCH 5/5] Use -XRecordWildCards As prompted to do so in review --- .../src/Distribution/Client/InstallSymlink.hs | 32 ++++++++----------- 1 file changed, 14 insertions(+), 18 deletions(-) diff --git a/cabal-install/src/Distribution/Client/InstallSymlink.hs b/cabal-install/src/Distribution/Client/InstallSymlink.hs index f453bc15d14..13e29a44d81 100644 --- a/cabal-install/src/Distribution/Client/InstallSymlink.hs +++ b/cabal-install/src/Distribution/Client/InstallSymlink.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} ----------------------------------------------------------------------------- @@ -284,24 +285,19 @@ onSymlinkBinary -- ^ Prompt action -> Symlink -> IO a -onSymlinkBinary - onMissing - onOverwrite - onNever - onPrompt - Symlink{overwritePolicy, publicBindir, privateBindir, publicName, privateName} = do - ok <- - targetOkToOverwrite - (publicBindir publicName) - (privateBindir privateName) - case ok of - NotExists -> onMissing - OkToOverwrite -> onOverwrite - NotOurFile -> - case overwritePolicy of - NeverOverwrite -> onNever - AlwaysOverwrite -> onOverwrite - PromptOverwrite -> onPrompt +onSymlinkBinary onMissing onOverwrite onNever onPrompt Symlink{..} = do + ok <- + targetOkToOverwrite + (publicBindir publicName) + (privateBindir privateName) + case ok of + NotExists -> onMissing + OkToOverwrite -> onOverwrite + NotOurFile -> + case overwritePolicy of + NeverOverwrite -> onNever + AlwaysOverwrite -> onOverwrite + PromptOverwrite -> onPrompt -- | Can we symlink a binary? --