Add prompt strategy for --overwrite-policy

haskell · Feb 3, 2019 · e61b60d · e61b60d
1 parent fd51946
commit e61b60d
Show file tree

Hide file tree

Showing 3 changed files with 33 additions and 11 deletions.
diff --git a/cabal-install/Distribution/Client/CmdInstall.hs b/cabal-install/Distribution/Client/CmdInstall.hs
@@ -157,18 +157,21 @@ newInstallOptions _ =
     "How to handle already existing symlinks."
     ninstOverwritePolicy (\v flags -> flags { ninstOverwritePolicy = v })
     $ reqArg
-        "always|never"
+        "always|never|prompt"
         readOverwritePolicyFlag
         showOverwritePolicyFlag
   ]
   where
     readOverwritePolicyFlag = ReadE $ \case
       "always" -> Right $ Flag AlwaysOverwrite
       "never"  -> Right $ Flag NeverOverwrite
-      policy   -> Left  $ "'" <> policy <> "' isn't a valid overwrite policy"
-    showOverwritePolicyFlag (Flag AlwaysOverwrite) = ["always"]
-    showOverwritePolicyFlag (Flag NeverOverwrite)  = ["never"]
-    showOverwritePolicyFlag NoFlag                 = []
+      "prompt" -> Right $ Flag PromptOverwrite
+      _policy  -> Left  $ "Policy must be one of: always, never or prompt."
+    showOverwritePolicyFlag (Flag f) = pure $ case f of
+      AlwaysOverwrite -> "always"
+      NeverOverwrite  -> "never"
+      PromptOverwrite -> "prompt"
+    showOverwritePolicyFlag NoFlag = []
 
 installCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags
                             , HaddockFlags, TestFlags, NewInstallFlags
@@ -700,7 +703,7 @@ symlinkBuiltPackage verbosity overwritePolicy
                     <> "Use --overwrite-policy=always to overwrite."
                   -- This shouldn't even be possible, but we keep it in case
                   -- symlinking logic changes
-                  AlwaysOverwrite -> "Symlinking '" <> prettyShow exe <> "' failed."
+                  _ -> "Symlinking '" <> prettyShow exe <> "' failed."
       unless success $ die' verbosity errorMessage
 
 -- | Symlink a specific exe.

diff --git a/cabal-install/Distribution/Client/InstallSymlink.hs b/cabal-install/Distribution/Client/InstallSymlink.hs
@@ -28,7 +28,7 @@ import Distribution.Simple.Setup (ConfigFlags)
 import Distribution.Simple.Compiler
 import Distribution.System
 
-data OverwritePolicy = NeverOverwrite | AlwaysOverwrite
+data OverwritePolicy = NeverOverwrite | AlwaysOverwrite | PromptOverwrite
   deriving (Show, Eq)
 
 symlinkBinaries :: Platform -> Compiler
@@ -92,9 +92,11 @@ import Distribution.Compat.Exception ( catchIO )
 import Control.Exception
          ( assert )
 import Data.Maybe
-         ( catMaybes )
+         ( catMaybes, listToMaybe )
+import Control.Monad (when)
+import Data.Char (toLower)
 
-data OverwritePolicy = NeverOverwrite | AlwaysOverwrite
+data OverwritePolicy = NeverOverwrite | AlwaysOverwrite | PromptOverwrite
   deriving (Show, Eq)
 
 -- | We would like by default to install binaries into some location that is on
@@ -222,14 +224,28 @@ 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 -> True <$ overwrite
+        PromptOverwrite -> maybeOverwrite
   where
     publicName' = display publicName
     relativeBindir = makeRelative publicBindir privateBindir
     mkLink = createSymbolicLink (relativeBindir </> privateName)
                                 (publicBindir   </> publicName')
     rmLink = removeLink (publicBindir </> publicName')
+    overwrite = rmLink >> mkLink
+    maybeOverwrite :: IO Bool
+    maybeOverwrite = do
+      a <- prompt "Existing file found. Do you want to unlink that file? (y/n)"
+      a <$ when a overwrite
+
+prompt :: String -> IO Bool
+prompt p = do
+  putStrLn p
+  l <- getLine
+  pure $ case listToMaybe l of
+    Nothing -> False
+    Just c  -> toLower c == 'y'
 
 -- | 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/changelog b/cabal-install/changelog
@@ -20,6 +20,8 @@
 2.4.1.0 Mikhail Glushenkov <mikhail.glushenkov@gmail.com> November 2018
 	* Add message to alert user to potential package casing errors. (#5635)
 	* new-clean no longer deletes dist-newstyle/src with `-s`. (#5699)
+2.4.0.1 (current bugfix version)
+	* Add "prompt" strategy when symlinking binaries.
 	* 'new-install' now warns when failing to symlink an exe (#5602)
 	* Extend 'cabal init' support for 'cabal-version' selection (#5567)
 	* 'new-sdist' now generates tarballs with file modification
@@ -30,6 +32,7 @@
 	  public lib. (#5379,#5604)
 	* Fixed a Windows bug where cabal-install tried to copy files
 	  after moving them (#5631).
+	after moving them (#5631).
 	* 'cabal v2-repl' now works for indefinite (in the Backpack sense) components. (#5619)
 	* Set data dir environment variable for tarballs and remote repos (#5469)
 	* Fix monolithic inplace build tool PATH (#5633)