From 40df015264c73b051d4c6cea3266490d9c0792cb Mon Sep 17 00:00:00 2001 From: Phil Ruffwind Date: Mon, 19 Sep 2022 01:32:21 -0700 Subject: [PATCH] WIP: removePathForcibly OUTSTANDING ISSUES: - No Windows support --- System/Directory/Internal/C_utimensat.hsc | 6 +- System/Directory/Internal/Common.hs | 4 + System/Directory/Internal/Posix.hsc | 102 +++++++++++++++++++++- System/Directory/Internal/Prelude.hs | 5 ++ System/Directory/OsPath.hs | 49 ++++++----- 5 files changed, 138 insertions(+), 28 deletions(-) diff --git a/System/Directory/Internal/C_utimensat.hsc b/System/Directory/Internal/C_utimensat.hsc index cf2aeb34..6841ddbb 100644 --- a/System/Directory/Internal/C_utimensat.hsc +++ b/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 diff --git a/System/Directory/Internal/Common.hs b/System/Directory/Internal/Common.hs index 86b95a9e..b2a8c759 100644 --- a/System/Directory/Internal/Common.hs +++ b/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] diff --git a/System/Directory/Internal/Posix.hsc b/System/Directory/Internal/Posix.hsc index 0e4f11c7..cd797b8e 100644 --- a/System/Directory/Internal/Posix.hsc +++ b/System/Directory/Internal/Posix.hsc @@ -1,9 +1,14 @@ +{-# LANGUAGE CApiFFI #-} module System.Directory.Internal.Posix where #include #if !defined(mingw32_HOST_OS) +#include #ifdef HAVE_LIMITS_H # include #endif +#ifdef HAVE_SYS_STAT_H +# include +#endif import Prelude () import System.Directory.Internal.Prelude #ifdef HAVE_UTIMENSAT @@ -17,9 +22,13 @@ 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 @@ -27,6 +36,22 @@ 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) + +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 +126,13 @@ exeExtensionInternal :: OsString exeExtensionInternal = exeExtension getDirectoryContentsInternal :: OsPath -> IO [OsPath] -getDirectoryContentsInternal (OsString path) = +getDirectoryContentsInternal path = + withFileRef Nothing path getDirectoryRefContents + +getDirectoryRefContents :: FileRef -> IO [OsPath] +getDirectoryRefContents fileRef = bracket - (Posix.openDirStream path) + (Posix.unsafeOpenDirStreamFd =<< Posix.dup fileRef) Posix.closeDirStream start where @@ -151,8 +180,63 @@ 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 name) = + bracket + (Posix.openFdAt dirRef name Posix.ReadOnly defaultFlags) + Posix.closeFd + +data Subref = NotSubdir -- ^ Not a directory (perhaps regular file or symlink). + | SubdirRef FileRef -- ^ Is a subdirectory. + deriving (Show) + +openSubref :: Maybe FileRef -> OsPath -> IO Subref +openSubref dirRef (OsString name) = do + let flags = defaultFlags { Posix.nofollow = True, Posix.directory = True } + result <- tryIOError (Posix.openFdAt dirRef name Posix.ReadOnly flags) + case result of + Left err -> do + errno <- getErrno + if errno == eLOOP || errno == eNOTDIR + then pure NotSubdir + else throwIO err + Right ref -> pure (SubdirRef ref) + +closeSubref :: Subref -> IO () +closeSubref NotSubdir = pure () +closeSubref (SubdirRef ref) = Posix.closeFd ref + +withSubref :: Maybe FileRef -> OsPath -> (Subref -> IO r) -> IO r +withSubref dirRef name action = + bracket (openSubref dirRef name) closeSubref action + type Metadata = Posix.FileStatus +foreign import capi "sys/stat.h fstatat" c_fstatat + :: Posix.Fd -> CString -> Ptr Posix.CStat -> CInt -> IO CInt + +c_AT_SYMLINK_NOFOLLOW :: CInt +c_AT_SYMLINK_NOFOLLOW = (#const AT_SYMLINK_NOFOLLOW) + +getSymbolicLinkMetadataAt :: Maybe FileRef -> OsPath -> IO Metadata +getSymbolicLinkMetadataAt dirRef (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 dirRef) pPath pStat c_AT_SYMLINK_NOFOLLOW + pure (Posix.FileStatus stat) + getSymbolicLinkMetadata :: OsPath -> IO Metadata getSymbolicLinkMetadata = Posix.getSymbolicLinkStatus . getOsString @@ -197,6 +281,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 -> Posix.FileMode -> CInt -> IO CInt + +setSymbolicLinkModeAt :: Maybe FileRef -> OsPath -> Posix.FileMode -> IO () +setSymbolicLinkModeAt 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 -> Metadata -> IO () +forceRemovable dirRef path metadata = do + let mode = modeFromMetadata metadata .|. Posix.ownerModes + setSymbolicLinkModeAt 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 37f6b8ba..6cac7827 100644 --- a/System/Directory/Internal/Prelude.hs +++ b/System/Directory/Internal/Prelude.hs @@ -80,11 +80,13 @@ import Foreign , allocaArray , allocaBytes , allocaBytesAligned + , mallocForeignPtrBytes , maybeWith , nullPtr , plusPtr , with , withArray + , withForeignPtr ) import Foreign.C ( CInt(..) @@ -96,6 +98,9 @@ import Foreign.C , CUShort(..) , CWString , CWchar(..) + , eLOOP + , eNOTDIR + , getErrno , throwErrnoIfMinus1Retry_ , throwErrnoIfMinus1_ , throwErrnoIfNull diff --git a/System/Directory/OsPath.hs b/System/Directory/OsPath.hs index db216eed..c3a20cdb 100644 --- a/System/Directory/OsPath.hs +++ b/System/Directory/OsPath.hs @@ -441,6 +441,23 @@ removeContentsRecursive path = for_ [path x | x <- cont] removePathRecursive removeDirectory path +type Preremover = Maybe FileRef -> OsPath -> IO () + +removeRecursivelyAt :: Preremover -> Maybe FileRef -> OsPath -> IO () +removeRecursivelyAt preremover dirRef name = do + preremover dirRef name + withSubref dirRef name $ \ subref -> do + case subref of + NotSubdir -> do + removePathAt File dirRef name -- TODO: What about windows dir links? + SubdirRef subdirRef -> do + -- dropSpecialDotDirs is very crucial! Otherwise it will recurse + -- into the parent directory and do terrible things. + names <- dropSpecialDotDirs <$> getDirectoryRefContents subdirRef + sequenceWithIOErrors_ $ + (removeRecursivelyAt preremover (Just subdirRef) <$> names) <> + [removePathAt Directory dirRef name] + -- | 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. @@ -461,32 +478,21 @@ 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 makeRemovable 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 } + makeRemovable :: Maybe FileRef -> OsPath -> IO () + makeRemovable dirRef name = do + metadata <- getSymbolicLinkMetadataAt dirRef name + when (fileTypeIsDirectory (fileTypeFromMetadata metadata) + || not filesAlwaysRemovable) $ do + forceRemovable dirRef name metadata + `catchIOError` \ _ -> pure () {- |'removeFile' /file/ removes the directory entry for an existing file /file/, where /file/ is not itself a directory. The @@ -1140,8 +1146,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. --