From 85f552f0e51d82c092fcb69f5bddda24ec1799d7 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 | 24 +++++ System/Directory/Internal/Posix.hsc | 123 +++++++++++++++++++--- System/Directory/Internal/Prelude.hs | 6 ++ System/Directory/Internal/Windows.hsc | 9 ++ System/Directory/OsPath.hs | 53 ++++++---- 6 files changed, 183 insertions(+), 38 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..62010c78 100644 --- a/System/Directory/Internal/Common.hs +++ b/System/Directory/Internal/Common.hs @@ -87,6 +87,17 @@ tryIOErrorType check action = do Left err -> if check err then pure (Left err) else throwIO err Right val -> pure (Right val) +-- | Similar to 'try' but only catches a specific kind of errno. Warning: +-- Only checks the errno from the last action that threw an 'IOException'. +tryErrno :: (Errno -> Bool) -> IO a -> IO (Maybe a) +tryErrno check action = do + result <- tryIOError action + case result of + Left err -> do + errno <- getErrno + if check errno then pure Nothing else throwIO err + Right val -> pure (Just val) + -- | Attempt to perform the given action, silencing any IO exception thrown by -- it. ignoreIOExceptions :: IO () -> IO () @@ -126,6 +137,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 +230,15 @@ 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 + +catchELoop :: IO a -> IO (Maybe a) +catchELoop = tryErrno (== eLOOP) + 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..f9a74de2 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,69 @@ 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) = modifyIOError ((`ioeAddLocation` "openRaw") . (`ioeSetOsPath` OsString path)) $ do -- REMOVE THIS + Posix.openFdAt dir path Posix.ReadOnly flags + where + flags = defaultOpenFlags { Posix.nofollow = isNoFollow whetherFollow } + +closeRaw :: RawHandle -> IO () +closeRaw = Posix.closeFd + +openNoFollow :: Maybe RawHandle -> OsPath -> IO (Maybe RawHandle) +openNoFollow dir path = + tryErrno (== eLOOP) (openRaw NoFollow dir path) + +closeNoFollow :: Maybe RawHandle -> IO () +closeNoFollow = (`for_` closeRaw) + 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 +158,28 @@ 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 (Maybe [OsPath]) +readDirToEnd fd = + bracket + (tryErrno (== eNOTDIR) (openDirFromFd fd)) + (`for_` Posix.closeDirStream) + (`for` 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 +219,23 @@ 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 + +getMetadata :: RawHandle -> IO Metadata +getMetadata = Posix.getFdStatus + +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 +280,22 @@ 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 + +setModeAt :: WhetherFollow -> Maybe RawHandle -> OsPath -> Posix.FileMode -> 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 + +forceRemovable :: Maybe RawHandle -> OsPath -> Metadata -> IO () +forceRemovable dir path metadata = do + let mode = modeFromMetadata metadata .|. Posix.ownerModes + setModeAt NoFollow dir 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..9b73cd8b 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,10 @@ import Foreign.C , CUShort(..) , CWString , CWchar(..) + , Errno + , eLOOP + , eNOTDIR + , getErrno , throwErrnoIfMinus1Retry_ , throwErrnoIfMinus1_ , throwErrnoIfNull diff --git a/System/Directory/Internal/Windows.hsc b/System/Directory/Internal/Windows.hsc index 6134bd81..f7226223 100644 --- a/System/Directory/Internal/Windows.hsc +++ b/System/Directory/Internal/Windows.hsc @@ -518,6 +518,15 @@ createSymbolicLink isDir target link = (normaliseSeparators target) isDir +type FileRef = OsPath + +data Subref = NotSubdir -- ^ Not a directory (perhaps regular file or symlink). + | SubdirRef FileRef -- ^ Is a subdirectory. + deriving (Show) + +withSubref :: Maybe FileRef -> OsPath -> (Subref -> IO r) -> IO r +withSubref dirRef name action = action (fromMaybe (os ".") dirRef name) + type Metadata = Win32.BY_HANDLE_FILE_INFORMATION getSymbolicLinkMetadata :: OsPath -> IO Metadata diff --git a/System/Directory/OsPath.hs b/System/Directory/OsPath.hs index db216eed..528cc221 100644 --- a/System/Directory/OsPath.hs +++ b/System/Directory/OsPath.hs @@ -441,6 +441,27 @@ removeContentsRecursive path = for_ [path x | x <- cont] removePathRecursive removeDirectory path +type Preremover = Maybe RawHandle -> OsPath -> IO () + +removeRecursivelyAt :: Preremover -> Maybe RawHandle -> OsPath -> IO () +removeRecursivelyAt preremover dir name = do + preremover dir name + -- TODO: What about windows dir links? + bracket (openNoFollow dir name) closeNoFollow $ \ noFollowHandle -> do + case noFollowHandle of + Nothing -> removePathAt File dir name -- symbolic links on POSIX + Just handle -> do + maybeNames <- readDirToEnd handle + case maybeNames of + Nothing -> removePathAt File dir name -- not a directory + Just allNames -> do + -- dropSpecialDotDirs is very crucial! Otherwise it will recurse + -- into the parent directory and do terrible things. + let names = dropSpecialDotDirs allNames + sequenceWithIOErrors_ $ + (removeRecursivelyAt preremover (Just handle) <$> names) <> + [removePathAt Directory dir 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 +482,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 RawHandle -> OsPath -> IO () + makeRemovable dir name = do + metadata <- getMetadataAt NoFollow dir name + when (fileTypeIsDirectory (fileTypeFromMetadata metadata) + || not filesAlwaysRemovable) $ do + forceRemovable dir 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 +1150,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. --