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..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..ebf74dce 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,11 @@ 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 +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 +34,54 @@ 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) + +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 @@ -101,9 +156,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 +210,53 @@ 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 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 (OsString path) = do + 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 +298,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 -> 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 37f6b8ba..827324ec 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 @@ -145,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 db216eed..b4931754 100644 --- a/System/Directory/OsPath.hs +++ b/System/Directory/OsPath.hs @@ -460,33 +460,43 @@ 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 + ignoreDoesNotExistError (removeForcibly Nothing path) + where + removeForcibly :: Maybe FileRef -> OsPath -> IO () + removeForcibly dirRef name = do + 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 - makeRemovable :: OsPath -> IO () - makeRemovable p = (`catchIOError` \ _ -> pure ()) $ do - perms <- getPermissions p - setPermissions path perms{ readable = True - , searchable = True - , writable = True } + 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 @@ -1100,6 +1110,15 @@ findFilesWithLazy f dirs path 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.) -- @@ -1140,8 +1159,7 @@ getDirectoryContents path = -- @[ENOTDIR]@ -- 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. -- @@ -1300,6 +1318,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