WIP: removePathForcibly

OUTSTANDING ISSUES:
- No Windows support

System/Directory/Internal/C_utimensat.hsc

@@ -15,6 +15,7 @@ module System.Directory.Internal.C_utimensat where
 import Prelude ()
 import System.Directory.Internal.Prelude
 import Data.Time.Clock.POSIX (POSIXTime)
+import qualified System.Posix as Posix
 
 data CTimeSpec = CTimeSpec EpochTime CLong
 
@@ -29,9 +30,6 @@ instance Storable CTimeSpec where
       nsec <- #{peek struct timespec, tv_nsec} p
       return (CTimeSpec sec nsec)
 
-c_AT_FDCWD :: CInt
-c_AT_FDCWD = (#const AT_FDCWD)
-
 utimeOmit :: CTimeSpec
 utimeOmit = CTimeSpec (CTime 0) (#const UTIME_OMIT)
 
@@ -42,6 +40,6 @@ toCTimeSpec t = CTimeSpec (CTime sec) (truncate $ 10 ^ (9 :: Int) * frac)
     (sec', frac') = properFraction (toRational t)
 
 foreign import capi "sys/stat.h utimensat" c_utimensat
-  :: CInt -> CString -> Ptr CTimeSpec -> CInt -> IO CInt
+  :: Posix.Fd -> CString -> Ptr CTimeSpec -> CInt -> IO CInt
 
 #endif

System/Directory/Internal/Common.hs

@@ -126,6 +126,10 @@ ioeSetOsPath err =
     (mkUTF8 TransliterateCodingFailure)
     (mkUTF16le TransliterateCodingFailure)
 
+dropSpecialDotDirs :: [OsPath] -> [OsPath]
+dropSpecialDotDirs = filter f
+  where f filename = filename /= os "." && filename /= os ".."
+
 -- | Given a list of path segments, expand @.@ and @..@.  The path segments
 -- must not contain path separators.
 expandDots :: [OsPath] -> [OsPath]
@@ -215,6 +219,12 @@ simplifyWindows path
     subpathIsAbsolute = any isPathSeparator (take 1 (unpack subpath))
     hasTrailingPathSep = hasTrailingPathSeparator subpath
 
+data WhetherFollow = NoFollow | FollowLinks deriving (Show)
+
+isNoFollow :: WhetherFollow -> Bool
+isNoFollow NoFollow    = True
+isNoFollow FollowLinks = False
+
 data FileType = File
               | SymbolicLink -- ^ POSIX: either file or directory link; Windows: file link
               | Directory

System/Directory/Internal/Posix.hsc

@@ -1,9 +1,14 @@
+{-# LANGUAGE CApiFFI #-}
 module System.Directory.Internal.Posix where
 #include <HsDirectoryConfig.h>
 #if !defined(mingw32_HOST_OS)
+#include <fcntl.h>
 #ifdef HAVE_LIMITS_H
 # include <limits.h>
 #endif
+#ifdef HAVE_SYS_STAT_H
+# include <sys/stat.h>
+#endif
 import Prelude ()
 import System.Directory.Internal.Prelude
 #ifdef HAVE_UTIMENSAT
@@ -17,16 +22,62 @@ import System.OsPath ((</>), isRelative, splitSearchPath)
 import System.OsString.Internal.Types (OsString(OsString, getOsString))
 import qualified Data.Time.Clock.POSIX as POSIXTime
 import qualified System.OsPath.Internal as OsPath
+import qualified System.Posix.Directory.Fd as Posix
 import qualified System.Posix.Directory.PosixPath as Posix
 import qualified System.Posix.Env.PosixString as Posix
+import qualified System.Posix.Files as Posix (FileStatus(..))
 import qualified System.Posix.Files.PosixString as Posix
+import qualified System.Posix.Internals as Posix (CStat)
+import qualified System.Posix.IO.PosixString as Posix
 import qualified System.Posix.PosixPath.FilePath as Posix
 import qualified System.Posix.Types as Posix
 import qualified System.Posix.User.ByteString as Posix
 
+c_AT_FDCWD :: Posix.Fd
+c_AT_FDCWD = Posix.Fd (#const AT_FDCWD)
+
+c_AT_SYMLINK_NOFOLLOW :: CInt
+c_AT_SYMLINK_NOFOLLOW = (#const AT_SYMLINK_NOFOLLOW)
+
+atWhetherFollow :: WhetherFollow -> CInt
+atWhetherFollow NoFollow    = c_AT_SYMLINK_NOFOLLOW
+atWhetherFollow FollowLinks = 0
+
+defaultOpenFlags :: Posix.OpenFileFlags
+defaultOpenFlags =
+  Posix.defaultFileFlags
+  { Posix.noctty = True
+  , Posix.nonBlock = True
+  , Posix.cloexec = True
+  }
+
+type RawHandle = Posix.Fd
+
+openRaw :: WhetherFollow -> Maybe RawHandle -> OsPath -> IO RawHandle
+openRaw whetherFollow dir (OsString path) =
+  Posix.openFdAt dir path Posix.ReadOnly flags
+  where
+    flags = defaultOpenFlags { Posix.nofollow = isNoFollow whetherFollow }
+
+closeRaw :: RawHandle -> IO ()
+closeRaw = Posix.closeFd
+
 createDirectoryInternal :: OsPath -> IO ()
 createDirectoryInternal (OsString path) = Posix.createDirectory path 0o777
 
+foreign import ccall "unistd.h unlinkat" c_unlinkat
+  :: Posix.Fd -> CString -> CInt -> IO CInt
+
+removePathAt :: FileType -> Maybe RawHandle -> OsPath -> IO ()
+removePathAt ty dir (OsString path) =
+  Posix.withFilePath path $ \ pPath -> do
+    Posix.throwErrnoPathIfMinus1_ "unlinkat" path
+      (c_unlinkat (fromMaybe c_AT_FDCWD dir) pPath flag)
+    pure ()
+  where
+    flag | fileTypeIsDirectory ty = (#const AT_REMOVEDIR)
+         | otherwise              = 0
+
 removePathInternal :: Bool -> OsPath -> IO ()
 removePathInternal True  = Posix.removeDirectory . getOsString
 removePathInternal False = Posix.removeLink . getOsString
@@ -100,20 +151,25 @@ findExecutablesLazyInternal findExecutablesInDirectoriesLazy binary =
 exeExtensionInternal :: OsString
 exeExtensionInternal = exeExtension
 
+openDirFromFd :: Posix.Fd -> IO Posix.DirStream
+openDirFromFd fd = Posix.unsafeOpenDirStreamFd =<< Posix.dup fd
+
+readDirStreamToEnd :: Posix.DirStream -> IO [OsPath]
+readDirStreamToEnd stream = loop id
+  where
+    loop acc = do
+      e <- Posix.readDirStream stream
+      if e == mempty
+        then pure (acc [])
+        else loop (acc . (OsString e :))
+
+readDirToEnd :: RawHandle -> IO [OsPath]
+readDirToEnd fd =
+  bracket (openDirFromFd fd) Posix.closeDirStream readDirStreamToEnd
+
 getDirectoryContentsInternal :: OsPath -> IO [OsPath]
 getDirectoryContentsInternal (OsString path) =
-  bracket
-    (Posix.openDirStream path)
-    Posix.closeDirStream
-    start
-  where
-    start dirp = loop id
-      where
-        loop acc = do
-          e <- Posix.readDirStream dirp
-          if e == mempty
-            then pure (acc [])
-            else loop (acc . (OsString e :))
+  bracket (Posix.openDirStream path) Posix.closeDirStream readDirStreamToEnd
 
 getCurrentDirectoryInternal :: IO OsPath
 getCurrentDirectoryInternal = OsString <$> Posix.getWorkingDirectory
@@ -153,6 +209,20 @@ readSymbolicLink = (OsString <$>) . Posix.readSymbolicLink . getOsString
 
 type Metadata = Posix.FileStatus
 
+foreign import capi "sys/stat.h fstatat" c_fstatat
+  :: Posix.Fd -> CString -> Ptr Posix.CStat -> CInt -> IO CInt
+
+getMetadataAt :: WhetherFollow -> Maybe RawHandle -> OsPath -> IO Metadata
+getMetadataAt whetherFollow dir (OsString path) =
+  Posix.withFilePath path $ \ pPath -> do
+    stat <- mallocForeignPtrBytes (#const sizeof(struct stat))
+    withForeignPtr stat $ \ pStat -> do
+      Posix.throwErrnoPathIfMinus1_ "fstatat" path $ do
+        c_fstatat (fromMaybe c_AT_FDCWD dir) pPath pStat flags
+    pure (Posix.FileStatus stat)
+  where
+    flags = atWhetherFollow whetherFollow
+
 getSymbolicLinkMetadata :: OsPath -> IO Metadata
 getSymbolicLinkMetadata = Posix.getSymbolicLinkStatus . getOsString
 
@@ -197,6 +267,22 @@ setWriteMode :: Bool -> Mode -> Mode
 setWriteMode False m = m .&. complement allWriteMode
 setWriteMode True  m = m .|. allWriteMode
 
+foreign import capi "sys/stat.h fchmodat" c_fchmodat
+  :: Posix.Fd -> CString -> Posix.FileMode -> CInt -> IO CInt
+
+setModeAt :: WhetherFollow -> Maybe RawHandle -> OsPath -> Posix.FileMode -> IO ()
+setModeAt whetherFollow dir (OsString path) mode = do
+  Posix.withFilePath path $ \ pPath ->
+    Posix.throwErrnoPathIfMinus1_ "fchmodat" path $ do
+      c_fchmodat (fromMaybe c_AT_FDCWD dir) pPath mode flags
+  where
+    flags = atWhetherFollow whetherFollow
+
+forceRemovable :: Maybe RawHandle -> OsPath -> Metadata -> IO ()
+forceRemovable dir path metadata = do
+  let mode = modeFromMetadata metadata .|. Posix.ownerModes
+  setModeAt NoFollow dir path mode
+
 setFileMode :: OsPath -> Mode -> IO ()
 setFileMode = Posix.setFileMode . getOsString
 

System/Directory/Internal/Prelude.hs

@@ -58,7 +58,7 @@ import Control.Exception
 import Control.Monad ((>=>), (<=<), unless, when, replicateM, replicateM_)
 import Data.Bits ((.&.), (.|.), complement)
 import Data.Char (isAlpha, isAscii, toLower, toUpper)
-import Data.Foldable (for_)
+import Data.Foldable (for_, sequenceA_)
 import Data.Function (on)
 import Data.Maybe (catMaybes, fromMaybe, maybeToList)
 import Data.Monoid ((<>), mconcat, mempty)
@@ -80,11 +80,13 @@ import Foreign
   , allocaArray
   , allocaBytes
   , allocaBytesAligned
+  , mallocForeignPtrBytes
   , maybeWith
   , nullPtr
   , plusPtr
   , with
   , withArray
+  , withForeignPtr
   )
 import Foreign.C
   ( CInt(..)

System/Directory/Internal/Windows.hsc

@@ -518,6 +518,15 @@ createSymbolicLink isDir target link =
       (normaliseSeparators target)
       isDir
 
+type FileRef = OsPath
+
+data Subref = NotSubdir -- ^ Not a directory (perhaps regular file or symlink).
+            | SubdirRef FileRef -- ^ Is a subdirectory.
+            deriving (Show)
+
+withSubref :: Maybe FileRef -> OsPath -> (Subref -> IO r) -> IO r
+withSubref dirRef name action = action (fromMaybe (os ".") dirRef </> name)
+
 type Metadata = Win32.BY_HANDLE_FILE_INFORMATION
 
 getSymbolicLinkMetadata :: OsPath -> IO Metadata

System/Directory/OsPath.hs

@@ -392,6 +392,40 @@ The operand refers to an existing non-directory object.
 removeDirectory :: OsPath -> IO ()
 removeDirectory = removePathInternal True
 
+type Preremover = Maybe RawHandle -> OsPath -> Metadata -> IO ()
+
+noPreremover :: Preremover
+noPreremover _ _ _ = pure ()
+
+forcePreremover :: Maybe RawHandle -> OsPath -> Metadata -> IO ()
+forcePreremover dir name metadata = do
+  when (fileTypeIsDirectory (fileTypeFromMetadata metadata)
+        || not filesAlwaysRemovable) $ do
+    forceRemovable dir name metadata
+      `catchIOError` \ _ -> pure ()
+
+removeRecursivelyAt
+  :: (IO () -> IO ())
+  -> ([IO ()] -> IO ())
+  -> Preremover
+  -> Maybe RawHandle
+  -> OsPath
+  -> IO ()
+removeRecursivelyAt catcher sequencer preremover dir name = catcher $ do
+  metadata <- getMetadataAt NoFollow dir name
+  preremover dir name metadata
+  let
+    fileType = fileTypeFromMetadata metadata
+    subremovals = do
+      when (fileType == Directory) $ do
+        bracket (openRaw NoFollow dir name) closeRaw $ \ handle -> do
+          -- dropSpecialDotDirs is extremely important! Otherwise it will
+          -- recurse into the parent directory and wreak havoc.
+          names <- dropSpecialDotDirs <$> readDirToEnd handle
+          sequencer (recurse (Just handle) <$> names)
+  sequencer [subremovals, removePathAt fileType dir name]
+  where recurse = removeRecursivelyAt catcher sequencer preremover
+
 -- | @'removeDirectoryRecursive' dir@ removes an existing directory /dir/
 -- together with its contents and subdirectories. Within this directory,
 -- symbolic links are removed without affecting their targets.
@@ -406,41 +440,13 @@ removeDirectoryRecursive path =
     m <- getSymbolicLinkMetadata path
     case fileTypeFromMetadata m of
       Directory ->
-        removeContentsRecursive path
+        removeRecursivelyAt id sequenceA_ noPreremover Nothing path
       DirectoryLink ->
         ioError (err `ioeSetErrorString` "is a directory symbolic link")
       _ ->
         ioError (err `ioeSetErrorString` "not a directory")
   where err = mkIOError InappropriateType "" Nothing Nothing `ioeSetOsPath` path
 
--- | @removePathRecursive path@ removes an existing file or directory at
--- /path/ together with its contents and subdirectories. Symbolic links are
--- removed without affecting their the targets.
---
--- This operation is reported to be flaky on Windows so retry logic may
--- be advisable. See: https://github.com/haskell/directory/pull/108
-removePathRecursive :: OsPath -> IO ()
-removePathRecursive path =
-  (`ioeAddLocation` "removePathRecursive") `modifyIOError` do
-    m <- getSymbolicLinkMetadata path
-    case fileTypeFromMetadata m of
-      Directory     -> removeContentsRecursive path
-      DirectoryLink -> removeDirectory path
-      _             -> removeFile path
-
--- | @removeContentsRecursive dir@ removes the contents of the directory
--- /dir/ recursively. Symbolic links are removed without affecting their the
--- targets.
---
--- This operation is reported to be flaky on Windows so retry logic may
--- be advisable. See: https://github.com/haskell/directory/pull/108
-removeContentsRecursive :: OsPath -> IO ()
-removeContentsRecursive path =
-  (`ioeAddLocation` "removeContentsRecursive") `modifyIOError` do
-    cont <- listDirectory path
-    for_ [path </> x | x <- cont] removePathRecursive
-    removeDirectory path
-
 -- | Removes a file or directory at /path/ together with its contents and
 -- subdirectories. Symbolic links are removed without affecting their
 -- targets. If the path does not exist, nothing happens.
@@ -460,34 +466,19 @@ removeContentsRecursive path =
 removePathForcibly :: OsPath -> IO ()
 removePathForcibly path =
   (`ioeAddLocation` "removePathForcibly") `modifyIOError` do
-    ignoreDoesNotExistError $ do
-      m <- getSymbolicLinkMetadata path
-      case fileTypeFromMetadata m of
-        DirectoryLink -> do
-          makeRemovable path
-          removeDirectory path
-        Directory -> do
-          makeRemovable path
-          names <- listDirectory path
-          sequenceWithIOErrors_ $
-            [ removePathForcibly (path </> name) | name <- names ] ++
-            [ removeDirectory path ]
-        _ -> do
-          unless filesAlwaysRemovable (makeRemovable path)
-          removeFile path
+    removeRecursivelyAt
+      ignoreDoesNotExistError
+      sequenceWithIOErrors_
+      forcePreremover
+      Nothing
+      path
+
   where
 
     ignoreDoesNotExistError :: IO () -> IO ()
     ignoreDoesNotExistError action =
       () <$ tryIOErrorType isDoesNotExistError action
 
-    makeRemovable :: OsPath -> IO ()
-    makeRemovable p = (`catchIOError` \ _ -> pure ()) $ do
-      perms <- getPermissions p
-      setPermissions path perms{ readable = True
-                               , searchable = True
-                               , writable = True }
-
 {- |'removeFile' /file/ removes the directory entry for an existing file
 /file/, where /file/ is not itself a directory. The
 implementation may specify additional constraints which must be
@@ -1140,8 +1131,7 @@ getDirectoryContents path =
 --   @[ENOTDIR]@
 --
 listDirectory :: OsPath -> IO [OsPath]
-listDirectory path = filter f <$> getDirectoryContents path
-  where f filename = filename /= os "." && filename /= os ".."
+listDirectory path = dropSpecialDotDirs <$> getDirectoryContents path
 
 -- | Obtain the current working directory as an absolute path.
 --