From 9882a8d86560faa9f76c6d0601ac22c07b8465f7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Thu, 8 Nov 2018 13:30:51 +0100 Subject: [PATCH] Add prompt strategy for `--overwrite-policy` --- .../src/Distribution/Client/CmdInstall.hs | 15 +++++++++++++-- .../Client/CmdInstall/ClientInstallFlags.hs | 2 +- .../src/Distribution/Client/InstallSymlink.hs | 14 ++++++++++++-- .../Distribution/Client/Types/OverwritePolicy.hs | 3 +++ changelog.d/pr-5672 | 2 ++ 5 files changed, 31 insertions(+), 5 deletions(-) create mode 100644 changelog.d/pr-5672 diff --git a/cabal-install/src/Distribution/Client/CmdInstall.hs b/cabal-install/src/Distribution/Client/CmdInstall.hs index 0e9965a918e..57c96dc4303 100644 --- a/cabal-install/src/Distribution/Client/CmdInstall.hs +++ b/cabal-install/src/Distribution/Client/CmdInstall.hs @@ -140,6 +140,8 @@ import System.Directory , removeFile, removeDirectory, copyFile ) import System.FilePath ( (), (<.>), takeDirectory, takeBaseName ) +import Distribution.Client.Init.Types (DefaultPrompt(MandatoryPrompt)) +import Distribution.Client.Init.Prompt (promptYesNo) installCommand :: CommandUI (NixStyleFlags ClientInstallFlags) installCommand = CommandUI @@ -781,7 +783,7 @@ installUnitExes verbosity overwritePolicy <> "Use --overwrite-policy=always to overwrite." -- This shouldn't even be possible, but we keep it in case -- symlinking/copying logic changes - AlwaysOverwrite -> + _ -> case installMethod of InstallMethodSymlink -> "Symlinking" InstallMethodCopy -> @@ -816,7 +818,8 @@ installBuiltExe verbosity overwritePolicy exists <- doesPathExist destination case (exists, overwritePolicy) of (True , NeverOverwrite ) -> pure False - (True , AlwaysOverwrite) -> remove >> copy + (True , AlwaysOverwrite) -> overwrite + (True , PromptOverwrite) -> maybeOverwrite (False, _ ) -> copy where source = sourceDir exeName @@ -827,6 +830,14 @@ installBuiltExe verbosity overwritePolicy then removeDirectory destination else removeFile destination copy = copyFile source destination >> pure True + overwrite :: IO Bool + overwrite = remove >> copy + maybeOverwrite :: IO Bool + maybeOverwrite = do + a <- promptYesNo + "Existing file found while installing executable. Do you want to unlink that file? (y/n)" + MandatoryPrompt + if a then overwrite else pure a -- | Create 'GhcEnvironmentFileEntry's for packages with exposed libraries. entriesForLibraryComponents :: TargetsMap -> [GhcEnvironmentFileEntry] diff --git a/cabal-install/src/Distribution/Client/CmdInstall/ClientInstallFlags.hs b/cabal-install/src/Distribution/Client/CmdInstall/ClientInstallFlags.hs index ff3c0d6162e..c5f24db2686 100644 --- a/cabal-install/src/Distribution/Client/CmdInstall/ClientInstallFlags.hs +++ b/cabal-install/src/Distribution/Client/CmdInstall/ClientInstallFlags.hs @@ -65,7 +65,7 @@ clientInstallOptions _ = , option [] ["overwrite-policy"] "How to handle already existing symlinks." cinstOverwritePolicy (\v flags -> flags { cinstOverwritePolicy = v }) - $ reqArg "always|never" + $ reqArg "always|never|prompt" (parsecToReadE (\err -> "Error parsing overwrite-policy: " ++ err) (toFlag `fmap` parsec)) (map prettyShow . flagToList) , option [] ["install-method"] diff --git a/cabal-install/src/Distribution/Client/InstallSymlink.hs b/cabal-install/src/Distribution/Client/InstallSymlink.hs index 76e3cf6d795..4c9bf734a63 100644 --- a/cabal-install/src/Distribution/Client/InstallSymlink.hs +++ b/cabal-install/src/Distribution/Client/InstallSymlink.hs @@ -62,6 +62,8 @@ import Control.Exception import Distribution.Client.Compat.Directory ( createFileLink, getSymbolicLinkTarget, pathIsSymbolicLink ) import Distribution.Client.Types.OverwritePolicy +import Distribution.Client.Init.Types ( DefaultPrompt(MandatoryPrompt) ) +import Distribution.Client.Init.Prompt ( promptYesNo ) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8 @@ -195,12 +197,20 @@ symlinkBinary overwritePolicy publicBindir privateBindir publicName privateName OkToOverwrite -> rmLink >> mkLink >> return True NotOurFile -> case overwritePolicy of - NeverOverwrite -> return False - AlwaysOverwrite -> rmLink >> mkLink >> return True + NeverOverwrite -> return False + AlwaysOverwrite -> overwrite + PromptOverwrite -> maybeOverwrite where relativeBindir = makeRelative publicBindir privateBindir mkLink = createFileLink (relativeBindir privateName) (publicBindir publicName) rmLink = removeFile (publicBindir publicName) + overwrite = True <$ (rmLink *> mkLink) + maybeOverwrite :: IO Bool + maybeOverwrite = do + a <- promptYesNo + "Existing file found while installing symlink. Do you want to unlink that file? (y/n)" + MandatoryPrompt + if a then overwrite else pure a -- | Check a file path of a symlink that we would like to create to see if it -- is OK. For it to be OK to overwrite it must either not already exist yet or diff --git a/cabal-install/src/Distribution/Client/Types/OverwritePolicy.hs b/cabal-install/src/Distribution/Client/Types/OverwritePolicy.hs index e2b43fdcedd..d6f8c8b5547 100644 --- a/cabal-install/src/Distribution/Client/Types/OverwritePolicy.hs +++ b/cabal-install/src/Distribution/Client/Types/OverwritePolicy.hs @@ -10,6 +10,7 @@ import qualified Text.PrettyPrint as PP data OverwritePolicy = NeverOverwrite | AlwaysOverwrite + | PromptOverwrite deriving (Show, Eq, Generic, Bounded, Enum) instance Binary OverwritePolicy @@ -21,8 +22,10 @@ instance Parsec OverwritePolicy where case name of "always" -> pure AlwaysOverwrite "never" -> pure NeverOverwrite + "prompt" -> pure PromptOverwrite _ -> P.unexpected $ "OverwritePolicy: " ++ name instance Pretty OverwritePolicy where pretty NeverOverwrite = PP.text "never" pretty AlwaysOverwrite = PP.text "always" + pretty PromptOverwrite = PP.text "prompt" diff --git a/changelog.d/pr-5672 b/changelog.d/pr-5672 new file mode 100644 index 00000000000..1648da484b6 --- /dev/null +++ b/changelog.d/pr-5672 @@ -0,0 +1,2 @@ +synopsis: Add "prompt" strategy when symlinking binaries. +prs: #5672