Add prompt strategy for --overwrite-policy

haskell · Nov 15, 2021 · 9882a8d · 9882a8d
1 parent e74a53b
commit 9882a8d
Show file tree

Hide file tree

Showing 5 changed files with 31 additions and 5 deletions.
diff --git 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
@@ -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
@@ -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
@@ -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
@@ -0,0 +1,2 @@
+synopsis: Add "prompt" strategy when symlinking binaries.
+prs: #5672