cabal-install/tests/UnitTests/TempTestDir.hs

   1 {-# LANGUAGE CPP #-}
   2
   3 module UnitTests.TempTestDir
   4   ( withTestDir
   5   , removeDirectoryRecursiveHack
   6   ) where
   7
   8 import Distribution.Compat.Internal.TempFile (createTempDirectory)
   9 import Distribution.Simple.Utils (warn)
  10 import Distribution.Verbosity
  11
  12 import Control.Concurrent (threadDelay)
  13 import Control.Exception (bracket, throwIO, try)
  14 import Control.Monad (when)
  15
  16 import System.Directory
  17 import System.IO.Error
  18 #if !(MIN_VERSION_directory(1,2,7))
  19 import System.FilePath ((</>))
  20 #endif
  21 import qualified System.Info (os)
  22
  23 -- | Much like 'withTemporaryDirectory' but with a number of hacks to make
  24 -- sure on windows that we can clean up the directory at the end.
  25 withTestDir :: Verbosity -> String -> (FilePath -> IO a) -> IO a
  26 withTestDir verbosity template action = do
  27   systmpdir <- getTemporaryDirectory
  28   bracket
  29     (createTempDirectory systmpdir template)
  30     (removeDirectoryRecursiveHack verbosity)
  31     action
  32
  33 -- | On Windows, file locks held by programs we run (in this case VCSs)
  34 -- are not always released prior to completing process termination!
  35 -- <https://msdn.microsoft.com/en-us/library/windows/desktop/aa365202.aspx>
  36 -- This means we run into stale locks when trying to delete the test
  37 -- directory. There is no sane way to wait on those locks being released,
  38 -- we just have to wait, try again and hope.
  39 --
  40 -- In addition, on Windows a file that is not writable also cannot be deleted,
  41 -- so we must try setting the permissions to readable before deleting files.
  42 -- Some VCS tools on Windows create files with read-only attributes.
  43 removeDirectoryRecursiveHack :: Verbosity -> FilePath -> IO ()
  44 removeDirectoryRecursiveHack verbosity dir | isWindows = go 1
  45   where
  46     isWindows = System.Info.os == "mingw32"
  47     limit = 3
  48
  49     go :: Int -> IO ()
  50     go n = do
  51       res <- try $ removePathForcibly dir
  52       case res of
  53         Left e
  54           -- wait a second and try again
  55           | isPermissionError e && n < limit -> do
  56               threadDelay 1000000
  57               go (n + 1)
  58
  59           -- but if we hit the limt warn and fail.
  60           | isPermissionError e -> do
  61               warn verbosity $
  62                 "Windows file locking hack: hit the retry limit "
  63                   ++ show limit
  64                   ++ " while trying to remove "
  65                   ++ dir
  66               throwIO e
  67
  68           -- or it's a different error fail.
  69           | otherwise -> throwIO e
  70         Right () ->
  71           when (n > 1) $
  72             warn verbosity $
  73               "Windows file locking hack: had to try "
  74                 ++ show n
  75                 ++ " times to remove "
  76                 ++ dir
  77 removeDirectoryRecursiveHack _ dir = removeDirectoryRecursive dir
  78
  79 #if !(MIN_VERSION_directory(1,2,7))
  80 -- A simplified version that ought to work for our use case here, and does
  81 -- not rely on directory internals.
  82 removePathForcibly :: FilePath -> IO ()
  83 removePathForcibly path = do
  84     makeRemovable path `catchIOError` \ _ -> pure ()
  85     isDir <- doesDirectoryExist path
  86     if isDir
  87        then do
  88          entries <- getDirectoryContents path
  89          sequence_
  90            [ removePathForcibly (path </> entry)
  91            | entry <- entries, entry /= ".", entry /= ".." ]
  92          removeDirectory path
  93        else
  94          removeFile path
  95   where
  96     makeRemovable :: FilePath -> IO ()
  97     makeRemovable p =
  98       setPermissions p emptyPermissions {
  99         readable   = True,
 100         searchable = True,
 101         writable   = True
 102       }
 103 #endif