Fix TOCTOU issue with recursive removal on POSIX systems

removeDirectoryRecursive and removePathForcibly are supposed to never
traverse symbolic links, which would avoid unintended deletion of files
outside the specified directory tree.

The previous implementation did not "lock onto" the directory while
enumerating its entries, allowing concurrent processes to replace the
directory with a symlink right before or during the enumeration and
tricking the deleter into traversing the symlink (haskell#97).

This commit mitigates the issue on POSIX systems by acquiring file
descriptors to every directory it traverses.

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

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

System/Directory/Internal/Posix.hsc

@@ -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
@@ -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
 

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(..)

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
+
+openRaw :: WhetherFollow -> Maybe RawHandle -> OsPath -> IO RawHandle
+openRaw _ 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