Commit 6c09d448 authored by Duncan Coutts's avatar Duncan Coutts Committed by Alexis Williams
Browse files

Try yet again with the windows file lock problem

Try the "retry N times on permission errors" strategy.
parent b72d7173
......@@ -607,6 +607,7 @@ executable cabal
UnitTests.Distribution.Solver.Modular.Solver
UnitTests.Distribution.Solver.Modular.WeightedPSQ
UnitTests.Options
UnitTests.TempTestDir
cpp-options: -DMONOLITHIC
build-depends:
......@@ -672,6 +673,7 @@ Test-Suite unit-tests
UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils
UnitTests.Distribution.Solver.Modular.WeightedPSQ
UnitTests.Options
UnitTests.TempTestDir
build-depends:
array,
base,
......
......@@ -8,8 +8,6 @@ import Distribution.Types.PackageName
import Distribution.Types.SourceRepo
import Distribution.Verbosity as Verbosity
import Distribution.Version
import Distribution.Simple.Utils
( withTempDirectory )
import Control.Monad
import Control.Exception
......@@ -22,6 +20,8 @@ import System.IO.Error
import Test.Tasty
import Test.Tasty.HUnit
import UnitTests.Options (RunNetworkTests (..))
import UnitTests.TempTestDir (withTestDir)
tests :: [TestTree]
tests =
......@@ -140,7 +140,7 @@ testSelectRepoKind =
testRepoDestinationExists :: Assertion
testRepoDestinationExists =
withTempDirectory verbosity "." "repos" $ \tmpdir -> do
withTestDir verbosity "repos" $ \tmpdir -> do
let pkgdir = tmpdir </> "foo"
createDirectory pkgdir
e1 <- assertException $
......@@ -163,7 +163,7 @@ testRepoDestinationExists =
testGitFetchFailed :: Assertion
testGitFetchFailed =
withTempDirectory verbosity "." "repos" $ \tmpdir -> do
withTestDir verbosity "repos" $ \tmpdir -> do
let srcdir = tmpdir </> "src"
repo = (emptySourceRepo RepoHead) {
repoType = Just Git,
......@@ -177,7 +177,7 @@ testGitFetchFailed =
testNetworkGitClone :: Assertion
testNetworkGitClone =
withTempDirectory verbosity "." "repos" $ \tmpdir -> do
withTestDir verbosity "repos" $ \tmpdir -> do
let repo1 = (emptySourceRepo RepoHead) {
repoType = Just Git,
repoLocation = Just "https://github.com/haskell/zlib.git"
......
......@@ -5,8 +5,6 @@ import Distribution.Client.VCS
import Distribution.Client.RebuildMonad
( execRebuild )
import Distribution.Simple.Program
import Distribution.Compat.Internal.TempFile
( createTempDirectory )
import Distribution.Verbosity as Verbosity
import Distribution.Types.SourceRepo
......@@ -28,11 +26,11 @@ import System.IO
import System.FilePath
import System.Directory
import System.Random
import qualified System.Info (os)
import Test.Tasty
import Test.Tasty.QuickCheck
import UnitTests.Distribution.Client.ArbitraryInstances
import UnitTests.TempTestDir (withTestDir)
-- | These tests take the following approach: we generate a pure representation
......@@ -132,7 +130,7 @@ testSetup :: VCS Program
testSetup vcs mkVCSTestDriver repoRecipe theTest = do
-- test setup
vcs' <- configureVCS verbosity vcs
withTestDir $ \tmpdir -> do
withTestDir verbosity "vcstest" $ \tmpdir -> do
let srcRepoPath = tmpdir </> "src"
vcsDriver = mkVCSTestDriver verbosity vcs' srcRepoPath
repoState <- createRepo vcsDriver repoRecipe
......@@ -694,27 +692,3 @@ vcsTestDriverDarcs mtimeChange verbosity vcs repoRoot =
}
darcs = runProgramInvocation verbosity . darcsInvocation
-- ------------------------------------------------------------
-- * Utils
-- ------------------------------------------------------------
withTestDir :: (FilePath -> IO a) -> IO a
withTestDir action = do
systmpdir <- getTemporaryDirectory
bracket
(createTempDirectory systmpdir "vcstest")
(\dir -> windowsFileLockHack >> removeDirectoryRecursive dir)
action
where
-- On Windows, file locks held by programs we run (in this case VCSs)
-- are not always released prior to completing process termination! (WTF!)
-- https://msdn.microsoft.com/en-us/library/windows/desktop/aa365202.aspx
-- This means we run into stale locks when trying to delete the test
-- directory. There is no sane way to wait on those locks being released,
-- we just have to wait and hope. Lets hope 10 second is enough.
windowsFileLockHack | isWindows = threadDelay 10000000
| otherwise = return ()
isWindows = System.Info.os == "mingw32"
module UnitTests.TempTestDir (
withTestDir
) where
import Distribution.Verbosity
import Distribution.Compat.Internal.TempFile (createTempDirectory)
import Distribution.Simple.Utils (warn)
import Control.Monad (when)
import Control.Exception (bracket, try, throwIO)
import Control.Concurrent (threadDelay)
import System.IO.Error (isPermissionError)
import System.Directory (getTemporaryDirectory, removeDirectoryRecursive)
import qualified System.Info (os)
withTestDir :: Verbosity -> String -> (FilePath -> IO a) -> IO a
withTestDir verbosity template action = do
systmpdir <- getTemporaryDirectory
bracket
(createTempDirectory systmpdir template)
(removeDirectoryRecursiveHack verbosity)
action
-- | On Windows, file locks held by programs we run (in this case VCSs)
-- are not always released prior to completing process termination!
-- <https://msdn.microsoft.com/en-us/library/windows/desktop/aa365202.aspx>
-- This means we run into stale locks when trying to delete the test
-- directory. There is no sane way to wait on those locks being released,
-- we just have to wait, try again and hope.
--
removeDirectoryRecursiveHack :: Verbosity -> FilePath -> IO ()
removeDirectoryRecursiveHack verbosity dir | isWindows = go 0
where
isWindows = System.Info.os == "mingw32"
limit = 30
go :: Int -> IO ()
go n = do
res <- try $ removeDirectoryRecursive dir
case res of
Left e
-- wait a second and try again
| isPermissionError e && n+1 < limit -> do
threadDelay 1000000
go (n+1)
-- but if we hit the limt warn and fail.
| isPermissionError e -> do
warn verbosity $ "Windows file locking hack: hit the retry limit "
++ show n ++ " while trying to remove " ++ dir
throwIO e
-- or it's a different error fail.
| otherwise -> throwIO e
Right () ->
when (n >= 3) $
warn verbosity $ "Windows file locking hack: had to try " ++ show n
++ " times to remove " ++ dir
removeDirectoryRecursiveHack _ dir = removeDirectoryRecursive dir
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