Commit 973b3cf5 authored by Francesco Gazzetta's avatar Francesco Gazzetta

Error on existing symlink and add overwrite option

Before, new-install could exit successfully while actually _not_ symlinking
anything.
Moreover, without an overwrite option, upgrading cabal was impossible
without moving links around.

* Error out on overwrite
* Overwrite if --force-overwrite is passed
parent e5618f91
......@@ -73,7 +73,7 @@ import Distribution.Client.DistDirLayout
import Distribution.Client.RebuildMonad
( runRebuild )
import Distribution.Client.InstallSymlink
( symlinkBinary )
( OverwritePolicy(..), symlinkBinary )
import Distribution.Simple.Setup
( Flag(Flag), HaddockFlags, fromFlagOrDefault, flagToMaybe, toFlag
, trueArg, configureOptions, haddockOptions, flagToList )
......@@ -131,14 +131,20 @@ import System.FilePath
data NewInstallFlags = NewInstallFlags
{ ninstInstallLibs :: Flag Bool
, ninstEnvironmentPath :: Flag FilePath
, ninstForceOverwrite :: Flag Bool
}
defaultNewInstallFlags :: NewInstallFlags
defaultNewInstallFlags = NewInstallFlags
{ ninstInstallLibs = toFlag False
, ninstEnvironmentPath = mempty
, ninstForceOverwrite = toFlag False
}
boolToOverwritePolicy :: Bool -> OverwritePolicy
boolToOverwritePolicy True = DoOverwrite
boolToOverwritePolicy False = DontOverwrite
newInstallOptions :: ShowOrParseArgs -> [OptionField NewInstallFlags]
newInstallOptions _ =
[ option [] ["lib"]
......@@ -149,6 +155,11 @@ newInstallOptions _ =
"Set the environment file that may be modified."
ninstEnvironmentPath (\pf flags -> flags { ninstEnvironmentPath = pf })
(reqArg "ENV" (succeedReadE Flag) flagToList)
-- TODO choose a name. --force-overwrite, --overwrite-symlink, --overwrite...
, option [] ["force-overwrite"]
"Overwrite an existing symlink."
ninstForceOverwrite (\v flags -> flags { ninstForceOverwrite = v })
trueArg
]
installCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags
......@@ -513,8 +524,12 @@ installAction (configFlags, configExFlags, installFlags, haddockFlags, newInstal
$ projectConfigBuildOnly
$ projectConfig $ baseCtx
createDirectoryIfMissingVerbose verbosity False symlinkBindir
traverse_ (symlinkBuiltPackage verbosity mkPkgBinDir symlinkBindir)
$ Map.toList $ targetsMap buildCtx
let
doSymlink = symlinkBuiltPackage
verbosity
overwritePolicy
mkPkgBinDir symlinkBindir
in traverse_ doSymlink $ Map.toList $ targetsMap buildCtx
runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes
when installLibs $
......@@ -550,6 +565,8 @@ installAction (configFlags, configExFlags, installFlags, haddockFlags, newInstal
globalFlags configFlags' configExFlags
installFlags haddockFlags
globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig)
overwritePolicy = fromFlagOrDefault DontOverwrite
$ boolToOverwritePolicy <$> ninstForceOverwrite newInstallFlags
globalPackages :: [PackageName]
globalPackages = mkPackageName <$>
......@@ -581,29 +598,43 @@ disableTestsBenchsByDefault 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 mkSourceBinDir destDir (pkg, components) =
symlinkBuiltPackage verbosity overwritePolicy
mkSourceBinDir destDir
(pkg, components) =
traverse_ symlinkAndWarn exes
where
exes = catMaybes $ (exeMaybe . fst) <$> components
exeMaybe (ComponentTarget (CExeName exe) _) = Just exe
exeMaybe _ = Nothing
symlinkAndWarn exe = do
success <- symlinkBuiltExe verbosity (mkSourceBinDir pkg) destDir exe
unless success $ warn verbosity $ "Symlink for "
<> prettyShow exe
<> " already exists. Not overwriting."
success <- symlinkBuiltExe
verbosity overwritePolicy
(mkSourceBinDir pkg) destDir exe
let errorMessage = case overwritePolicy of
DontOverwrite ->
"Symlink for '" <> prettyShow exe <> "' already exists. "
<> "Use --force-overwrite to overwrite."
-- This shouldn't even be possible, but we keep it in case
-- symlinking logic changes
DoOverwrite -> "Symlinking '" <> prettyShow exe <> "' failed."
unless success $ die' verbosity errorMessage
-- | Symlink a specific exe.
symlinkBuiltExe :: Verbosity -> FilePath -> FilePath -> UnqualComponentName -> IO Bool
symlinkBuiltExe verbosity sourceDir destDir exe = do
symlinkBuiltExe :: Verbosity -> OverwritePolicy
-> FilePath -> FilePath
-> UnqualComponentName
-> IO Bool
symlinkBuiltExe verbosity overwritePolicy sourceDir destDir exe = do
notice verbosity $ "Symlinking " ++ prettyShow exe
symlinkBinary
overwritePolicy
destDir
sourceDir
exe
......
......@@ -96,7 +96,7 @@ import qualified Distribution.Client.BuildReports.Anonymous as BuildReports
import qualified Distribution.Client.BuildReports.Storage as BuildReports
( storeAnonymous, storeLocal, fromInstallPlan, fromPlanningFailure )
import qualified Distribution.Client.InstallSymlink as InstallSymlink
( symlinkBinaries )
( OverwritePolicy(..), symlinkBinaries )
import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade
import qualified Distribution.Client.World as World
import qualified Distribution.InstalledPackageInfo as Installed
......@@ -965,6 +965,7 @@ symlinkBinaries :: Verbosity
symlinkBinaries verbosity platform comp configFlags installFlags
plan buildOutcomes = do
failed <- InstallSymlink.symlinkBinaries platform comp
InstallSymlink.DontOverwrite
configFlags installFlags
plan buildOutcomes
case failed of
......
......@@ -12,6 +12,7 @@
-- Managing installing binaries with symlinks.
-----------------------------------------------------------------------------
module Distribution.Client.InstallSymlink (
OverwritePolicy(..),
symlinkBinaries,
symlinkBinary,
) where
......@@ -27,16 +28,22 @@ import Distribution.Simple.Setup (ConfigFlags)
import Distribution.Simple.Compiler
import Distribution.System
data OverwritePolicy = DontOverwrite | DoOverwrite
deriving (Show, Eq)
symlinkBinaries :: Platform -> Compiler
-> OverwritePolicy
-> ConfigFlags
-> InstallFlags
-> InstallPlan
-> BuildOutcomes
-> IO [(PackageIdentifier, UnqualComponentName, FilePath)]
symlinkBinaries _ _ _ _ _ _ = return []
symlinkBinaries _ _ _ _ _ _ _ = return []
symlinkBinary :: FilePath -> FilePath -> UnqualComponentName -> String -> IO Bool
symlinkBinary _ _ _ _ = fail "Symlinking feature not available on Windows"
symlinkBinary :: OverwritePolicy
-> FilePath -> FilePath -> UnqualComponentName -> String
-> IO Bool
symlinkBinary _ _ _ _ _ = fail "Symlinking feature not available on Windows"
#else
......@@ -87,6 +94,9 @@ import Control.Exception
import Data.Maybe
( catMaybes )
data OverwritePolicy = DontOverwrite | DoOverwrite
deriving (Show, Eq)
-- | We would like by default to install binaries into some location that is on
-- the user's PATH. For per-user installations on Unix systems that basically
-- means the @~/bin/@ directory. On the majority of platforms the @~/bin/@
......@@ -108,12 +118,15 @@ import Data.Maybe
-- with symlinks so is not available to Windows users.
--
symlinkBinaries :: Platform -> Compiler
-> OverwritePolicy
-> ConfigFlags
-> InstallFlags
-> InstallPlan
-> BuildOutcomes
-> IO [(PackageIdentifier, UnqualComponentName, FilePath)]
symlinkBinaries platform comp configFlags installFlags plan buildOutcomes =
symlinkBinaries platform comp overwritePolicy
configFlags installFlags
plan buildOutcomes =
case flagToMaybe (installSymlinkBinDir installFlags) of
Nothing -> return []
Just symlinkBinDir
......@@ -125,6 +138,7 @@ symlinkBinaries platform comp configFlags installFlags plan buildOutcomes =
fmap catMaybes $ sequence
[ do privateBinDir <- pkgBinDir pkg ipid
ok <- symlinkBinary
overwritePolicy
publicBinDir privateBinDir
publicExeName privateExeName
if ok
......@@ -187,7 +201,8 @@ symlinkBinaries platform comp configFlags installFlags plan buildOutcomes =
(CompilerId compilerFlavor _) = compilerInfoId cinfo
symlinkBinary ::
FilePath -- ^ The canonical path of the public bin dir eg
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@
......@@ -199,13 +214,16 @@ symlinkBinary ::
-- there was another file there already that we did
-- not own. Other errors like permission errors just
-- propagate as exceptions.
symlinkBinary publicBindir privateBindir publicName privateName = do
symlinkBinary overwritePolicy publicBindir privateBindir publicName privateName = do
ok <- targetOkToOverwrite (publicBindir </> publicName')
(privateBindir </> privateName)
case ok of
NotOurFile -> return False
NotExists -> mkLink >> return True
OkToOverwrite -> rmLink >> mkLink >> return True
NotExists -> mkLink >> return True
OkToOverwrite -> rmLink >> mkLink >> return True
NotOurFile ->
case overwritePolicy of
DontOverwrite -> return False
DoOverwrite -> rmLink >> mkLink >> return True
where
publicName' = display publicName
relativeBindir = makeRelative publicBindir privateBindir
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment