content: {-# LANGUAGE CPP #-}
  {-# LANGUAGE ForeignFunctionInterface #-}
  {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  {-# LANGUAGE LambdaCase #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE ViewPatterns #-}
  module UnliftIO.IO.File.Posix
    ( withBinaryFileDurable
    , withBinaryFileDurableAtomic
    , withBinaryFileAtomic
    , ensureFileDurable
    )
    where
  
  #if __GLASGOW_HASKELL__ < 710
  import Control.Applicative
  #endif
  import Control.Monad (forM_, guard, unless, void, when)
  import Control.Monad.IO.Unlift
  import Data.Bits (Bits, (.|.))
  import Data.ByteString (ByteString)
  import Data.Maybe (fromMaybe)
  import Data.Typeable (cast)
  import Foreign (allocaBytes)
  import Foreign.C (CInt(..), throwErrnoIfMinus1, throwErrnoIfMinus1Retry,
                    throwErrnoIfMinus1Retry_)
  import GHC.IO.Device (IODeviceType(RegularFile))
  import qualified GHC.IO.Device as Device
  import GHC.IO.Exception (IOErrorType(UnsupportedOperation))
  import qualified GHC.IO.FD as FD
  import qualified GHC.IO.Handle.FD as HandleFD
  import qualified GHC.IO.Handle.Types as HandleFD (Handle(..), Handle__(..))
  import System.Directory (removeFile)
  import System.FilePath (takeDirectory, takeFileName)
  import System.IO (Handle, IOMode(..), SeekMode(..), hGetBuf, hPutBuf,
                    openBinaryTempFile)
  import System.IO.Error (ioeGetErrorType, isAlreadyExistsError,
                          isDoesNotExistError)
  import qualified System.Posix.Files as Posix
  import System.Posix.Internals (CFilePath, c_close, c_safe_open, withFilePath)
  import System.Posix.Types (CMode(..), Fd(..), FileMode)
  import UnliftIO.Exception
  import UnliftIO.IO
  import UnliftIO.MVar
  
  -- NOTE: System.Posix.Internal doesn't re-export this constants so we have to
  -- recreate-them here
  
  newtype CFlag =
    CFlag CInt
    deriving (Eq, Show, Bits)
  
  foreign import ccall unsafe "HsBase.h __hscore_o_rdonly" o_RDONLY :: CFlag
  foreign import ccall unsafe "HsBase.h __hscore_o_wronly" o_WRONLY :: CFlag
  foreign import ccall unsafe "HsBase.h __hscore_o_rdwr"   o_RDWR   :: CFlag
  foreign import ccall unsafe "HsBase.h __hscore_o_append" o_APPEND :: CFlag
  foreign import ccall unsafe "HsBase.h __hscore_o_creat"  o_CREAT  :: CFlag
  foreign import ccall unsafe "HsBase.h __hscore_o_noctty" o_NOCTTY :: CFlag
  
  -- After here, we have our own imports
  
  -- On non-Linux operating systems that do not support `O_TMPFILE` the value of
  -- `o_TMPFILE` will be 0, which is then used to fallback onto a different
  -- implementation of temporary files.
  foreign import ccall unsafe "file-posix.c unliftio_o_tmpfile" o_TMPFILE :: CFlag
  
  
  -- | Whenever Operating System does not support @O_TMPFILE@ flag and anonymous
  -- temporary files then `o_TMPFILE` flag will be set to @0@
  o_TMPFILE_not_supported :: CFlag
  o_TMPFILE_not_supported = CFlag 0
  
  newtype CAt = CAt
    { unCAt :: CInt
    } deriving (Eq, Show, Bits)
  
  foreign import ccall unsafe "file-posix.c unliftio_at_fdcwd" at_FDCWD :: CAt
  foreign import ccall unsafe "file-posix.c unliftio_at_symlink_follow" at_SYMLINK_FOLLOW :: CAt
  foreign import ccall unsafe "file-posix.c unliftio_s_irusr" s_IRUSR :: CMode
  foreign import ccall unsafe "file-posix.c unliftio_s_iwusr" s_IWUSR :: CMode
  
  c_open :: CFilePath -> CFlag -> CMode -> IO CInt
  c_open fp (CFlag flags) = c_safe_open fp flags
  
  foreign import ccall safe "fcntl.h openat"
    c_safe_openat :: CInt -> CFilePath -> CInt -> CMode -> IO CInt
  
  c_openat :: DirFd -> CFilePath -> CFlag -> CMode -> IO CInt
  c_openat (DirFd (Fd fd)) fp (CFlag flags) = c_safe_openat fd fp flags
  
  foreign import ccall safe "fcntl.h renameat"
    c_safe_renameat :: CInt -> CFilePath -> CInt -> CFilePath -> IO CInt
  
  c_renameat :: DirFd -> CFilePath -> DirFd -> CFilePath -> IO CInt
  c_renameat (DirFd (Fd fdFrom)) cFpFrom (DirFd (Fd fdTo)) cFpTo =
    c_safe_renameat fdFrom cFpFrom fdTo cFpTo
  
  foreign import ccall safe "unistd.h fsync"
    c_safe_fsync :: CInt -> IO CInt
  
  c_fsync :: Fd -> IO CInt
  c_fsync (Fd fd) = c_safe_fsync fd
  
  foreign import ccall safe "unistd.h linkat"
    c_safe_linkat :: CInt -> CFilePath -> CInt -> CFilePath -> CInt -> IO CInt
  
  c_linkat :: CAt -> CFilePath -> Either DirFd CAt -> CFilePath -> CAt -> IO CInt
  c_linkat cat oldPath eNewDir newPath (CAt flags) =
    c_safe_linkat (unCAt cat) oldPath newDir newPath flags
    where
      unFd (Fd fd) = fd
      newDir = either (unFd . unDirFd) unCAt eNewDir
  
  std_flags, output_flags, read_flags, write_flags, rw_flags,
      append_flags :: CFlag
  std_flags    = o_NOCTTY
  output_flags = std_flags    .|. o_CREAT
  read_flags   = std_flags    .|. o_RDONLY
  write_flags  = output_flags .|. o_WRONLY
  rw_flags     = output_flags .|. o_RDWR
  append_flags = write_flags  .|. o_APPEND
  
  ioModeToFlags :: IOMode -> CFlag
  ioModeToFlags iomode =
    case iomode of
      ReadMode      -> read_flags
      WriteMode     -> write_flags
      ReadWriteMode -> rw_flags
      AppendMode    -> append_flags
  
  newtype DirFd = DirFd
    { unDirFd :: Fd
    }
  
  -- | Returns a low-level file descriptor for a directory path. This function
  -- exists given the fact that 'openFile' does not work with directories.
  --
  -- If you use this function, make sure you are working on a masked state,
  -- otherwise async exceptions may leave file descriptors open.
  openDir :: MonadIO m => FilePath -> m Fd
  openDir fp
    -- TODO: Investigate what is the situation with Windows FS in regards to non_blocking
    -- NOTE: File operations _do not support_ non_blocking on various kernels, more
    -- info can be found here: https://ghc.haskell.org/trac/ghc/ticket/15153
   =
    liftIO $
    withFilePath fp $ \cFp ->
      Fd <$>
      throwErrnoIfMinus1Retry
        "openDir"
        (c_open cFp (ioModeToFlags ReadMode) 0o660)
  
  -- | Closes a 'Fd' that points to a Directory.
  closeDirectory :: MonadIO m => DirFd -> m ()
  closeDirectory (DirFd (Fd dirFd)) =
    liftIO $
    throwErrnoIfMinus1Retry_ "closeDirectory" $ c_close dirFd
  
  -- | Executes the low-level C function fsync on a C file descriptor
  fsyncFileDescriptor
    :: MonadIO m
    => String -- ^ Meta-description for error messages
    -> Fd   -- ^ C File Descriptor
    -> m ()
  fsyncFileDescriptor name fd =
    liftIO $ void $ throwErrnoIfMinus1 ("fsync - " ++ name) $ c_fsync fd
  
  -- | Call @fsync@ on the file handle. Accepts an arbitary string for error reporting.
  fsyncFileHandle :: String -> Handle -> IO ()
  fsyncFileHandle fname hdl = withHandleFd hdl (fsyncFileDescriptor (fname ++ "/File"))
  
  
  -- | Call @fsync@ on the opened directory file descriptor. Accepts an arbitary
  -- string for error reporting.
  fsyncDirectoryFd :: String -> DirFd -> IO ()
  fsyncDirectoryFd fname = fsyncFileDescriptor (fname ++ "/Directory") . unDirFd
  
  
  -- | Opens a file from a directory, using this function in favour of a regular
  -- 'openFile' guarantees that any file modifications are kept in the same
  -- directory where the file was opened. An edge case scenario is a mount
  -- happening in the directory where the file was opened while your program is
  -- running.
  --
  -- If you use this function, make sure you are working on an masked state,
  -- otherwise async exceptions may leave file descriptors open.
  --
  openFileFromDir :: MonadIO m => DirFd -> FilePath -> IOMode -> m Handle
  openFileFromDir dirFd filePath@(takeFileName -> fileName) iomode =
    liftIO $
    withFilePath fileName $ \cFileName ->
      bracketOnError
        (do fileFd <-
              throwErrnoIfMinus1Retry "openFileFromDir" $
              c_openat dirFd cFileName (ioModeToFlags iomode) 0o666
              {- Can open directory with read only -}
            FD.mkFD
              fileFd
              iomode
              Nothing {- no stat -}
              False {- not a socket -}
              False {- non_blocking -}
             `onException`
              c_close fileFd)
        (liftIO . Device.close . fst)
        (\(fD, fd_type)
           -- we want to truncate() if this is an open in WriteMode, but only if the
           -- target is a RegularFile. ftruncate() fails on special files like
           -- /dev/null.
          -> do
           when (iomode == WriteMode && fd_type == RegularFile) $
             Device.setSize fD 0
           HandleFD.mkHandleFromFD fD fd_type filePath iomode False Nothing)
  
  
  -- | Similar to `openFileFromDir`, but will open an anonymous (nameless)
  -- temporary file in the supplied directory
  openAnonymousTempFileFromDir ::
       MonadIO m =>
       Maybe DirFd
       -- ^ If a file descriptor is given for the directory where the target file is/will be
       -- located in, then it will be used for opening an anonymous file. Otherwise
       -- anonymous will be opened unattached to any file path.
       -> FilePath
       -- ^ File path of the target file that we are working on.
       -> IOMode
       -> m Handle
  openAnonymousTempFileFromDir mDirFd filePath iomode =
    liftIO $
    case mDirFd of
      Just dirFd -> withFilePath "." (openAnonymousWith . c_openat dirFd)
      Nothing ->
        withFilePath (takeDirectory filePath) (openAnonymousWith . c_open)
    where
      fdName = "openAnonymousTempFileFromDir - " ++ filePath
      ioModeToTmpFlags :: IOMode -> CFlag
      ioModeToTmpFlags =
        \case
          ReadMode -> o_RDWR -- It is an error to create a O_TMPFILE with O_RDONLY
          ReadWriteMode -> o_RDWR
          _ -> o_WRONLY
      openAnonymousWith fopen =
        bracketOnError
          (do fileFd <-
                throwErrnoIfMinus1Retry "openAnonymousTempFileFromDir" $
                fopen (o_TMPFILE .|. ioModeToTmpFlags iomode) (s_IRUSR .|. s_IWUSR)
              FD.mkFD
                fileFd
                iomode
                Nothing {- no stat -}
                False {- not a socket -}
                False {- non_blocking -}
               `onException`
                c_close fileFd)
          (liftIO . Device.close . fst)
          (\(fD, fd_type) ->
             HandleFD.mkHandleFromFD fD fd_type fdName iomode False Nothing)
  
  
  atomicDurableTempFileRename ::
       DirFd -> Maybe FileMode -> Handle -> Maybe FilePath -> FilePath -> IO ()
  atomicDurableTempFileRename dirFd mFileMode tmpFileHandle mTmpFilePath filePath = do
    fsyncFileHandle "atomicDurableTempFileCreate" tmpFileHandle
    -- at this point we know that the content has been persisted to the storage it
    -- is safe to do the atomic move/replace
    let eTmpFile = maybe (Left tmpFileHandle) Right mTmpFilePath
    atomicTempFileRename (Just dirFd) mFileMode eTmpFile filePath
    -- Important to close the handle, so the we can fsync the directory
    hClose tmpFileHandle
    -- file path is updated, now we can fsync the directory
    fsyncDirectoryFd "atomicDurableTempFileCreate" dirFd
  
  
  -- | There will be an attempt to atomically convert an invisible temporary file
  -- into a target file at the supplied file path. In case when there is already a
  -- file at that file path, a new visible temporary file will be created in the
  -- same folder and then atomically renamed into the target file path, replacing
  -- any existing file. This is necessary since `c_safe_linkat` cannot replace
  -- files atomically and we have to fall back onto `c_safe_renameat`. This should
  -- not be a problem in practice, since lifetime of such visible file is
  -- extremely short and it will be cleaned up regardless of the outcome of the
  -- rename.
  --
  -- It is important to note, that whenever a file descriptor for the containing
  -- directory is supplied, renaming and linking will be done in its context,
  -- thus allowing to do proper fsyncing if durability is necessary.
  --
  -- __NOTE__: this function will work only on Linux.
  --
  atomicTempFileCreate ::
       Maybe DirFd
    -- ^ Possible handle for the directory where the target file is located. Which
    -- means that the file is already in that directory, just without a name. In other
    -- words it was opened before with `openAnonymousTempFileFromDir`
    -> Maybe FileMode
    -- ^ If file permissions are supplied they will be set on the new file prior
    -- to atomic rename.
    -> Handle
    -- ^ Handle to the anonymous temporary file created with `c_openat` and
    -- `o_TMPFILE`
    -> FilePath
    -- ^ File path for the target file.
    -> IO ()
  atomicTempFileCreate mDirFd mFileMode tmpFileHandle filePath =
    withHandleFd tmpFileHandle $ \fd@(Fd cFd) ->
      withFilePath ("/proc/self/fd/" ++ show cFd) $ \cFromFilePath ->
        withFilePath filePathName $ \cToFilePath -> do
          let fileMode = fromMaybe Posix.stdFileMode mFileMode
          -- work around for the glibc bug: https://sourceware.org/bugzilla/show_bug.cgi?id=17523
          Posix.setFdMode fd fileMode
          let safeLink which to =
                throwErrnoIfMinus1Retry_
                  ("atomicFileCreate - c_safe_linkat - " ++ which) $
                -- see `man linkat` and `man openat` for more info
                c_linkat at_FDCWD cFromFilePath cDirFd to at_SYMLINK_FOLLOW
          eExc <-
            tryJust (guard . isAlreadyExistsError) $
            safeLink "anonymous" cToFilePath
          case eExc of
            Right () -> pure ()
            Left () ->
              withBinaryTempFileFor filePath $ \visTmpFileName visTmpFileHandle -> do
                hClose visTmpFileHandle
                removeFile visTmpFileName
                case mDirFd of
                  Nothing -> do
                    withFilePath visTmpFileName (safeLink "visible")
                    Posix.rename visTmpFileName filePath
                  Just dirFd ->
                    withFilePath (takeFileName visTmpFileName) $ \cVisTmpFile -> do
                      safeLink "visible" cVisTmpFile
                      throwErrnoIfMinus1Retry_
                          "atomicFileCreate - c_safe_renameat" $
                        c_renameat dirFd cVisTmpFile dirFd cToFilePath
    where
      (cDirFd, filePathName) =
        case mDirFd of
          Nothing    -> (Right at_FDCWD, filePath)
          Just dirFd -> (Left dirFd, takeFileName filePath)
  
  atomicTempFileRename ::
       Maybe DirFd
       -- ^ Possible handle for the directory where the target file is located.
    -> Maybe FileMode
    -- ^ If file permissions are supplied they will be set on the new file prior
    -- to atomic rename.
    -> Either Handle FilePath
    -- ^ Temporary file. If a handle is supplied, it means it was opened with
    -- @O_TMPFILE@ flag and thus we are on the Linux OS and can safely call
    -- `atomicTempFileCreate`
    -> FilePath
    -- ^ File path for the target file. Whenever `DirFd` is supplied, it must be
    -- the containgin directory fo this file, but that invariant is not enforced
    -- within this function.
    -> IO ()
  atomicTempFileRename mDirFd mFileMode eTmpFile filePath =
    case eTmpFile of
      Left tmpFileHandle ->
        atomicTempFileCreate mDirFd mFileMode tmpFileHandle filePath
      Right tmpFilePath -> do
        forM_ mFileMode $ \fileMode -> Posix.setFileMode tmpFilePath fileMode
        case mDirFd of
          Nothing -> Posix.rename tmpFilePath filePath
          Just dirFd ->
            withFilePath (takeFileName filePath) $ \cToFilePath ->
              withFilePath (takeFileName tmpFilePath) $ \cTmpFilePath ->
                throwErrnoIfMinus1Retry_ "atomicFileCreate - c_safe_renameat" $
                c_renameat dirFd cTmpFilePath dirFd cToFilePath
  
  
  withDirectory :: MonadUnliftIO m => FilePath -> (DirFd -> m a) -> m a
  withDirectory dirPath = bracket (DirFd <$> openDir dirPath) closeDirectory
  
  withFileInDirectory ::
       MonadUnliftIO m => DirFd -> FilePath -> IOMode -> (Handle -> m a) -> m a
  withFileInDirectory dirFd filePath iomode =
    bracket (openFileFromDir dirFd filePath iomode) hClose
  
  
  -- | Create a temporary file for a matching possibly exiting target file that
  -- will be replaced in the future. Temporary file is meant to be renamed
  -- afterwards, thus it is only deleted upon error.
  --
  -- __Important__: Temporary file is not removed and file handle is not closed if
  -- there was no exception thrown by the supplied action.
  withBinaryTempFileFor ::
       MonadUnliftIO m
    => FilePath
    -- ^ "For" file. It may exist or may not.
    -> (FilePath -> Handle -> m a)
    -> m a
  withBinaryTempFileFor filePath action =
    bracketOnError
      (liftIO (openBinaryTempFile dirPath tmpFileName))
      (\(tmpFilePath, tmpFileHandle) ->
          hClose tmpFileHandle >> liftIO (tryIO (removeFile tmpFilePath)))
      (uncurry action)
    where
      dirPath = takeDirectory filePath
      fileName = takeFileName filePath
      tmpFileName = "." ++ fileName ++ ".tmp"
  
  -- | Returns `Nothing` if anonymous temporary file is not supported by the OS or
  -- the underlying file system can't handle that feature.
  withAnonymousBinaryTempFileFor ::
       MonadUnliftIO m
    => Maybe DirFd
    -- ^ It is possible to open the temporary file in the context of a directory,
    -- in such case supply its file descriptor. i.e. @openat@ will be used instead
    -- of @open@
    -> FilePath
    -- ^ "For" file. The file may exist or may not.
    -> IOMode
    -> (Handle -> m a)
    -> m (Maybe a)
  withAnonymousBinaryTempFileFor mDirFd filePath iomode action
    | o_TMPFILE == o_TMPFILE_not_supported = pure Nothing
    | otherwise =
      trySupported $
      bracket (openAnonymousTempFileFromDir mDirFd filePath iomode) hClose action
    where
      trySupported m =
        tryIO m >>= \case
          Right res -> pure $ Just res
          Left exc
            | ioeGetErrorType exc == UnsupportedOperation -> pure Nothing
          Left exc -> throwIO exc
  
  withNonAnonymousBinaryTempFileFor ::
       MonadUnliftIO m
    => Maybe DirFd
    -- ^ It is possible to open the temporary file in the context of a directory,
    -- in such case supply its file descriptor. i.e. @openat@ will be used instead
    -- of @open@
    -> FilePath
    -- ^ "For" file. The file may exist or may not.
    -> IOMode
    -> (FilePath -> Handle -> m a)
    -> m a
  withNonAnonymousBinaryTempFileFor mDirFd filePath iomode action =
    withBinaryTempFileFor filePath $ \tmpFilePath tmpFileHandle -> do
      hClose tmpFileHandle
      case mDirFd of
        Nothing -> withBinaryFile tmpFilePath iomode (action tmpFilePath)
        Just dirFd -> withFileInDirectory dirFd tmpFilePath iomode (action tmpFilePath)
  
  -- | Copy the contents of the file into the handle, but only if that file exists
  -- and either `ReadWriteMode` or `AppendMode` is specified. Returned are the
  -- file permissions of the original file so it can be set later when original
  -- gets overwritten atomically.
  copyFileHandle ::
       MonadUnliftIO f => IOMode -> FilePath -> Handle -> f (Maybe FileMode)
  copyFileHandle iomode fromFilePath toHandle =
    either (const Nothing) Just <$>
    tryJust
      (guard . isDoesNotExistError)
      (do fileStatus <- liftIO $ Posix.getFileStatus fromFilePath
          -- Whenever we are not overwriting an existing file, we also need a
          -- copy of the file's contents
          unless (iomode == WriteMode) $ do
            withBinaryFile fromFilePath ReadMode (`copyHandleData` toHandle)
            unless (iomode == AppendMode) $ hSeek toHandle AbsoluteSeek 0
          -- Get the copy of source file permissions, but only whenever it exists
          pure $ Posix.fileMode fileStatus)
  
  
  -- This is a copy of the internal function from `directory-1.3.3.2`. It became
  -- available only in directory-1.3.3.0 and is still internal, hence the
  -- duplication.
  copyHandleData :: MonadIO m => Handle -> Handle -> m ()
  copyHandleData hFrom hTo = liftIO $ allocaBytes bufferSize go
    where
      bufferSize = 131072 -- 128 KiB, as coreutils `cp` uses as of May 2014 (see ioblksize.h)
      go buffer = do
        count <- hGetBuf hFrom buffer bufferSize
        when (count > 0) $ do
          hPutBuf hTo buffer count
          go buffer
  
  -- | Thread safe access to the file descriptor in the file handle
  withHandleFd :: Handle -> (Fd -> IO a) -> IO a
  withHandleFd h cb =
    case h of
      HandleFD.FileHandle _ mv ->
        withMVar mv $ \HandleFD.Handle__{HandleFD.haDevice = dev} ->
          case cast dev of
            Just fd -> cb $ Fd $ FD.fdFD fd
            Nothing -> error "withHandleFd: not a file handle"
      HandleFD.DuplexHandle {} -> error "withHandleFd: not a file handle"
  
  -- | See `ensureFileDurable`
  ensureFileDurable :: MonadIO m => FilePath -> m ()
  ensureFileDurable filePath =
    liftIO $
    withDirectory (takeDirectory filePath) $ \dirFd ->
      withFileInDirectory dirFd filePath ReadMode $ \fileHandle ->
        liftIO $ do
          fsyncFileHandle "ensureFileDurablePosix" fileHandle
          -- NOTE: Here we are purposefully not fsyncing the directory if the file fails to fsync
          fsyncDirectoryFd "ensureFileDurablePosix" dirFd
  
  
  
  -- | See `withBinaryFileDurable`
  withBinaryFileDurable ::
       MonadUnliftIO m => FilePath -> IOMode -> (Handle -> m r) -> m r
  withBinaryFileDurable filePath iomode action =
    case iomode of
      ReadMode
        -- We do not need to consider durable operations when we are in a
        -- 'ReadMode', so we can use a regular `withBinaryFile`
       -> withBinaryFile filePath iomode action
      _ {- WriteMode,  ReadWriteMode,  AppendMode -}
       ->
        withDirectory (takeDirectory filePath) $ \dirFd ->
          withFileInDirectory dirFd filePath iomode $ \tmpFileHandle -> do
            res <- action tmpFileHandle
            liftIO $ do
              fsyncFileHandle "withBinaryFileDurablePosix" tmpFileHandle
              -- NOTE: Here we are purposefully not fsyncing the directory if the file fails to fsync
              fsyncDirectoryFd "withBinaryFileDurablePosix" dirFd
            pure res
  
  -- | See `withBinaryFileDurableAtomic`
  withBinaryFileDurableAtomic ::
       MonadUnliftIO m => FilePath -> IOMode -> (Handle -> m r) -> m r
  withBinaryFileDurableAtomic filePath iomode action =
    case iomode of
      ReadMode
        -- We do not need to consider an atomic operation when we are in a
        -- 'ReadMode', so we can use a regular `withBinaryFile`
       -> withBinaryFile filePath iomode action
      _ {- WriteMode,  ReadWriteMode,  AppendMode -}
       ->
        withDirectory (takeDirectory filePath) $ \dirFd -> do
          mRes <- withAnonymousBinaryTempFileFor (Just dirFd) filePath iomode $
            durableAtomicAction dirFd Nothing
          case mRes of
            Just res -> pure res
            Nothing ->
              withNonAnonymousBinaryTempFileFor (Just dirFd) filePath iomode $ \tmpFilePath ->
                durableAtomicAction dirFd (Just tmpFilePath)
    where
      durableAtomicAction dirFd mTmpFilePath tmpFileHandle = do
        mFileMode <- copyFileHandle iomode filePath tmpFileHandle
        res <- action tmpFileHandle
        liftIO $
          atomicDurableTempFileRename
            dirFd
            mFileMode
            tmpFileHandle
            mTmpFilePath
            filePath
        pure res
  
  -- | See `withBinaryFileAtomic`
  withBinaryFileAtomic ::
       MonadUnliftIO m => FilePath -> IOMode -> (Handle -> m r) -> m r
  withBinaryFileAtomic filePath iomode action =
    case iomode of
      ReadMode
        -- We do not need to consider an atomic operation when we are in a
        -- 'ReadMode', so we can use a regular `withBinaryFile`
       -> withBinaryFile filePath iomode action
      _ {- WriteMode,  ReadWriteMode,  AppendMode -}
       -> do
        mRes <-
          withAnonymousBinaryTempFileFor Nothing filePath iomode $
          atomicAction Nothing
        case mRes of
          Just res -> pure res
          Nothing ->
            withNonAnonymousBinaryTempFileFor Nothing filePath iomode $ \tmpFilePath ->
              atomicAction (Just tmpFilePath)
    where
      atomicAction mTmpFilePath tmpFileHandle = do
        let eTmpFile = maybe (Left tmpFileHandle) Right mTmpFilePath
        mFileMode <- copyFileHandle iomode filePath tmpFileHandle
        res <- action tmpFileHandle
        liftIO $ atomicTempFileRename Nothing mFileMode eTmpFile filePath
        pure res
  
  