1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
|
{-# LANGUAGE CPP #-}
module UnitTests.TempTestDir (
withTestDir, removeDirectoryRecursiveHack
) 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
import System.Directory
#if !(MIN_VERSION_directory(1,2,7))
import System.FilePath ((</>))
#endif
import qualified System.Info (os)
-- | Much like 'withTemporaryDirectory' but with a number of hacks to make
-- sure on windows that we can clean up the directory at the end.
--
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.
--
-- In addition, on Windows a file that is not writable also cannot be deleted,
-- so we must try setting the permissions to readable before deleting files.
-- Some VCS tools on Windows create files with read-only attributes.
--
removeDirectoryRecursiveHack :: Verbosity -> FilePath -> IO ()
removeDirectoryRecursiveHack verbosity dir | isWindows = go 1
where
isWindows = System.Info.os == "mingw32"
limit = 3
go :: Int -> IO ()
go n = do
res <- try $ removePathForcibly dir
case res of
Left e
-- wait a second and try again
| isPermissionError e && n < 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 limit ++ " while trying to remove " ++ dir
throwIO e
-- or it's a different error fail.
| otherwise -> throwIO e
Right () ->
when (n > 1) $
warn verbosity $ "Windows file locking hack: had to try "
++ show n ++ " times to remove " ++ dir
removeDirectoryRecursiveHack _ dir = removeDirectoryRecursive dir
#if !(MIN_VERSION_directory(1,2,7))
-- A simplified version that ought to work for our use case here, and does
-- not rely on directory internals.
removePathForcibly :: FilePath -> IO ()
removePathForcibly path = do
makeRemovable path `catchIOError` \ _ -> pure ()
isDir <- doesDirectoryExist path
if isDir
then do
entries <- getDirectoryContents path
sequence_
[ removePathForcibly (path </> entry)
| entry <- entries, entry /= ".", entry /= ".." ]
removeDirectory path
else
removeFile path
where
makeRemovable :: FilePath -> IO ()
makeRemovable p =
setPermissions p emptyPermissions {
readable = True,
searchable = True,
writable = True
}
#endif
|
