From 6148ae3a499f11187182c04b13aa462351f4a5d6 Mon Sep 17 00:00:00 2001 From: Phil Ruffwind Date: Wed, 18 Feb 2015 03:22:49 -0500 Subject: [PATCH] Add regression tests for removeDirectoryRecursive bug (#15) --- tests/.gitignore | 1 + tests/TestUtils.hs | 88 ++++++++++++++++++++++ tests/all.T | 2 + tests/removeDirectoryRecursive001.hs | 93 ++++++++++++++++++++++++ tests/removeDirectoryRecursive001.stdout | 19 +++++ 5 files changed, 203 insertions(+) create mode 100644 tests/TestUtils.hs create mode 100644 tests/removeDirectoryRecursive001.hs create mode 100644 tests/removeDirectoryRecursive001.stdout diff --git a/tests/.gitignore b/tests/.gitignore index 9abd17e2..4a62c19f 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 00000000..36c357e1 --- /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 3279e5d7..d2a84407 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 00000000..fbd38e71 --- /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 00000000..09670142 --- /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 + +. ..