From f95edb6952065ad703aaa18d7da017d2e5f2f2e9 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: - forceRemovable doesn't work when r bit is unset, since it happens AFTER openat - Can we use fstatat? - No Windows support --- System/Directory/Internal/C_utimensat.hsc | 6 +- System/Directory/Internal/Common.hs | 4 + System/Directory/Internal/Posix.hsc | 65 ++++++++++++- System/Directory/Internal/Prelude.hs | 2 + System/Directory/OsPath.hs | 110 +++++++++++++++++----- lint.py | 31 ++++++ 6 files changed, 189 insertions(+), 29 deletions(-) create mode 100644 lint.py diff --git a/System/Directory/Internal/C_utimensat.hsc b/System/Directory/Internal/C_utimensat.hsc index 3d9b1942..1ccb52fe 100644 --- a/System/Directory/Internal/C_utimensat.hsc +++ b/System/Directory/Internal/C_utimensat.hsc @@ -16,6 +16,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 @@ -31,9 +32,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) @@ -44,6 +42,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..31e469c9 100644 --- a/System/Directory/Internal/Common.hs +++ b/System/Directory/Internal/Common.hs @@ -215,6 +215,10 @@ simplifyWindows path subpathIsAbsolute = any isPathSeparator (take 1 (unpack subpath)) hasTrailingPathSep = hasTrailingPathSeparator subpath +-- | Whether to follow symbolic links when opening files. +data FollowMode = FollowLinks | NoFollow + deriving (Bounded, Enum, Eq, Ord, Read, Show) + 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..3fdf551c 100644 --- a/System/Directory/Internal/Posix.hsc +++ b/System/Directory/Internal/Posix.hsc @@ -1,6 +1,7 @@ module System.Directory.Internal.Posix where #include #if !defined(mingw32_HOST_OS) +#include #ifdef HAVE_LIMITS_H # include #endif @@ -17,6 +18,7 @@ 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.PosixString as Posix @@ -27,6 +29,22 @@ 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) + +foreign import ccall "unistd.h unlinkat" c_unlinkat + :: Posix.Fd -> CString -> CInt -> IO CInt + removePathInternal :: Bool -> OsPath -> IO () removePathInternal True = Posix.removeDirectory . getOsString removePathInternal False = Posix.removeLink . getOsString @@ -101,9 +119,13 @@ exeExtensionInternal :: OsString exeExtensionInternal = exeExtension getDirectoryContentsInternal :: OsPath -> IO [OsPath] -getDirectoryContentsInternal (OsString path) = +getDirectoryContentsInternal path = + withFileRef Nothing path getDirectoryContentsAt + +getDirectoryContentsAt :: FileRef -> IO [OsPath] +getDirectoryContentsAt fileRef = bracket - (Posix.openDirStream path) + (Posix.unsafeOpenDirStreamFd =<< Posix.dup fileRef) Posix.closeDirStream start where @@ -151,11 +173,46 @@ createSymbolicLink _ (OsString p1) (OsString p2) = readSymbolicLink :: OsPath -> IO OsPath readSymbolicLink = (OsString <$>) . Posix.readSymbolicLink . getOsString +type FileRef = Posix.Fd + +withFileRef :: Maybe FileRef -> OsPath -> (FileRef -> IO r) -> IO r +withFileRef dirRef (OsString path) = + bracket + (Posix.openFdAt dirRef path Posix.ReadOnly defaultFlags) + Posix.closeFd + +data NoFollowRef = NoFollowLink | NoFollowRef FileRef deriving (Show) + +withNoFollowRef :: Maybe FileRef -> OsPath -> (NoFollowRef -> IO r) -> IO r +withNoFollowRef dirRef path action = + (`ioeAddLocation` show (dirRef, path)) `modifyIOError` -- TEMPORARY + bracket (openNoFollowRef dirRef path) closeNoFollowRef action + +openNoFollowRef :: Maybe FileRef -> OsPath -> IO NoFollowRef +openNoFollowRef dirRef osPath@(OsString path) = + (`ioeSetOsPath` osPath) `modifyIOError` do -- TEMPORARY + let flags = defaultFlags { Posix.nofollow = True } + result <- tryIOError (Posix.openFdAt dirRef path Posix.ReadOnly flags) + case result of + Left err -> do + errno <- getErrno + if errno == eLOOP + then pure NoFollowLink + else throwIO err + Right val -> pure (NoFollowRef val) + +closeNoFollowRef :: NoFollowRef -> IO () +closeNoFollowRef NoFollowLink = pure () +closeNoFollowRef (NoFollowRef fd) = Posix.closeFd fd + type Metadata = Posix.FileStatus getSymbolicLinkMetadata :: OsPath -> IO Metadata getSymbolicLinkMetadata = Posix.getSymbolicLinkStatus . getOsString +getFileRefMetadata :: FileRef -> IO Metadata +getFileRefMetadata = Posix.getFdStatus + getFileMetadata :: OsPath -> IO Metadata getFileMetadata = Posix.getFileStatus . getOsString @@ -197,6 +254,10 @@ 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) + setFileMode :: OsPath -> Mode -> IO () setFileMode = Posix.setFileMode . getOsString diff --git a/System/Directory/Internal/Prelude.hs b/System/Directory/Internal/Prelude.hs index 37f6b8ba..a420a349 100644 --- a/System/Directory/Internal/Prelude.hs +++ b/System/Directory/Internal/Prelude.hs @@ -96,6 +96,8 @@ import Foreign.C , CUShort(..) , CWString , CWchar(..) + , eLOOP + , getErrno , throwErrnoIfMinus1Retry_ , throwErrnoIfMinus1_ , throwErrnoIfNull diff --git a/System/Directory/OsPath.hs b/System/Directory/OsPath.hs index db216eed..4bb7dc7c 100644 --- a/System/Directory/OsPath.hs +++ b/System/Directory/OsPath.hs @@ -457,36 +457,48 @@ removeContentsRecursive path = -- If an exception occurs while removing an entry, @removePathForcibly@ will -- still try to remove as many entries as it can before failing with an -- exception. The first exception that it encountered is re-thrown. +-- +-- @since 1.2.7.0 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 + ignoreDoesNotExistError (removeForcibly Nothing path) + where + 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 + 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 } + tryForceRemovable :: FileRef -> Metadata -> IO () + tryForceRemovable r m = forceRemovable r m `catchIOError` \ _ -> pure () {- |'removeFile' /file/ removes the directory entry for an existing file /file/, where /file/ is not itself a directory. The @@ -703,6 +715,8 @@ renameFile opath npath = -- Either the destination path refers to an existing directory, or one of the -- parent segments in the destination path is not a directory. -- @[ENOTDIR, EISDIR, EINVAL, EEXIST, ENOTEMPTY]@ +-- +-- @since 1.2.7.0 renamePath :: OsPath -- ^ Old path -> OsPath -- ^ New path -> IO () @@ -787,6 +801,8 @@ withReplacementFile path postAction action = -- the very act of copying can change the access time of the source file, -- hence the access times of the two files may differ after the operation -- completes. +-- +-- @since 1.2.6.0 copyFileWithMetadata :: OsPath -- ^ Source file -> OsPath -- ^ Destination file -> IO () @@ -944,6 +960,8 @@ canonicalizePath = \ path -> -- If the path is already absolute, the operation never fails. Otherwise, the -- operation may fail with the same exceptions as 'getCurrentDirectory'. -- +-- @since 1.2.2.0 +-- makeAbsolute :: OsPath -> IO OsPath makeAbsolute path = ((`ioeAddLocation` "makeAbsolute") . @@ -1005,6 +1023,8 @@ findExecutable binary = -- 'findExecutablesInDirectories' using the search directories from the @PATH@ -- environment variable. Details can be found in the documentation of -- 'findExecutablesInDirectories'. +-- +-- @since 1.2.2.0 findExecutables :: OsString -> IO [OsPath] findExecutables binary = listTToList @@ -1021,6 +1041,8 @@ findExecutables binary = -- Unlike other similarly named functions, 'findExecutablesInDirectories' does -- not use @SearchPath@ from the Win32 API. The behavior of this function on -- Windows is therefore equivalent to those on non-Windows platforms. +-- +-- @since 1.2.4.0 findExecutablesInDirectories :: [OsPath] -> OsString -> IO [OsPath] findExecutablesInDirectories path binary = listTToList (findExecutablesInDirectoriesLazy path binary) @@ -1045,6 +1067,8 @@ findFile = findFileWith (\ _ -> pure True) -- -- The behavior is equivalent to 'findFilesWith'. Details can be found in the -- documentation of 'findFilesWith'. +-- +-- @since 1.2.1.0 findFiles :: [OsPath] -> OsString -> IO [OsPath] findFiles = findFilesWith (\ _ -> pure True) @@ -1055,6 +1079,8 @@ findFiles = findFilesWith (\ _ -> pure True) -- This is essentially a more performant version of 'findFilesWith' that -- always returns the first result, if any. Details can be found in the -- documentation of 'findFilesWith'. +-- +-- @since 1.2.6.0 findFileWith :: (OsPath -> IO Bool) -> [OsPath] -> OsString -> IO (Maybe OsPath) findFileWith f ds name = listTHead (findFilesWithLazy f ds name) @@ -1074,6 +1100,8 @@ findFileWith f ds name = listTHead (findFilesWithLazy f ds name) -- If the @name@ is an absolute path, then the function will return a single -- result if the file exists and satisfies the predicate and no results -- otherwise. This is irrespective of what search directories were given. +-- +-- @since 1.2.1.0 findFilesWith :: (OsPath -> IO Bool) -> [OsPath] -> OsString -> IO [OsPath] findFilesWith f ds name = listTToList (findFilesWithLazy f ds name) @@ -1097,9 +1125,20 @@ findFilesWithLazy f dirs path -- | Filename extension for executable files (including the dot if any) -- (usually @\"\"@ on POSIX systems and @\".exe\"@ on Windows or OS\/2). +-- +-- @since 1.2.4.0 exeExtension :: OsString exeExtension = exeExtensionInternal +curDir :: OsPath +curDir = os "." + +parDir :: OsPath +parDir = os ".." + +isSpecialDir :: OsPath -> Bool +isSpecialDir = (`elem` [curDir, parDir]) + -- | Similar to 'listDirectory', but always includes the special entries (@.@ -- and @..@). (This applies to Windows as well.) -- @@ -1139,9 +1178,10 @@ getDirectoryContents path = -- The path refers to an existing non-directory object. -- @[ENOTDIR]@ -- +-- @since 1.2.5.0 +-- listDirectory :: OsPath -> IO [OsPath] -listDirectory path = filter f <$> getDirectoryContents path - where f filename = filename /= os "." && filename /= os ".." +listDirectory path = filter (not . isSpecialDir) <$> getDirectoryContents path -- | Obtain the current working directory as an absolute path. -- @@ -1227,6 +1267,8 @@ setCurrentDirectory = setCurrentDirectoryInternal -- The operation may fail with the same exceptions as 'getCurrentDirectory' -- and 'setCurrentDirectory'. -- +-- @since 1.2.3.0 +-- withCurrentDirectory :: OsPath -- ^ Directory to execute in -> IO a -- ^ Action to be executed -> IO a @@ -1236,6 +1278,8 @@ withCurrentDirectory dir action = action -- | Obtain the size of a file in bytes. +-- +-- @since 1.2.7.0 getFileSize :: OsPath -> IO Integer getFileSize path = (`ioeAddLocation` "getFileSize") `modifyIOError` do @@ -1246,6 +1290,8 @@ getFileSize path = -- function may return false even if the file does actually exist. This -- operation traverses symbolic links, so it can return either True or False -- for them. +-- +-- @since 1.2.7.0 doesPathExist :: OsPath -> IO Bool doesPathExist path = do (True <$ getFileMetadata path) @@ -1300,6 +1346,8 @@ pathIsDirectory path = -- if the user lacks the privileges to create symbolic links. It may also -- fail with 'illegalOperationErrorType' if the file system does not support -- symbolic links. +-- +-- @since 1.3.1.0 createFileLink :: OsPath -- ^ path to the target file -> OsPath -- ^ path of the link to be created @@ -1333,6 +1381,8 @@ createFileLink target link = -- if the user lacks the privileges to create symbolic links. It may also -- fail with 'illegalOperationErrorType' if the file system does not support -- symbolic links. +-- +-- @since 1.3.1.0 createDirectoryLink :: OsPath -- ^ path to the target directory -> OsPath -- ^ path of the link to be created @@ -1347,6 +1397,8 @@ createDirectoryLink target link = -- is an alias for 'removeFile'. -- -- See also: 'removeFile', which can remove an existing /file/ symbolic link. +-- +-- @since 1.3.1.0 removeDirectoryLink :: OsPath -> IO () removeDirectoryLink path = (`ioeAddLocation` "removeDirectoryLink") `modifyIOError` do @@ -1366,6 +1418,8 @@ removeDirectoryLink path = -- -- * 'isPermissionError' if the user is not permitted to read the symbolic -- link. +-- +-- @since 1.3.0.0 pathIsSymbolicLink :: OsPath -> IO Bool pathIsSymbolicLink path = ((`ioeAddLocation` "pathIsSymbolicLink") . @@ -1383,6 +1437,8 @@ pathIsSymbolicLink path = -- Windows-specific errors: This operation may fail with -- 'illegalOperationErrorType' if the file system does not support symbolic -- links. +-- +-- @since 1.3.1.0 getSymbolicLinkTarget :: OsPath -> IO OsPath getSymbolicLinkTarget path = (`ioeAddLocation` "getSymbolicLinkTarget") `modifyIOError` do @@ -1401,6 +1457,8 @@ getSymbolicLinkTarget path = -- resolution only if this package is compiled against @unix-2.6.0.0@ or later -- and the underlying filesystem supports them. -- +-- @since 1.2.3.0 +-- getAccessTime :: OsPath -> IO UTCTime getAccessTime path = (`ioeAddLocation` "getAccessTime") `modifyIOError` do @@ -1445,6 +1503,8 @@ getModificationTime path = -- would not be able to set timestamps with sub-second resolution. In this -- case, there would also be loss of precision in the modification time. -- +-- @since 1.2.3.0 +-- setAccessTime :: OsPath -> UTCTime -> IO () setAccessTime path atime = (`ioeAddLocation` "setAccessTime") `modifyIOError` do @@ -1474,6 +1534,8 @@ setAccessTime path atime = -- would not be able to set timestamps with sub-second resolution. In this -- case, there would also be loss of precision in the access time. -- +-- @since 1.2.3.0 +-- setModificationTime :: OsPath -> UTCTime -> IO () setModificationTime path mtime = (`ioeAddLocation` "setModificationTime") `modifyIOError` do @@ -1537,6 +1599,8 @@ getHomeDirectory = -- As of 1.3.5.0, the environment variable is ignored if set to a relative -- path, per revised XDG Base Directory Specification. See -- . +-- +-- @since 1.2.3.0 getXdgDirectory :: XdgDirectory -- ^ which special directory -> OsPath -- ^ a relative path that is appended -- to the path; if empty, the base diff --git a/lint.py b/lint.py new file mode 100644 index 00000000..a93a5f51 --- /dev/null +++ b/lint.py @@ -0,0 +1,31 @@ +#!/usr/bin/env python3 +import glob, pathlib, re, sys + +def error(counter, path, row, message): + sys.stderr.write(f'{path}:{row}: {message}\n') + counter[0] += 1 + +counter = [0] +for path in glob.glob('**', recursive=True): + if not re.fullmatch(r'System/.*\.hsc?', path): + continue + contents = pathlib.Path(path).read_text() + + for i, line in enumerate(contents.splitlines()): + if len(line) > 80: + error(counter, path, i+1, f'line over 80 chars') + + contents = re.sub(r'--.*', '', contents) + for m in re.finditer(r'(?s)\b(os|so)\b\s*(\S*)', contents): + func, next_token = m.groups() + if not re.fullmatch(r'|'.join([ + r'".*', + r'=', + r'::', + r'EXE_EXTENSION', + r'.*exeExtension', + ]), next_token): + row = 1 + contents[:m.start()].count('\n') + error(counter, path, row, f'{func} only allowed on literals') +if counter[0]: + sys.exit(f'{counter[0]} error(s)')