diff options
author | 2014-02-03 11:38:20 -0400 | |
---|---|---|
committer | 2014-02-03 11:45:31 -0400 | |
commit | f0c652b2a9ebc29e734316b8f87770fc8960aae2 (patch) | |
tree | 7f7d2966eb06dadf4e651e7895cbb7f9beb9bb3e | |
parent | 65b8b2cbc8ff2f9d8dc1958298c86965f46acbc6 (diff) |
try harder to delete test dir on windows
-rw-r--r-- | Test.hs | 30 |
1 files changed, 20 insertions, 10 deletions
@@ -64,6 +64,7 @@ import qualified Utility.Exception import qualified Utility.Hash import qualified Utility.Scheduled import qualified Utility.HumanTime +import qualified Utility.ThreadScheduler #ifndef mingw32_HOST_OS import qualified CmdLine.GitAnnex as GitAnnex import qualified Remote.Helper.Encryptable @@ -1166,15 +1167,24 @@ ensuretmpdir = do createDirectory tmpdir cleanup :: FilePath -> IO () -cleanup dir = do - e <- doesDirectoryExist dir - when e $ do - -- Allow all files and directories to be written to, so - -- they can be deleted. Both git and git-annex use file - -- permissions to prevent this. - recurseDir SystemFS dir >>= - mapM_ Utility.FileMode.allowWrite - void $ tryIO $ removeDirectoryRecursive dir +cleanup = cleanup' False + +cleanup' :: Bool -> FilePath -> IO () +cleanup' final dir = whenM (doesDirectoryExist dir) $ do + -- Allow all files and directories to be written to, so + -- they can be deleted. Both git and git-annex use file + -- permissions to prevent deletion. + recurseDir SystemFS dir >>= + mapM_ Utility.FileMode.allowWrite + -- This sometimes fails on Windows, due to some files + -- being still opened by a subprocess. + catchIO (removeDirectoryRecursive dir) $ \e -> do + when final $ do + print e + putStrLn "sleeping 10 seconds and will retry directory cleanup" + Utility.ThreadScheduler.threadDelaySeconds (Utility.ThreadScheduler.Seconds 10) + whenM (doesDirectoryExist dir) $ do + removeDirectoryRecursive dir checklink :: FilePath -> Assertion checklink f = do @@ -1277,7 +1287,7 @@ withTestEnv forcedirect = withResource prepare release releaseTestEnv :: TestEnv -> IO () releaseTestEnv _env = do - cleanup tmpdir + cleanup' True tmpdir prepareTestEnv :: Bool -> IO TestEnv prepareTestEnv forcedirect = do |