Add regression tests for removeDirectoryRecursive bug (haskell#15)

tests/.gitignore

@@ -23,4 +23,5 @@
 /getPermissions001
 /renameFile001
 /renameFile001.tmp1
+/removeDirectoryRecursive001
 /T8482

tests/TestUtils.hs

@@ -0,0 +1,88 @@
+{-# LANGUAGE CPP #-}
+module TestUtils
+  ( copyPathRecursive
+  , createSymbolicLink
+  , modifyPermissions
+  , tryCreateSymbolicLink
+  ) where
+import System.Directory
+import System.FilePath ((</>))
+import System.IO.Error (ioeSetLocation, modifyIOError)
+#ifdef mingw32_HOST_OS
+import Foreign (Ptr)
+import Foreign.C (CUChar(..), CULong(..), CWchar(..), withCWString)
+import System.FilePath (takeDirectory)
+import System.IO (hPutStrLn, stderr)
+import System.IO.Error (catchIOError, ioeSetErrorString, isPermissionError,
+                        mkIOError, permissionErrorType)
+import System.Win32.Types (failWith, getLastError)
+#else
+import System.Posix.Files (createSymbolicLink)
+#endif
+
+#ifdef mingw32_HOST_OS
+# if defined i386_HOST_ARCH
+#  define WINAPI stdcall
+# elif defined x86_64_HOST_ARCH
+#  define WINAPI ccall
+# else
+#  error unknown architecture
+# endif
+foreign import WINAPI unsafe "windows.h CreateSymbolicLinkW"
+  c_CreateSymbolicLink :: Ptr CWchar -> Ptr CWchar -> CULong -> IO CUChar
+#endif
+
+-- | @'copyPathRecursive' path@ copies an existing file or directory at
+--   /path/ together with its contents and subdirectories.
+--
+--   Warning: mostly untested and might not handle symlinks correctly.
+copyPathRecursive :: FilePath -> FilePath -> IO ()
+copyPathRecursive source dest =
+  (`ioeSetLocation` "copyPathRecursive") `modifyIOError` do
+    dirExists <- doesDirectoryExist source
+    if dirExists
+      then do
+        contents <- getDirectoryContents source
+        createDirectory dest
+        mapM_ (uncurry copyPathRecursive)
+          [(source </> x, dest </> x) | x <- contents, x /= "." && x /= ".."]
+      else copyFile source dest
+
+modifyPermissions :: FilePath -> (Permissions -> Permissions) -> IO ()
+modifyPermissions path modify = do
+  permissions <- getPermissions path
+  setPermissions path (modify permissions)
+
+#if mingw32_HOST_OS
+createSymbolicLink :: String -> String -> IO ()
+createSymbolicLink target link =
+  (`ioeSetLocation` "createSymbolicLink") `modifyIOError` do
+    isDir <- (fromIntegral . fromEnum) `fmap`
+             doesDirectoryExist (takeDirectory link </> target)
+    withCWString target $ \ target' ->
+      withCWString link $ \ link' -> do
+        status <- c_CreateSymbolicLink link' target' isDir
+        if status == 0
+          then do
+            errCode <- getLastError
+            if errCode == c_ERROR_PRIVILEGE_NOT_HELD
+              then ioError . (`ioeSetErrorString` permissionErrorMsg) $
+                   mkIOError permissionErrorType "" Nothing (Just link)
+              else failWith "createSymbolicLink" errCode
+          else return ()
+  where c_ERROR_PRIVILEGE_NOT_HELD = 0x522
+        permissionErrorMsg = "no permission to create symbolic links"
+#endif
+
+-- | Attempt to create a symbolic link.  On Windows, this falls back to
+--   copying if forbidden due to Group Policies.
+tryCreateSymbolicLink :: FilePath -> FilePath -> IO ()
+tryCreateSymbolicLink target link = createSymbolicLink target link
+#ifdef mingw32_HOST_OS
+  `catchIOError` \ e ->
+    if isPermissionError e
+    then do
+      copyPathRecursive (takeDirectory link </> target) link
+      hPutStrLn stderr "warning: didn't test symlinks due to Group Policy"
+    else ioError e
+#endif

tests/all.T

@@ -28,3 +28,5 @@ test('createDirectoryIfMissing001',  normal, compile_and_run, [''])
 test('getHomeDirectory001',  ignore_output, compile_and_run, [''])
 
 test('T8482',  normal, compile_and_run, [''])
+
+test('removeDirectoryRecursive001', normal, compile_and_run, [''])

tests/removeDirectoryRecursive001.hs

@@ -0,0 +1,93 @@
+{-# LANGUAGE CPP #-}
+module Main (main) where
+import Data.List (sort)
+import System.Directory
+import System.FilePath ((</>), normalise)
+import System.IO.Error (catchIOError)
+import TestUtils
+
+testName :: String
+testName = "removeDirectoryRecursive001"
+
+tmpD :: String
+tmpD  = testName ++ ".tmp"
+
+tmp :: String -> String
+tmp s = tmpD </> normalise s
+
+main :: IO ()
+main = do
+
+  ------------------------------------------------------------
+  -- clean up junk from previous invocations
+
+  modifyPermissions (tmp "c") (\ p -> p { writable = True })
+    `catchIOError` \ _ -> return ()
+  removeDirectoryRecursive tmpD
+    `catchIOError` \ _ -> return ()
+
+  ------------------------------------------------------------
+  -- set up
+
+  createDirectoryIfMissing True (tmp "a/x/w")
+  createDirectoryIfMissing True (tmp "a/y")
+  createDirectoryIfMissing True (tmp "a/z")
+  createDirectoryIfMissing True (tmp "b")
+  createDirectoryIfMissing True (tmp "c")
+  writeFile (tmp "a/x/w/u") "foo"
+  writeFile (tmp "a/t")     "bar"
+  tryCreateSymbolicLink (normalise "../a") (tmp "b/g")
+  tryCreateSymbolicLink (normalise "../b") (tmp "c/h")
+  tryCreateSymbolicLink (normalise "a")    (tmp "d")
+  modifyPermissions (tmp "c") (\ p -> p { writable = False })
+
+  ------------------------------------------------------------
+  -- tests
+
+  getDirectoryContents  tmpD     >>= putStrLn . unwords . sort
+  getDirectoryContents (tmp "a") >>= putStrLn . unwords . sort
+  getDirectoryContents (tmp "b") >>= putStrLn . unwords . sort
+  getDirectoryContents (tmp "c") >>= putStrLn . unwords . sort
+  getDirectoryContents (tmp "d") >>= putStrLn . unwords . sort
+
+  putStrLn ""
+
+  removeDirectoryRecursive (tmp "d")
+    `catchIOError` \ _ -> removeFile      (tmp "d")
+#ifdef mingw32_HOST_OS
+    `catchIOError` \ _ -> removeDirectory (tmp "d")
+#endif
+
+  getDirectoryContents  tmpD     >>= putStrLn . unwords . sort
+  getDirectoryContents (tmp "a") >>= putStrLn . unwords . sort
+  getDirectoryContents (tmp "b") >>= putStrLn . unwords . sort
+  getDirectoryContents (tmp "c") >>= putStrLn . unwords . sort
+
+  putStrLn ""
+
+  removeDirectoryRecursive (tmp "c")
+    `catchIOError` \ _ -> do
+      modifyPermissions (tmp "c") (\ p -> p { writable = True })
+      removeDirectoryRecursive (tmp "c")
+
+  getDirectoryContents  tmpD     >>= putStrLn . unwords . sort
+  getDirectoryContents (tmp "a") >>= putStrLn . unwords . sort
+  getDirectoryContents (tmp "b") >>= putStrLn . unwords . sort
+
+  putStrLn ""
+
+  removeDirectoryRecursive (tmp "b")
+
+  getDirectoryContents  tmpD     >>= putStrLn . unwords . sort
+  getDirectoryContents (tmp "a") >>= putStrLn . unwords . sort
+
+  putStrLn ""
+
+  removeDirectoryRecursive (tmp "a")
+
+  getDirectoryContents  tmpD     >>= putStrLn . unwords . sort
+
+  ------------------------------------------------------------
+  -- clean up
+
+  removeDirectoryRecursive tmpD

tests/removeDirectoryRecursive001.stdout

@@ -0,0 +1,19 @@
+. .. a b c d
+. .. t x y z
+. .. g
+. .. h
+. .. t x y z
+
+. .. a b c
+. .. t x y z
+. .. g
+. .. h
+
+. .. a b
+. .. t x y z
+. .. g
+
+. .. a
+. .. t x y z
+
+. ..