Impement removeFileForcibly and use it instead of removeFile

Author: Bodigrim

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
@@ -2620,7 +2619,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
@@ -524,10 +522,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) gets 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