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

@@ -215,6 +215,10 @@ simplifyWindows path
     subpathIsAbsolute = any isPathSeparator (take 1 (unpack subpath))
     hasTrailingPathSep = hasTrailingPathSeparator subpath
 
+-- | Whether to follow symbolic links when opening files.
+data FollowMode = FollowLinks | NoFollow
+                deriving (Bounded, Enum, Eq, Ord, Read, Show)
+
 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,66 @@ 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.PosixString as Posix
+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
 
 createDirectoryInternal :: OsPath -> IO ()
 createDirectoryInternal (OsString path) = Posix.createDirectory path 0o777
 
+c_AT_FDCWD :: Posix.Fd
+c_AT_FDCWD = Posix.Fd (#const AT_FDCWD)
+
+data CStat = CStat { st_mode :: CMode }
+
+instance Storable CStat where
+  sizeOf    _ = #{size      struct stat}
+  alignment _ = #{alignment struct stat}
+  poke p (CStat { st_mode = mode }) = do
+    (#poke struct stat, st_mode) p mode
+  peek p = do
+    mode <- #{peek struct stat, st_mode} p
+    pure (CStat { st_mode = mode })
+
+foreign import capi "sys/stat.h fstatat" c_fstatat
+  :: Posix.Fd -> CString -> Ptr CStat -> CInt -> IO CInt
+
+c_AT_SYMLINK_NOFOLLOW :: CInt
+c_AT_SYMLINK_NOFOLLOW = (#const AT_SYMLINK_NOFOLLOW)
+
+-- This is conceptually the same as Posix.FileStatus, but since
+-- Posix.FileStatus is private we cannot use that version.
+type Stat = CStat
+
+statAtNoFollow :: Maybe FileRef -> OsPath -> IO Stat
+statAtNoFollow dirRef (OsString path) =
+  Posix.withFilePath path $ \ pPath ->
+  alloca $ \ pStat -> do
+    Posix.throwErrnoPathIfMinus1_ "fstatat" path $ do
+      c_fstatat (fromMaybe c_AT_FDCWD dirRef) pPath pStat c_AT_SYMLINK_NOFOLLOW
+    peek pStat
+
+statIsDirectory :: Stat -> Bool
+statIsDirectory m = (Posix.directoryMode .&. st_mode m) /= 0
+
+foreign import ccall "unistd.h unlinkat" c_unlinkat
+  :: Posix.Fd -> CString -> CInt -> IO CInt
+
+removePathAt :: FileType -> Maybe FileRef -> OsPath -> IO ()
+removePathAt fType dirRef (OsString path) =
+  Posix.withFilePath path $ \ pPath -> do
+    Posix.throwErrnoPathIfMinus1_ "unlinkat" path
+      (c_unlinkat (fromMaybe c_AT_FDCWD dirRef) pPath flag)
+    pure ()
+  where
+    flag | fileTypeIsDirectory fType = (#const AT_REMOVEDIR)
+         | otherwise                 = 0
+
 removePathInternal :: Bool -> OsPath -> IO ()
 removePathInternal True  = Posix.removeDirectory . getOsString
 removePathInternal False = Posix.removeLink . getOsString
@@ -101,9 +156,13 @@ exeExtensionInternal :: OsString
 exeExtensionInternal = exeExtension
 
 getDirectoryContentsInternal :: OsPath -> IO [OsPath]
-getDirectoryContentsInternal (OsString path) =
+getDirectoryContentsInternal path =
+  withFileRef Nothing path getDirectoryContentsAt
+
+getDirectoryContentsAt :: FileRef -> IO [OsPath]
+getDirectoryContentsAt fileRef =
   bracket
-    (Posix.openDirStream path)
+    (Posix.unsafeOpenDirStreamFd =<< Posix.dup fileRef)
     Posix.closeDirStream
     start
   where
@@ -151,11 +210,53 @@ createSymbolicLink _ (OsString p1) (OsString p2) =
 readSymbolicLink :: OsPath -> IO OsPath
 readSymbolicLink = (OsString <$>) . Posix.readSymbolicLink . getOsString
 
+defaultFlags :: Posix.OpenFileFlags
+defaultFlags =
+  Posix.defaultFileFlags
+  { Posix.noctty = True
+  , Posix.nonBlock = True
+  , Posix.cloexec = True
+  }
+
+type FileRef = Posix.Fd
+
+withFileRef :: Maybe FileRef -> OsPath -> (FileRef -> IO r) -> IO r
+withFileRef dirRef (OsString path) =
+  bracket
+    (Posix.openFdAt dirRef path Posix.ReadOnly defaultFlags)
+    Posix.closeFd
+
+data NoFollowRef = NoFollowLink | NoFollowRef FileRef deriving (Show)
+
+withNoFollowRef :: Maybe FileRef -> OsPath -> (NoFollowRef -> IO r) -> IO r
+withNoFollowRef dirRef path action =
+  (`ioeAddLocation` show (dirRef, path)) `modifyIOError` -- TEMPORARY
+  bracket (openNoFollowRef dirRef path) closeNoFollowRef action
+
+openNoFollowRef :: Maybe FileRef -> OsPath -> IO NoFollowRef
+openNoFollowRef dirRef (OsString path) = do
+  let flags = defaultFlags { Posix.nofollow = True }
+  result <- tryIOError (Posix.openFdAt dirRef path Posix.ReadOnly flags)
+  case result of
+    Left err -> do
+      errno <- getErrno
+      if errno == eLOOP
+        then pure NoFollowLink
+        else throwIO err
+    Right val -> pure (NoFollowRef val)
+
+closeNoFollowRef :: NoFollowRef -> IO ()
+closeNoFollowRef  NoFollowLink    = pure ()
+closeNoFollowRef (NoFollowRef fd) = Posix.closeFd fd
+
 type Metadata = Posix.FileStatus
 
 getSymbolicLinkMetadata :: OsPath -> IO Metadata
 getSymbolicLinkMetadata = Posix.getSymbolicLinkStatus . getOsString
 
+getFileRefMetadata :: FileRef -> IO Metadata
+getFileRefMetadata = Posix.getFdStatus
+
 getFileMetadata :: OsPath -> IO Metadata
 getFileMetadata = Posix.getFileStatus . getOsString
 
@@ -197,6 +298,20 @@ 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 -> CMode -> CInt -> IO CInt
+
+setFileModeAtNoFollow :: Maybe FileRef -> OsPath -> CMode -> IO ()
+setFileModeAtNoFollow dirRef (OsString path) mode = do
+  Posix.withFilePath path $ \ pPath ->
+    Posix.throwErrnoPathIfMinus1_ "fchmodat" path
+      (c_fchmodat (fromMaybe c_AT_FDCWD dirRef) pPath mode c_AT_SYMLINK_NOFOLLOW)
+
+forceRemovable :: Maybe FileRef -> OsPath -> Stat -> IO ()
+forceRemovable dirRef path stat = do
+  let mode = st_mode stat .|. Posix.ownerModes
+  setFileModeAtNoFollow dirRef path mode
+
 setFileMode :: OsPath -> Mode -> IO ()
 setFileMode = Posix.setFileMode . getOsString
 

System/Directory/Internal/Prelude.hs

@@ -96,6 +96,8 @@ import Foreign.C
   , CUShort(..)
   , CWString
   , CWchar(..)
+  , eLOOP
+  , getErrno
   , throwErrnoIfMinus1Retry_
   , throwErrnoIfMinus1_
   , throwErrnoIfNull
@@ -145,5 +147,5 @@ import System.IO.Error
   , tryIOError
   , userError
   )
-import System.Posix.Types (EpochTime)
+import System.Posix.Types (CMode, EpochTime)
 import System.Timeout (timeout)

System/Directory/OsPath.hs

@@ -460,33 +460,43 @@ 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
+    ignoreDoesNotExistError (removeForcibly Nothing path)
+
   where
 
+    removeForcibly :: Maybe FileRef -> OsPath -> IO ()
+    removeForcibly dirRef name = do
+      stat <- statAtNoFollow dirRef name
+      if not (statIsDirectory stat)
+        then do
+          unless filesAlwaysRemovable (tryForceRemovable dirRef name stat)
+          removePathAt File dirRef name
+        else do
+          tryForceRemovable dirRef name stat
+          withNoFollowRef dirRef name $ \ noFollowRef -> do
+            case noFollowRef of
+              NoFollowLink -> removePathAt File dirRef name
+              NoFollowRef rFile -> do
+                mFile <- getFileRefMetadata rFile
+                case fileTypeFromMetadata mFile of
+                  DirectoryLink -> removePathAt Directory dirRef name
+                  Directory -> do
+                    names <-
+                      -- This filter is very important! Otherwise it will
+                      -- recurse into the parent directory and do bad things.
+                      filter (not . isSpecialDir) <$>
+                        getDirectoryContentsAt rFile
+                    sequenceWithIOErrors_ $
+                      (removeForcibly (Just rFile) <$> names) <>
+                      [removePathAt Directory dirRef name]
+                  _ -> removePathAt File dirRef name
+
     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 }
+    tryForceRemovable :: Maybe FileRef -> OsPath -> Stat -> IO ()
+    tryForceRemovable r p s = forceRemovable r p s `catchIOError` \ _ -> pure ()
 
 {- |'removeFile' /file/ removes the directory entry for an existing file
 /file/, where /file/ is not itself a directory. The
@@ -1100,6 +1110,15 @@ findFilesWithLazy f dirs path
 exeExtension :: OsString
 exeExtension = exeExtensionInternal
 
+curDir :: OsPath
+curDir = os "."
+
+parDir :: OsPath
+parDir = os ".."
+
+isSpecialDir :: OsPath -> Bool
+isSpecialDir = (`elem` [curDir, parDir])
+
 -- | Similar to 'listDirectory', but always includes the special entries (@.@
 -- and @..@).  (This applies to Windows as well.)
 --
@@ -1140,8 +1159,7 @@ getDirectoryContents path =
 --   @[ENOTDIR]@
 --
 listDirectory :: OsPath -> IO [OsPath]
-listDirectory path = filter f <$> getDirectoryContents path
-  where f filename = filename /= os "." && filename /= os ".."
+listDirectory path = filter (not . isSpecialDir) <$> getDirectoryContents path
 
 -- | Obtain the current working directory as an absolute path.
 --
@@ -1300,6 +1318,8 @@ pathIsDirectory path =
 -- if the user lacks the privileges to create symbolic links.  It may also
 -- fail with 'illegalOperationErrorType' if the file system does not support
 -- symbolic links.
+--
+-- @since 1.3.1.0
 createFileLink
   :: OsPath                           -- ^ path to the target file
   -> OsPath                           -- ^ path of the link to be created