From 2ddc490739843d96924dd8e20245e19e815c3379 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 | 10 ++ System/Directory/Internal/Posix.hsc | 108 +++++++++++++++++++--- System/Directory/Internal/Prelude.hs | 4 +- System/Directory/Internal/Windows.hsc | 28 ++++++ System/Directory/OsPath.hs | 98 +++++++++----------- 6 files changed, 184 insertions(+), 70 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..af3373cf 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] @@ -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 diff --git a/System/Directory/Internal/Posix.hsc b/System/Directory/Internal/Posix.hsc index 0e4f11c7..374fa6f4 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,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,20 @@ setWriteMode :: Bool -> Mode -> Mode setWriteMode False m = m .&. complement allWriteMode setWriteMode True m = m .|. allWriteMode +setForceRemoveMode :: Mode -> Mode +setForceRemoveMode m = m .|. Posix.ownerModes + +foreign import capi "sys/stat.h fchmodat" c_fchmodat + :: Posix.Fd -> CString -> Posix.FileMode -> CInt -> IO CInt + +setModeAt :: WhetherFollow -> Maybe RawHandle -> OsPath -> Mode -> 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 + setFileMode :: OsPath -> Mode -> IO () setFileMode = Posix.setFileMode . getOsString diff --git a/System/Directory/Internal/Prelude.hs b/System/Directory/Internal/Prelude.hs index 37f6b8ba..29c57075 100644 --- a/System/Directory/Internal/Prelude.hs +++ b/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(..) diff --git a/System/Directory/Internal/Windows.hsc b/System/Directory/Internal/Windows.hsc index 6134bd81..925127ff 100644 --- a/System/Directory/Internal/Windows.hsc +++ b/System/Directory/Internal/Windows.hsc @@ -42,12 +42,27 @@ import qualified System.Win32.WindowsString.Shell as Win32 import qualified System.Win32.WindowsString.Time as Win32 import qualified System.Win32.WindowsString.Types as Win32 +type RawHandle = OsPath + +pathAt :: Maybe RawHandle -> OsPath -> OsPath +pathAt dir path = fromMaybe mempty dir path + +openNoFollow :: Maybe RawHandle -> OsPath -> IO RawHandle +openNoFollow dir path = pure (pathAt dir path) + +closeRaw :: RawHandle -> IO () +closeRaw = pure () + createDirectoryInternal :: OsPath -> IO () createDirectoryInternal path = (`ioeSetOsPath` path) `modifyIOError` do path' <- furnishPath path Win32.createDirectory path' Nothing +removePathAt :: FileType -> Maybe RawHandle -> OsPath -> IO () +removePathAt ty dir path = removePathInternal isDir (pathAt dir path) + where isDir = fileTypeIsDirectory ty + removePathInternal :: Bool -> OsPath -> IO () removePathInternal isDir path = (`ioeSetOsPath` path) `modifyIOError` do @@ -406,6 +421,9 @@ findExecutablesLazyInternal _ = maybeToListT . searchPathEnvForExes exeExtensionInternal :: OsString exeExtensionInternal = exeExtension +readDirToEnd :: RawHandle -> IO [OsPath] +readDirToEnd = getDirectoryContentsInternal + getDirectoryContentsInternal :: OsPath -> IO [OsPath] getDirectoryContentsInternal path = do query <- furnishPath (path os "*") @@ -520,6 +538,10 @@ createSymbolicLink isDir target link = type Metadata = Win32.BY_HANDLE_FILE_INFORMATION +getMetadataAt :: WhetherFollow -> Maybe RawHandle -> OsPath -> IO Metadata +getMetadataAt NoFollow dir path = getSymbolicLinkMetadata (pathAt dir path) +getMetadataAt FollowLinks dir path = getFileMetadata (pathAt dir path) + getSymbolicLinkMetadata :: OsPath -> IO Metadata getSymbolicLinkMetadata path = (`ioeSetOsPath` path) `modifyIOError` do @@ -603,6 +625,12 @@ setWriteMode :: Bool -> Mode -> Mode setWriteMode False m = m .|. Win32.fILE_ATTRIBUTE_READONLY setWriteMode True m = m .&. complement Win32.fILE_ATTRIBUTE_READONLY +setForceRemoveMode :: Mode -> Mode +setForceRemoveMode m = m .&. complement Win32.fILE_ATTRIBUTE_READONLY + +setModeAt :: WhetherFollow -> Maybe RawHandle -> OsPath -> Mode -> IO () +setModeAt _ dir path = setFileMode (pathAt dir path) + setFileMode :: OsPath -> Mode -> IO () setFileMode path mode = (`ioeSetOsPath` path) `modifyIOError` do diff --git a/System/Directory/OsPath.hs b/System/Directory/OsPath.hs index db216eed..dce71b56 100644 --- a/System/Directory/OsPath.hs +++ b/System/Directory/OsPath.hs @@ -392,6 +392,42 @@ 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 :: Preremover +forcePreremover dir path metadata = do + when (fileTypeIsDirectory (fileTypeFromMetadata metadata) + || not filesAlwaysRemovable) $ do + setModeAt NoFollow dir path mode + `catchIOError` \ _ -> pure () + where + mode = setForceRemoveMode (modeFromMetadata metadata) + +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 +442,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 +468,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 +1133,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. --