From 4462606cdc8c5d7bc60c245dc68ebd47e1efc3e2 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 1/3] 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 From 139ac4fe60e7fbb41f74b22978888b25fc7a5ceb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Mon, 15 Nov 2021 18:53:11 +0100 Subject: [PATCH 2/3] Flush stdout after prompt, before parsing response. --- cabal-install/src/Distribution/Client/Init/Prompt.hs | 2 ++ cabal-install/src/Distribution/Client/Init/Types.hs | 4 ++++ 2 files changed, 6 insertions(+) diff --git a/cabal-install/src/Distribution/Client/Init/Prompt.hs b/cabal-install/src/Distribution/Client/Init/Prompt.hs index cb8811940fd..2e7e25e25f7 100644 --- a/cabal-install/src/Distribution/Client/Init/Prompt.hs +++ b/cabal-install/src/Distribution/Client/Init/Prompt.hs @@ -25,6 +25,7 @@ import Prelude hiding (break, putStrLn, getLine, putStr) import Distribution.Client.Compat.Prelude hiding (break, empty, getLine, putStr, putStrLn) import Distribution.Client.Init.Types +import qualified System.IO -- | Create a prompt with optional default value that returns a @@ -149,6 +150,7 @@ promptDefault -> m t promptDefault parse pprint msg def = do putStr $ mkDefPrompt msg (pprint <$> def) + hFlush System.IO.stdout input <- getLine case def of DefaultPrompt d | null input -> return d diff --git a/cabal-install/src/Distribution/Client/Init/Types.hs b/cabal-install/src/Distribution/Client/Init/Types.hs index d22a60f37dc..3f8c487c4bd 100644 --- a/cabal-install/src/Distribution/Client/Init/Types.hs +++ b/cabal-install/src/Distribution/Client/Init/Types.hs @@ -69,6 +69,7 @@ import Distribution.CabalSpecVersion import Distribution.Client.Utils as P import Distribution.Fields.Pretty import Language.Haskell.Extension ( Language(..), Extension ) +import qualified System.IO import qualified System.Directory as P import qualified System.Process as P @@ -322,6 +323,7 @@ class Monad m => Interactive m where copyFile :: FilePath -> FilePath -> m () renameDirectory :: FilePath -> FilePath -> m () message :: Verbosity -> String -> m () + hFlush :: System.IO.Handle -> m () -- misc functions break :: m Bool @@ -350,6 +352,7 @@ instance Interactive IO where copyFile = P.copyFile renameDirectory = P.renameDirectory message q = unless (q == silent) . putStrLn + hFlush = System.IO.hFlush break = return False throwPrompt = throwM @@ -382,6 +385,7 @@ instance Interactive PurePrompt where copyFile !_ !_ = return () renameDirectory !_ !_ = return () message !_ !_ = return () + hFlush _ = return () break = return True throwPrompt (BreakException e) = PurePrompt $ \s -> Left $ BreakException From f27e87ad5bbf9107000312d59432f3a04a2d07b1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iveren?= Date: Mon, 22 Nov 2021 21:40:31 +0100 Subject: [PATCH 3/3] Address PR feedback --- .../src/Distribution/Client/CmdInstall.hs | 13 ++++----- .../src/Distribution/Client/InstallSymlink.hs | 28 ++++++++++++------- 2 files changed, 23 insertions(+), 18 deletions(-) diff --git a/cabal-install/src/Distribution/Client/CmdInstall.hs b/cabal-install/src/Distribution/Client/CmdInstall.hs index 57c96dc4303..7ebe48952e0 100644 --- a/cabal-install/src/Distribution/Client/CmdInstall.hs +++ b/cabal-install/src/Distribution/Client/CmdInstall.hs @@ -90,7 +90,7 @@ import Distribution.Client.DistDirLayout import Distribution.Client.RebuildMonad ( runRebuild ) import Distribution.Client.InstallSymlink - ( symlinkBinary, trySymlink ) + ( symlinkBinary, trySymlink, promptRun ) import Distribution.Client.Types.OverwritePolicy ( OverwritePolicy (..) ) import Distribution.Simple.Flag @@ -140,8 +140,6 @@ 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 @@ -833,11 +831,10 @@ installBuiltExe verbosity overwritePolicy 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 + maybeOverwrite + = promptRun + "Existing file found while installing executable. Do you want to overwrite that file? (y/n)" + overwrite -- | Create 'GhcEnvironmentFileEntry's for packages with exposed libraries. entriesForLibraryComponents :: TargetsMap -> [GhcEnvironmentFileEntry] diff --git a/cabal-install/src/Distribution/Client/InstallSymlink.hs b/cabal-install/src/Distribution/Client/InstallSymlink.hs index 4c9bf734a63..5acf0092002 100644 --- a/cabal-install/src/Distribution/Client/InstallSymlink.hs +++ b/cabal-install/src/Distribution/Client/InstallSymlink.hs @@ -16,6 +16,7 @@ module Distribution.Client.InstallSymlink ( symlinkBinaries, symlinkBinary, trySymlink, + promptRun ) where import Distribution.Client.Compat.Prelude hiding (ioError) @@ -193,8 +194,8 @@ symlinkBinary overwritePolicy publicBindir privateBindir publicName privateName ok <- targetOkToOverwrite (publicBindir publicName) (privateBindir privateName) case ok of - NotExists -> mkLink >> return True - OkToOverwrite -> rmLink >> mkLink >> return True + NotExists -> mkLink + OkToOverwrite -> overwrite NotOurFile -> case overwritePolicy of NeverOverwrite -> return False @@ -202,15 +203,22 @@ symlinkBinary overwritePolicy publicBindir privateBindir publicName privateName PromptOverwrite -> maybeOverwrite where relativeBindir = makeRelative publicBindir privateBindir - mkLink = createFileLink (relativeBindir privateName) (publicBindir publicName) - rmLink = removeFile (publicBindir publicName) - overwrite = True <$ (rmLink *> mkLink) + 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 = 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 + maybeOverwrite + = promptRun + "Existing file found while installing symlink. Do you want to overwrite that file? (y/n)" + overwrite + +promptRun :: String -> IO Bool -> IO Bool +promptRun s m = do + a <- promptYesNo s MandatoryPrompt + if a then m 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