IO/File/Posix.hs

{-# 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