Commit 0f68aff2 authored by Tamar Christina's avatar Tamar Christina Committed by Ryan Scott

hsc2hs: Make removeFile more reliable on Windows. (#25)

* hsc2hs: Make removeFile more reliable on Windows.

* hsc2hs: update after review

* hsc2hs: fix linux builds

* hsc2hs: redundant imports warning linux

* hsc2hs: Add changelog entry
parent 1ba919f9
{-# LANGUAGE CPP #-}
module Common where
import Control.Exception ( bracket_ )
import qualified Control.Exception as Exception
import Control.Monad ( when )
import System.IO
import System.Process ( rawSystem, runProcess, waitForProcess )
#if defined(mingw32_HOST_OS)
import Control.Concurrent ( threadDelay )
import System.IO.Error ( isPermissionError )
#endif
import System.Process ( rawSystem, createProcess, waitForProcess
, proc, CreateProcess(..), StdStream(..) )
import System.Exit ( ExitCode(..), exitWith )
import System.Directory ( removeFile )
......@@ -38,7 +41,16 @@ rawSystemWithStdOutL action flg prog args outFile = do
let cmdLine = prog++" "++unwords args++" >"++outFile
when flg (hPutStrLn stderr ("Executing: " ++ cmdLine))
hOut <- openFile outFile WriteMode
process <- runProcess prog args Nothing Nothing Nothing (Just hOut) Nothing
(_ ,_ ,_ , process) <-
-- We use createProcess here instead of runProcess since we need to specify
-- a custom CreateProcess structure to turn on use_process_jobs when
-- available.
createProcess
#if MIN_VERSION_process (1,5,0)
(proc prog args){ use_process_jobs = True, std_out = UseHandle hOut }
#else
(proc prog args){ std_out = UseHandle hOut }
#endif
exitStatus <- waitForProcess process
hClose hOut
case exitStatus of
......@@ -52,13 +64,39 @@ rawSystemWithStdOutL action flg prog args outFile = do
-- just been exec'ed by a sub-process (Win32 only.)
finallyRemove :: FilePath -> IO a -> IO a
finallyRemove fp act =
bracket_ (return fp)
Exception.bracket_ (return fp)
(noisyRemove fp)
act
where
max_retries :: Int
max_retries = 5
noisyRemove :: FilePath -> IO ()
noisyRemove fpath =
catchIO (removeFile fpath)
catchIO (removeFileInternal max_retries fpath)
(\ e -> hPutStrLn stderr ("Failed to remove file " ++ fpath ++ "; error= " ++ show e))
removeFileInternal _retries path = do
#if defined(mingw32_HOST_OS)
-- On Windows we have to retry the delete a couple of times.
-- The reason for this is that a FileDelete command just marks a
-- file for deletion. The file is really only removed when the last
-- handle to the file is closed. Unfortunately there are a lot of
-- system services that can have a file temporarily opened using a shared
-- read-only lock, such as the built in AV and search indexer.
--
-- We can't really guarantee that these are all off, so what we can do is
-- whenever after an rm the file still exists to try again and wait a bit.
res <- Exception.try $ removeFile path
case res of
Right a -> return a
Left ex | isPermissionError ex && _retries > 1 -> do
let retries' = _retries - 1
threadDelay ((max_retries - retries') * 200)
removeFileInternal retries' path
| otherwise -> Exception.throw ex
#else
removeFile path
#endif
catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
catchIO = Exception.catch
......
## 0.68.6
- Temporary file removals on Windows are not a bit more reliable and should
throw less access denied errors. See #25 and
([#9775](https://gitlab.haskell.org/ghc/ghc/issues/9775))
## 0.68.5
- Support response files regardless of which GHC `hsc2hs` was compiled
......
......@@ -62,6 +62,9 @@ Executable hsc2hs
filepath >= 1.2.0 && < 1.5,
process >= 1.1.0 && < 1.7
if os(windows)
Build-Depends: process >= 1.5.0 && < 1.7
ghc-options: -Wall
if flag(in-ghc-tree)
cpp-options: -DIN_GHC_TREE
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment