[commit: packages/directory] master: Add regression test for removeDirectoryRecursive bug (issue #15) (23b416f)
git at git.haskell.org
git at git.haskell.org
Thu Mar 19 11:38:10 UTC 2015
Repository : ssh://git@git.haskell.org/directory
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/23b416fdca01737223395f1cd243e67e31293101/directory
>---------------------------------------------------------------
commit 23b416fdca01737223395f1cd243e67e31293101
Author: Phil Ruffwind <rf at rufflewind.com>
Date: Wed Feb 18 03:22:49 2015 -0500
Add regression test for removeDirectoryRecursive bug (issue #15)
>---------------------------------------------------------------
23b416fdca01737223395f1cd243e67e31293101
tests/.gitignore | 1 +
tests/TestUtils.hs | 88 ++++++++++++++++++++++++++++++
tests/all.T | 2 +
tests/removeDirectoryRecursive001.hs | 93 ++++++++++++++++++++++++++++++++
tests/removeDirectoryRecursive001.stdout | 19 +++++++
5 files changed, 203 insertions(+)
diff --git a/tests/.gitignore b/tests/.gitignore
index 9abd17e..4a62c19 100644
--- a/tests/.gitignore
+++ b/tests/.gitignore
@@ -23,4 +23,5 @@
/getPermissions001
/renameFile001
/renameFile001.tmp1
+/removeDirectoryRecursive001
/T8482
diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs
new file mode 100644
index 0000000..36c357e
--- /dev/null
+++ b/tests/TestUtils.hs
@@ -0,0 +1,88 @@
+{-# LANGUAGE CPP, ForeignFunctionInterface #-}
+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
diff --git a/tests/all.T b/tests/all.T
index 3279e5d..d2a8440 100644
--- a/tests/all.T
+++ b/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, [''])
diff --git a/tests/removeDirectoryRecursive001.hs b/tests/removeDirectoryRecursive001.hs
new file mode 100644
index 0000000..fbd38e7
--- /dev/null
+++ b/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
diff --git a/tests/removeDirectoryRecursive001.stdout b/tests/removeDirectoryRecursive001.stdout
new file mode 100644
index 0000000..0967014
--- /dev/null
+++ b/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
+
+. ..
More information about the ghc-commits
mailing list