Merge pull request #5672 from fredefox/wip/prompt-overwrite-policy

Prompt overwrite policy

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
@@ -781,7 +781,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 +816,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 +828,13 @@ 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
+      = 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]

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"]

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

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

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)
@@ -62,6 +63,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
@@ -191,16 +194,31 @@ 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
-        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)
+    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
+      = 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

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"

changelog.d/pr-5672

@@ -0,0 +1,2 @@
+synopsis: Add "prompt" strategy when symlinking binaries.
+prs: #5672