Skip to content

Commit

Permalink
WIP: removePathForcibly
Browse files Browse the repository at this point in the history
OUTSTANDING ISSUES:
- No Windows support
  • Loading branch information
Rufflewind committed Jul 5, 2024
1 parent b9b2cda commit 722a3f6
Show file tree
Hide file tree
Showing 5 changed files with 137 additions and 28 deletions.
6 changes: 2 additions & 4 deletions System/Directory/Internal/C_utimensat.hsc
Original file line number Diff line number Diff line change
Expand Up @@ -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

Expand All @@ -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)

Expand All @@ -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
4 changes: 4 additions & 0 deletions System/Directory/Internal/Common.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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]
Expand Down
101 changes: 99 additions & 2 deletions System/Directory/Internal/Posix.hsc
Original file line number Diff line number Diff line change
@@ -1,9 +1,14 @@
{-# LANGUAGE CApiFFI #-}
module System.Directory.Internal.Posix where
#include <HsDirectoryConfig.h>
#if !defined(mingw32_HOST_OS)
#include <fcntl.h>
#ifdef HAVE_LIMITS_H
# include <limits.h>
#endif
#ifdef HAVE_SYS_STAT_H
# include <sys/stat.h>
#endif
import Prelude ()
import System.Directory.Internal.Prelude
#ifdef HAVE_UTIMENSAT
Expand All @@ -17,16 +22,36 @@ 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

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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -151,8 +180,62 @@ 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 deriving (Show) -- ^ Is a subdirectory.

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

Expand Down Expand Up @@ -197,6 +280,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

Expand Down
5 changes: 5 additions & 0 deletions System/Directory/Internal/Prelude.hs
Original file line number Diff line number Diff line change
Expand Up @@ -80,11 +80,13 @@ import Foreign
, allocaArray
, allocaBytes
, allocaBytesAligned
, mallocForeignPtrBytes
, maybeWith
, nullPtr
, plusPtr
, with
, withArray
, withForeignPtr
)
import Foreign.C
( CInt(..)
Expand All @@ -96,6 +98,9 @@ import Foreign.C
, CUShort(..)
, CWString
, CWchar(..)
, eLOOP
, eNOTDIR
, getErrno
, throwErrnoIfMinus1Retry_
, throwErrnoIfMinus1_
, throwErrnoIfNull
Expand Down
49 changes: 27 additions & 22 deletions System/Directory/OsPath.hs
Original file line number Diff line number Diff line change
Expand Up @@ -441,6 +441,23 @@ removeContentsRecursive path =
for_ [path </> x | x <- cont] removePathRecursive
removeDirectory path

type Preremover = Maybe FileRef -> OsPath -> IO ()

removeRecursiveAt :: Preremover -> Maybe FileRef -> OsPath -> IO ()
removeRecursiveAt 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_ $
(removeRecursiveAt 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.
Expand All @@ -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
removeRecursiveAt 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
Expand Down Expand Up @@ -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.
--
Expand Down

0 comments on commit 722a3f6

Please sign in to comment.