Handle removing files better

Cabal-tests/tests/UnitTests/Distribution/Simple/Utils.hs

@@ -11,7 +11,7 @@ import Distribution.Verbosity
 import Data.IORef
 import System.Directory ( doesDirectoryExist, doesFileExist
                         , getTemporaryDirectory
-                        , removePathForcibly, removeFile )
+                        , removePathForcibly )
 import System.FilePath ( (<.>) )
 import System.IO (hClose, localeEncoding, hPutStrLn)
 import System.IO.Error
@@ -32,7 +32,7 @@ withTempFileRemovedTest :: Assertion
 withTempFileRemovedTest = do
   withTempFile ".foo" $ \fileName handle -> do
     hClose handle
-    removeFile fileName
+    removeFileForcibly fileName
 
 withTempDirTest :: Assertion
 withTempDirTest = do

Cabal-tests/tests/custom-setup/IdrisSetup.hs

@@ -301,8 +301,8 @@ idrisPostSDist args flags desc lbi = do
                               let targetFile = "src" </> "Target_idris" Px.<.> "hs"
                               putStrLn $ "Removing generated modules:\n "
                                         ++ file ++ "\n" ++ targetFile
-                              removeFile file
-                              removeFile targetFile)
+                              removeFileForcible file
+                              removeFileForcible targetFile)
              (\e -> let e' = (e :: SomeException) in return ())
   postSDist simpleUserHooks args flags desc lbi
 #endif

Cabal/src/Distribution/Simple/Build.hs

@@ -128,7 +128,6 @@ import Control.Monad
 import qualified Data.ByteString.Lazy as LBS
 import qualified Data.Map as Map
 
-import System.Directory (doesFileExist, removeFile)
 import System.FilePath (takeDirectory)
 
 -- -----------------------------------------------------------------------------
@@ -307,10 +306,9 @@ dumpBuildInfo verbosity distPref dumpBuildInfoFlag pkg_descr lbi flags = do
           ++ unlines warns
     LBS.writeFile buildInfoFile buildInfoText
 
-  when (not shouldDumpBuildInfo) $ do
+  when (not shouldDumpBuildInfo) $
     -- Remove existing build-info.json as it might be outdated now.
-    exists <- doesFileExist buildInfoFile
-    when exists $ removeFile buildInfoFile
+    removeFileForcibly buildInfoFile
   where
     buildInfoFile = interpretSymbolicPathLBI lbi $ buildInfoPref distPref
     shouldDumpBuildInfo = fromFlagOrDefault NoDumpBuildInfo dumpBuildInfoFlag == DumpBuildInfo

Cabal/src/Distribution/Simple/Configure.hs

@@ -156,7 +156,6 @@ import System.Directory
   , doesFileExist
   , doesPathExist
   , listDirectory
-  , removeFile
   )
 import System.FilePath
   ( isAbsolute
@@ -2634,7 +2633,7 @@ checkForeignDeps pkg lbi verbosity =
             ++ (baseDir </> hdr)
             ++ "; removing "
             ++ (baseDir </> hdr)
-        removeFile (baseDir </> hdr)
+        removeFileForcibly (baseDir </> hdr)
 
     findOffendingHdr =
       ifBuildsWith

Cabal/src/Distribution/Simple/GHC/Build/Link.hs

@@ -51,8 +51,6 @@ import Distribution.Version
 import System.Directory
   ( createDirectoryIfMissing
   , doesDirectoryExist
-  , doesFileExist
-  , removeFile
   , renameFile
   )
 import System.FilePath
@@ -551,10 +549,8 @@ linkExecutable linkerOpts (way, buildOpts) targetDir targetName runGhcProg lbi =
   -- situation, see #3294
   let target =
         targetDir </> makeRelativePathEx (exeTargetName (hostPlatform lbi) targetName)
-  when (compilerVersion comp < mkVersion [7, 7]) $ do
-    let targetPath = interpretSymbolicPathLBI lbi target
-    e <- doesFileExist targetPath
-    when e (removeFile targetPath)
+  when (compilerVersion comp < mkVersion [7, 7]) $
+    removeFileForcibly (interpretSymbolicPathLBI lbi target)
   runGhcProg linkOpts{ghcOptOutputFile = toFlag target}
 
 -- | Link a foreign library component

Cabal/src/Distribution/Simple/GHCJS.hs

@@ -97,7 +97,6 @@ import System.Directory
   , createDirectoryIfMissing
   , doesFileExist
   , getAppUserDataDirectory
-  , removeFile
   , renameFile
   )
 import System.FilePath
@@ -1570,10 +1569,8 @@ gbuild verbosity numJobs pkg_descr lbi bm clbi = do
       -- Work around old GHCs not relinking in this
       -- situation, see #3294
       let target = targetDir </> makeRelativePathEx targetName
-      when (compilerVersion comp < mkVersion [7, 7]) $ do
-        let targetPath = i target
-        e <- doesFileExist targetPath
-        when e (removeFile targetPath)
+      when (compilerVersion comp < mkVersion [7, 7]) $
+        removeFileForcibly (i target)
       runGhcProg linkOpts{ghcOptOutputFile = toFlag target}
     GBuildFLib flib -> do
       let rtsInfo = extractRtsInfo lbi

Cabal/src/Distribution/Simple/Test.hs

@@ -54,9 +54,7 @@ import Distribution.Types.InstalledPackageInfo (InstalledPackageInfo (libraryDir
 import Distribution.Types.LocalBuildInfo (LocalBuildInfo (..))
 import System.Directory
   ( createDirectoryIfMissing
-  , doesFileExist
   , listDirectory
-  , removeFile
   )
 
 -- | Perform the \"@.\/setup test@\" action.
@@ -151,8 +149,7 @@ test args verbHandles pkg_descr lbi0 flags = do
 
   -- Delete ordinary files from test log directory.
   listDirectory (i testLogDir)
-    >>= filterM doesFileExist . map (i testLogDir </>)
-    >>= traverse_ removeFile
+    >>= traverse_ (removeFileForcibly . (i testLogDir </>))
 
   -- We configured the unit-ids of libraries we should cover in our coverage
   -- report at configure time into the local build info. At build time, we built

Cabal/src/Distribution/Simple/Test/LibV09.hs

@@ -48,7 +48,6 @@ import System.Directory
   , createDirectoryIfMissing
   , doesFileExist
   , getCurrentDirectory
-  , removeFile
   , removePathForcibly
   , setCurrentDirectory
   )
@@ -91,7 +90,7 @@ runTest verbHandles pkg_descr lbi clbi hpcMarkupInfo flags suite = do
   -- Write summary notices indicating start of test suite
   notice verbosity $ summarizeSuiteStart testName'
 
-  suiteLog <- CE.bracket openCabalTemp deleteIfExists $ \tempLog -> do
+  suiteLog <- CE.bracket openCabalTemp removeFileForcibly $ \tempLog -> do
     -- Compute the appropriate environment for running the test suite
     let progDb = LBI.withPrograms lbi
         pathVar = progSearchPath progDb
@@ -209,10 +208,6 @@ runTest verbHandles pkg_descr lbi clbi hpcMarkupInfo flags suite = do
     common = testCommonFlags flags
     testName' = unUnqualComponentName $ PD.testName suite
 
-    deleteIfExists file = do
-      exists <- doesFileExist file
-      when exists $ removeFile file
-
     testLogDir = distPref </> makeRelativePathEx "test"
     openCabalTemp = do
       (f, h) <- openTempFile (i testLogDir) $ "cabal-test-" <.> "log"

Cabal/src/Distribution/Simple/Utils.hs

@@ -97,6 +97,9 @@ module Distribution.Simple.Utils
   , copyFileTo
   , copyFileToCwd
 
+    -- * removing files
+  , removeFileForcibly
+
     -- * installing files
   , installOrdinaryFile
   , installExecutableFile
@@ -244,6 +247,7 @@ import Data.Typeable
   ( cast
   )
 
+import Control.Concurrent (threadDelay)
 import qualified Control.Exception as Exception
 import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime)
 import qualified Data.Version as DV
@@ -1812,6 +1816,26 @@ copyFilesWith doCopy verbosity targetDir srcFiles = withFrozenCallStack $ do
 copyFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO ()
 copyFiles v fp fs = withFrozenCallStack (copyFilesWith copyFileVerbose v fp fs)
 
+-- | A robust helper to remove an existing file, which does not throw
+-- an exception if such file never existed, thus akin to removePathForcibly.
+removeFileForcibly :: FilePath -> IO ()
+removeFileForcibly fp = catch (removeFile fp) $ \case
+  e
+    -- If the file never existed in the first place, we are golden.
+    | isDoesNotExistError e -> pure ()
+    -- If we got a permission error, chances are that it's a read-only
+    -- file on Windows. Removing read-only attribute ourselves requires
+    -- reaching out for internal API, so instead of it we call 'removePathForcibly',
+    -- which is a bit of overkill for a single file, but well.
+    | isPermissionError e -> removePathForcibly fp
+    -- If device is busy, wait 1ms and give it another go.
+    -- EBUSY from unlink(2) is mapped to UnsatisfiedConstraints.
+    | ioeGetErrorType e == GHC.UnsatisfiedConstraints -> do
+        threadDelay 1000
+        removeFile fp
+    -- Else we give up.
+    | otherwise -> throwIO e
+
 -- | This is like 'copyFiles' but uses 'installOrdinaryFile'.
 installOrdinaryFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO ()
 installOrdinaryFiles v fp fs = withFrozenCallStack (copyFilesWith installOrdinaryFile v fp fs)

cabal-install/src/Distribution/Client/CmdClean.hs

@@ -51,6 +51,7 @@ import Distribution.Simple.Setup
 import Distribution.Simple.Utils
   ( dieWithException
   , info
+  , removeFileForcibly
   , wrapText
   )
 import Distribution.System
@@ -85,7 +86,6 @@ import System.Directory
   , doesDirectoryExist
   , doesFileExist
   , listDirectory
-  , removeFile
   , removePathForcibly
   )
 import System.FilePath
@@ -216,5 +216,5 @@ cleanAction (ProjectFlags{..}, CleanFlags{..}) extraArgs _ = do
 
 removeEnvFiles :: FilePath -> IO ()
 removeEnvFiles dir =
-  (traverse_ (removeFile . (dir </>)) . filter ((".ghc.environment" ==) . take 16))
+  (traverse_ (removeFileForcibly . (dir </>)) . filter ((".ghc.environment" ==) . take 16))
     =<< listDirectory dir

cabal-install/src/Distribution/Client/Init/Types.hs

@@ -81,6 +81,7 @@ import Distribution.Fields.Pretty
 import Distribution.ModuleName
 import qualified Distribution.Package as P
 import Distribution.Simple.Setup (Flag)
+import qualified Distribution.Simple.Utils as P
 import Distribution.Verbosity (VerbosityFlags, VerbosityLevel (..), verbosityLevel)
 import Distribution.Version
 import Language.Haskell.Extension (Extension, Language (..))
@@ -403,7 +404,7 @@ instance Interactive PromptIO where
   createDirectory = liftIO <$> P.createDirectory
   removeDirectory = liftIO <$> P.removePathForcibly
   writeFile a b = liftIO $ P.writeFile a b
-  removeExistingFile = liftIO <$> P.removeExistingFile
+  removeExistingFile = liftIO <$> P.removeFileForcibly
   copyFile a b = liftIO $ P.copyFile a b
   renameDirectory a b = liftIO $ P.renameDirectory a b
   hFlush = liftIO <$> System.IO.hFlush

cabal-install/src/Distribution/Client/Install.hs

@@ -51,7 +51,6 @@ import System.Directory
   , doesFileExist
   , getTemporaryDirectory
   , listDirectory
-  , removeFile
   , renameDirectory
   )
 import System.FilePath
@@ -237,6 +236,7 @@ import Distribution.Simple.Utils as Utils
   , dieWithException
   , info
   , notice
+  , removeFileForcibly
   , warn
   , withTempDirectory
   )
@@ -2061,8 +2061,7 @@ installUnpackedPackage
             let logFileName = mkLogFileName (packageId pkg) uid
                 logDir = takeDirectory logFileName
             unless (null logDir) $ createDirectoryIfMissing True logDir
-            logFileExists <- doesFileExist logFileName
-            when logFileExists $ removeFile logFileName
+            removeFileForcibly logFileName
             return (Just logFileName)
 
       setup cmd getCommonFlags flags mLogPath =

cabal-install/src/Distribution/Client/InstallSymlink.hs

@@ -64,7 +64,7 @@ import Distribution.Simple.Setup
   , fromFlag
   , fromFlagOrDefault
   )
-import Distribution.Simple.Utils (info, withTempDirectory)
+import Distribution.Simple.Utils (info, removeFileForcibly, withTempDirectory)
 import Distribution.System
   ( Platform
   )
@@ -79,7 +79,6 @@ import System.Directory
   , getSymbolicLinkTarget
   , getTemporaryDirectory
   , pathIsSymbolicLink
-  , removeFile
   )
 import System.FilePath
   ( isAbsolute
@@ -322,7 +321,7 @@ symlinkBinary inputs@Symlink{publicBindir, privateBindir, publicName, privateNam
     mkLink = True <$ createFileLink (relativeBindir </> privateName) (publicBindir </> publicName)
 
     rmLink :: IO Bool
-    rmLink = True <$ removeFile (publicBindir </> publicName)
+    rmLink = True <$ removeFileForcibly (publicBindir </> publicName)
 
     overwrite :: IO Bool
     overwrite = rmLink *> mkLink

cabal-install/src/Distribution/Client/ProjectBuilding/PackageFileMonitor.hs

@@ -24,9 +24,9 @@ import Distribution.InstalledPackageInfo (InstalledPackageInfo)
 import Distribution.Simple.LocalBuildInfo
   ( ComponentName (..)
   )
+import Distribution.Simple.Utils (removeFileForcibly)
 
 import qualified Data.Set as Set
-import Distribution.Client.Init.Types (removeExistingFile, runPromptIO)
 
 -----------------------------
 -- Package change detection
@@ -291,4 +291,4 @@ updatePackageRegFileMonitor
 
 invalidatePackageRegFileMonitor :: PackageFileMonitor -> IO ()
 invalidatePackageRegFileMonitor PackageFileMonitor{pkgFileMonitorReg} =
-  runPromptIO $ removeExistingFile (fileMonitorCacheFile pkgFileMonitorReg)
+  removeFileForcibly (fileMonitorCacheFile pkgFileMonitorReg)

cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs

@@ -105,7 +105,7 @@ import qualified Data.ByteString.Lazy.Char8 as LBS.Char8
 import qualified Data.List.NonEmpty as NE
 
 import Control.Exception (ErrorCall, Handler (..), SomeAsyncException, assert, catches, onException)
-import System.Directory (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, listDirectory, removeFile)
+import System.Directory (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist, listDirectory)
 import System.FilePath (dropDrive, normalise, takeDirectory, (<.>), (</>))
 import System.IO (Handle, IOMode (AppendMode), withFile)
 import System.Semaphore (SemaphoreName (..))
@@ -799,8 +799,7 @@ buildAndInstallUnpackedPackage
           Nothing -> return ()
           Just logFile -> do
             createDirectoryIfMissing True (takeDirectory logFile)
-            exists <- doesFileExist logFile
-            when exists $ removeFile logFile
+            removeFileForcibly logFile
 
 -- | The copy part of the installation phase when doing build-and-install
 copyPkgFiles

cabal-install/src/Distribution/Client/Utils.hs

@@ -15,7 +15,6 @@ module Distribution.Client.Utils
   , withExtraPathEnv
   , determineNumJobs
   , numberOfProcessors
-  , removeExistingFile
   , withTempFileName
   , makeAbsoluteToCwd
   , makeRelativeToCwd
@@ -71,7 +70,7 @@ import Distribution.Client.Errors
 import Distribution.Compat.Environment
 import Distribution.Compat.Time (getModTime)
 import Distribution.Simple.Setup (Flag, pattern Flag, pattern NoFlag)
-import Distribution.Simple.Utils (dieWithException, findPackageDesc, noticeNoWrap)
+import Distribution.Simple.Utils (dieWithException, findPackageDesc, noticeNoWrap, removeFileForcibly)
 import Distribution.Utils.Path
   ( CWD
   , FileOrDir (..)
@@ -91,7 +90,6 @@ import System.Directory
   , doesDirectoryExist
   , doesFileExist
   , listDirectory
-  , removeFile
   )
 import qualified System.Directory as Directory
 import System.FilePath
@@ -151,14 +149,6 @@ duplicatesBy cmp = filter moreThanOne . groupBy eq . sortBy cmp
     moreThanOne (_ : _ : _) = True
     moreThanOne _ = False
 
--- | Like 'removeFile', but does not throw an exception when the file does not
--- exist.
-removeExistingFile :: FilePath -> IO ()
-removeExistingFile path = do
-  exists <- doesFileExist path
-  when exists $
-    removeFile path
-
 -- | A variant of 'withTempFile' that only gives us the file name, and while
 -- it will clean up the file afterwards, it's lenient if the file is
 -- moved\/deleted.
@@ -170,7 +160,7 @@ withTempFileName
 withTempFileName tmpDir template action =
   Safe.bracket
     (openTempFile tmpDir template)
-    (\(name, _) -> removeExistingFile name)
+    (\(name, _) -> removeFileForcibly name)
     (\(name, h) -> hClose h >> action name)
 
 -- | Executes the action with an environment variable set to some