From 52cc39866c8b535f07a2620211956b7ddb2c2e93 Mon Sep 17 00:00:00 2001 From: Phil Ruffwind Date: Sun, 18 Dec 2022 21:45:44 -0800 Subject: [PATCH] WIP --- System/Directory/Internal/C_utimensat.hsc | 3 +- System/Directory/Internal/Posix.hsc | 84 +++++++++++++++++++---- System/Directory/Internal/Prelude.hs | 2 +- System/Directory/OsPath.hs | 51 +++++++------- 4 files changed, 97 insertions(+), 43 deletions(-) diff --git a/System/Directory/Internal/C_utimensat.hsc b/System/Directory/Internal/C_utimensat.hsc index 1ccb52fe..1ae0607b 100644 --- a/System/Directory/Internal/C_utimensat.hsc +++ b/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 diff --git a/System/Directory/Internal/Posix.hsc b/System/Directory/Internal/Posix.hsc index 3fdf551c..ebf74dce 100644 --- a/System/Directory/Internal/Posix.hsc +++ b/System/Directory/Internal/Posix.hsc @@ -1,3 +1,4 @@ +{-# LANGUAGE CApiFFI #-} module System.Directory.Internal.Posix where #include #if !defined(mingw32_HOST_OS) @@ -5,6 +6,9 @@ module System.Directory.Internal.Posix where #ifdef HAVE_LIMITS_H # include #endif +#ifdef HAVE_SYS_STAT_H +# include +#endif import Prelude () import System.Directory.Internal.Prelude #ifdef HAVE_UTIMENSAT @@ -22,6 +26,7 @@ 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 @@ -29,22 +34,54 @@ 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 diff --git a/System/Directory/Internal/Prelude.hs b/System/Directory/Internal/Prelude.hs index a420a349..827324ec 100644 --- a/System/Directory/Internal/Prelude.hs +++ b/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) diff --git a/System/Directory/OsPath.hs b/System/Directory/OsPath.hs index 4bb7dc7c..e2274b33 100644 --- a/System/Directory/OsPath.hs +++ b/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