WIP

System/Directory/Internal/C_utimensat.hsc

@@ -22,8 +22,7 @@ data CTimeSpec = CTimeSpec EpochTime CLong
 
 instance Storable CTimeSpec where
     sizeOf    _ = #{size struct timespec}
-    -- workaround (hsc2hs for GHC < 8.0 doesn't support #{alignment ...})
-    alignment _ = #{size char[alignof(struct timespec)] }
+    alignment _ = #{alignment struct timespec}
     poke p (CTimeSpec sec nsec) = do
       (#poke struct timespec, tv_sec)  p sec
       (#poke struct timespec, tv_nsec) p nsec

System/Directory/Internal/Posix.hsc

@@ -1,10 +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
@@ -22,29 +26,62 @@ 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
 
-removePathAt :: FileType -> Maybe FileRef -> OsPath -> IO ()
-removePathAt fType maybeRef (OsString path) =
-  Posix.withFilePath path $ \ pPath -> do
-    print ("c_unlinkat", (fromMaybe c_AT_FDCWD maybeRef) ,path, flag)
-    (() <$) .  Posix.throwErrnoPathIfMinus1 "unlinkat" path $
-      c_unlinkat (fromMaybe c_AT_FDCWD maybeRef) pPath flag
-  where
-    flag | fileTypeIsDirectory fType = (#const AT_REMOVEDIR)
-         | otherwise                 = 0
-
 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
@@ -173,6 +210,14 @@ 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
@@ -189,8 +234,7 @@ withNoFollowRef dirRef path action =
   bracket (openNoFollowRef dirRef path) closeNoFollowRef action
 
 openNoFollowRef :: Maybe FileRef -> OsPath -> IO NoFollowRef
-openNoFollowRef dirRef osPath@(OsString path) =
-  (`ioeSetOsPath` osPath) `modifyIOError` do -- TEMPORARY
+openNoFollowRef dirRef (OsString path) = do
   let flags = defaultFlags { Posix.nofollow = True }
   result <- tryIOError (Posix.openFdAt dirRef path Posix.ReadOnly flags)
   case result of
@@ -254,9 +298,19 @@ setWriteMode :: Bool -> Mode -> Mode
 setWriteMode False m = m .&. complement allWriteMode
 setWriteMode True  m = m .|. allWriteMode
 
-forceRemovable :: FileRef -> Metadata -> IO ()
-forceRemovable fileRef status =
-  Posix.setFdMode fileRef (Posix.fileMode status .|. Posix.ownerModes)
+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

@@ -147,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

@@ -469,36 +469,37 @@ removePathForcibly path =
     removeForcibly :: Maybe FileRef -> OsPath -> IO ()
     removeForcibly dirRef name = do
       print ("withFileRefAt", dirRef, name)
-      withNoFollowRef dirRef name $ \ noFollowRef -> do
-        print ("withFileRefAt RECEIVED ", noFollowRef, dirRef, name)
-        case noFollowRef of
-          NoFollowLink -> removePathAt File dirRef name
-          NoFollowRef rFile -> do
-            mFile <- getFileRefMetadata rFile
-            case fileTypeFromMetadata mFile of
-              DirectoryLink -> do
-                tryForceRemovable rFile mFile
-                removePathAt Directory dirRef name
-              Directory -> do
-                tryForceRemovable rFile mFile
-                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]
-              _ -> do
-                unless filesAlwaysRemovable (tryForceRemovable rFile mFile)
-                removePathAt File dirRef name
+      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
 
-    tryForceRemovable :: FileRef -> Metadata -> IO ()
-    tryForceRemovable r m = forceRemovable r m `catchIOError` \ _ -> pure ()
+    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