{-# 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 (CFlag -> CFlag -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CFlag -> CFlag -> Bool
$c/= :: CFlag -> CFlag -> Bool
== :: CFlag -> CFlag -> Bool
$c== :: CFlag -> CFlag -> Bool
Eq, Int -> CFlag -> ShowS
[CFlag] -> ShowS
CFlag -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [CFlag] -> ShowS
$cshowList :: [CFlag] -> ShowS
show :: CFlag -> [Char]
$cshow :: CFlag -> [Char]
showsPrec :: Int -> CFlag -> ShowS
$cshowsPrec :: Int -> CFlag -> ShowS
Show, Eq CFlag
CFlag
Int -> CFlag
CFlag -> Bool
CFlag -> Int
CFlag -> Maybe Int
CFlag -> CFlag
CFlag -> Int -> Bool
CFlag -> Int -> CFlag
CFlag -> CFlag -> CFlag
forall a.
Eq a
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> Int -> a)
-> (a -> Int -> a)
-> a
-> (Int -> a)
-> (a -> Int -> a)
-> (a -> Int -> a)
-> (a -> Int -> a)
-> (a -> Int -> Bool)
-> (a -> Maybe Int)
-> (a -> Int)
-> (a -> Bool)
-> (a -> Int -> a)
-> (a -> Int -> a)
-> (a -> Int -> a)
-> (a -> Int -> a)
-> (a -> Int -> a)
-> (a -> Int -> a)
-> (a -> Int)
-> Bits a
popCount :: CFlag -> Int
$cpopCount :: CFlag -> Int
rotateR :: CFlag -> Int -> CFlag
$crotateR :: CFlag -> Int -> CFlag
rotateL :: CFlag -> Int -> CFlag
$crotateL :: CFlag -> Int -> CFlag
unsafeShiftR :: CFlag -> Int -> CFlag
$cunsafeShiftR :: CFlag -> Int -> CFlag
shiftR :: CFlag -> Int -> CFlag
$cshiftR :: CFlag -> Int -> CFlag
unsafeShiftL :: CFlag -> Int -> CFlag
$cunsafeShiftL :: CFlag -> Int -> CFlag
shiftL :: CFlag -> Int -> CFlag
$cshiftL :: CFlag -> Int -> CFlag
isSigned :: CFlag -> Bool
$cisSigned :: CFlag -> Bool
bitSize :: CFlag -> Int
$cbitSize :: CFlag -> Int
bitSizeMaybe :: CFlag -> Maybe Int
$cbitSizeMaybe :: CFlag -> Maybe Int
testBit :: CFlag -> Int -> Bool
$ctestBit :: CFlag -> Int -> Bool
complementBit :: CFlag -> Int -> CFlag
$ccomplementBit :: CFlag -> Int -> CFlag
clearBit :: CFlag -> Int -> CFlag
$cclearBit :: CFlag -> Int -> CFlag
setBit :: CFlag -> Int -> CFlag
$csetBit :: CFlag -> Int -> CFlag
bit :: Int -> CFlag
$cbit :: Int -> CFlag
zeroBits :: CFlag
$czeroBits :: CFlag
rotate :: CFlag -> Int -> CFlag
$crotate :: CFlag -> Int -> CFlag
shift :: CFlag -> Int -> CFlag
$cshift :: CFlag -> Int -> CFlag
complement :: CFlag -> CFlag
$ccomplement :: CFlag -> CFlag
xor :: CFlag -> CFlag -> CFlag
$cxor :: CFlag -> CFlag -> CFlag
.|. :: CFlag -> CFlag -> CFlag
$c.|. :: CFlag -> CFlag -> CFlag
.&. :: CFlag -> CFlag -> CFlag
$c.&. :: CFlag -> CFlag -> CFlag
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
o_TMPFILE_not_supported = CInt -> CFlag
CFlag CInt
0

newtype CAt = CAt
  { CAt -> CInt
unCAt :: CInt
  } deriving (CAt -> CAt -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CAt -> CAt -> Bool
$c/= :: CAt -> CAt -> Bool
== :: CAt -> CAt -> Bool
$c== :: CAt -> CAt -> Bool
Eq, Int -> CAt -> ShowS
[CAt] -> ShowS
CAt -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [CAt] -> ShowS
$cshowList :: [CAt] -> ShowS
show :: CAt -> [Char]
$cshow :: CAt -> [Char]
showsPrec :: Int -> CAt -> ShowS
$cshowsPrec :: Int -> CAt -> ShowS
Show, Eq CAt
CAt
Int -> CAt
CAt -> Bool
CAt -> Int
CAt -> Maybe Int
CAt -> CAt
CAt -> Int -> Bool
CAt -> Int -> CAt
CAt -> CAt -> CAt
forall a.
Eq a
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> Int -> a)
-> (a -> Int -> a)
-> a
-> (Int -> a)
-> (a -> Int -> a)
-> (a -> Int -> a)
-> (a -> Int -> a)
-> (a -> Int -> Bool)
-> (a -> Maybe Int)
-> (a -> Int)
-> (a -> Bool)
-> (a -> Int -> a)
-> (a -> Int -> a)
-> (a -> Int -> a)
-> (a -> Int -> a)
-> (a -> Int -> a)
-> (a -> Int -> a)
-> (a -> Int)
-> Bits a
popCount :: CAt -> Int
$cpopCount :: CAt -> Int
rotateR :: CAt -> Int -> CAt
$crotateR :: CAt -> Int -> CAt
rotateL :: CAt -> Int -> CAt
$crotateL :: CAt -> Int -> CAt
unsafeShiftR :: CAt -> Int -> CAt
$cunsafeShiftR :: CAt -> Int -> CAt
shiftR :: CAt -> Int -> CAt
$cshiftR :: CAt -> Int -> CAt
unsafeShiftL :: CAt -> Int -> CAt
$cunsafeShiftL :: CAt -> Int -> CAt
shiftL :: CAt -> Int -> CAt
$cshiftL :: CAt -> Int -> CAt
isSigned :: CAt -> Bool
$cisSigned :: CAt -> Bool
bitSize :: CAt -> Int
$cbitSize :: CAt -> Int
bitSizeMaybe :: CAt -> Maybe Int
$cbitSizeMaybe :: CAt -> Maybe Int
testBit :: CAt -> Int -> Bool
$ctestBit :: CAt -> Int -> Bool
complementBit :: CAt -> Int -> CAt
$ccomplementBit :: CAt -> Int -> CAt
clearBit :: CAt -> Int -> CAt
$cclearBit :: CAt -> Int -> CAt
setBit :: CAt -> Int -> CAt
$csetBit :: CAt -> Int -> CAt
bit :: Int -> CAt
$cbit :: Int -> CAt
zeroBits :: CAt
$czeroBits :: CAt
rotate :: CAt -> Int -> CAt
$crotate :: CAt -> Int -> CAt
shift :: CAt -> Int -> CAt
$cshift :: CAt -> Int -> CAt
complement :: CAt -> CAt
$ccomplement :: CAt -> CAt
xor :: CAt -> CAt -> CAt
$cxor :: CAt -> CAt -> CAt
.|. :: CAt -> CAt -> CAt
$c.|. :: CAt -> CAt -> CAt
.&. :: CAt -> CAt -> CAt
$c.&. :: CAt -> CAt -> CAt
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 :: CFilePath -> CFlag -> CMode -> IO CInt
c_open CFilePath
fp (CFlag CInt
flags) = CFilePath -> CInt -> CMode -> IO CInt
c_safe_open CFilePath
fp CInt
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 -> CFilePath -> CFlag -> CMode -> IO CInt
c_openat (DirFd (Fd CInt
fd)) CFilePath
fp (CFlag CInt
flags) = CInt -> CFilePath -> CInt -> CMode -> IO CInt
c_safe_openat CInt
fd CFilePath
fp CInt
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 -> CFilePath -> DirFd -> CFilePath -> IO CInt
c_renameat (DirFd (Fd CInt
fdFrom)) CFilePath
cFpFrom (DirFd (Fd CInt
fdTo)) CFilePath
cFpTo =
  CInt -> CFilePath -> CInt -> CFilePath -> IO CInt
c_safe_renameat CInt
fdFrom CFilePath
cFpFrom CInt
fdTo CFilePath
cFpTo

foreign import ccall safe "unistd.h fsync"
  c_safe_fsync :: CInt -> IO CInt

c_fsync :: Fd -> IO CInt
c_fsync :: Fd -> IO CInt
c_fsync (Fd CInt
fd) = CInt -> IO CInt
c_safe_fsync CInt
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 -> CFilePath -> Either DirFd CAt -> CFilePath -> CAt -> IO CInt
c_linkat CAt
cat CFilePath
oldPath Either DirFd CAt
eNewDir CFilePath
newPath (CAt CInt
flags) =
  CInt -> CFilePath -> CInt -> CFilePath -> CInt -> IO CInt
c_safe_linkat (CAt -> CInt
unCAt CAt
cat) CFilePath
oldPath CInt
newDir CFilePath
newPath CInt
flags
  where
    unFd :: Fd -> CInt
unFd (Fd CInt
fd) = CInt
fd
    newDir :: CInt
newDir = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Fd -> CInt
unFd forall b c a. (b -> c) -> (a -> b) -> a -> c
. DirFd -> Fd
unDirFd) CAt -> CInt
unCAt Either DirFd CAt
eNewDir

std_flags, output_flags, read_flags, write_flags, rw_flags,
    append_flags :: CFlag
std_flags :: CFlag
std_flags    = CFlag
o_NOCTTY
output_flags :: CFlag
output_flags = CFlag
std_flags    forall a. Bits a => a -> a -> a
.|. CFlag
o_CREAT
read_flags :: CFlag
read_flags   = CFlag
std_flags    forall a. Bits a => a -> a -> a
.|. CFlag
o_RDONLY
write_flags :: CFlag
write_flags  = CFlag
output_flags forall a. Bits a => a -> a -> a
.|. CFlag
o_WRONLY
rw_flags :: CFlag
rw_flags     = CFlag
output_flags forall a. Bits a => a -> a -> a
.|. CFlag
o_RDWR
append_flags :: CFlag
append_flags = CFlag
write_flags  forall a. Bits a => a -> a -> a
.|. CFlag
o_APPEND

ioModeToFlags :: IOMode -> CFlag
ioModeToFlags :: IOMode -> CFlag
ioModeToFlags IOMode
iomode =
  case IOMode
iomode of
    IOMode
ReadMode      -> CFlag
read_flags
    IOMode
WriteMode     -> CFlag
write_flags
    IOMode
ReadWriteMode -> CFlag
rw_flags
    IOMode
AppendMode    -> CFlag
append_flags

newtype DirFd = DirFd
  { DirFd -> Fd
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 :: forall (m :: * -> *). MonadIO m => [Char] -> m Fd
openDir [Char]
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
 =
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
  forall a. [Char] -> (CFilePath -> IO a) -> IO a
withFilePath [Char]
fp forall a b. (a -> b) -> a -> b
$ \CFilePath
cFp ->
    CInt -> Fd
Fd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    forall a. (Eq a, Num a) => [Char] -> IO a -> IO a
throwErrnoIfMinus1Retry
      [Char]
"openDir"
      (CFilePath -> CFlag -> CMode -> IO CInt
c_open CFilePath
cFp (IOMode -> CFlag
ioModeToFlags IOMode
ReadMode) CMode
0o660)

-- | Closes a 'Fd' that points to a Directory.
closeDirectory :: MonadIO m => DirFd -> m ()
closeDirectory :: forall (m :: * -> *). MonadIO m => DirFd -> m ()
closeDirectory (DirFd (Fd CInt
dirFd)) =
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
  forall a. (Eq a, Num a) => [Char] -> IO a -> IO ()
throwErrnoIfMinus1Retry_ [Char]
"closeDirectory" forall a b. (a -> b) -> a -> b
$ CInt -> IO CInt
c_close CInt
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 :: forall (m :: * -> *). MonadIO m => [Char] -> Fd -> m ()
fsyncFileDescriptor [Char]
name Fd
fd =
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a. (Eq a, Num a) => [Char] -> IO a -> IO a
throwErrnoIfMinus1 ([Char]
"fsync - " forall a. [a] -> [a] -> [a]
++ [Char]
name) forall a b. (a -> b) -> a -> b
$ Fd -> IO CInt
c_fsync Fd
fd

-- | Call @fsync@ on the file handle. Accepts an arbitary string for error reporting.
fsyncFileHandle :: String -> Handle -> IO ()
fsyncFileHandle :: [Char] -> Handle -> IO ()
fsyncFileHandle [Char]
fname Handle
hdl = forall a. Handle -> (Fd -> IO a) -> IO a
withHandleFd Handle
hdl (forall (m :: * -> *). MonadIO m => [Char] -> Fd -> m ()
fsyncFileDescriptor ([Char]
fname forall a. [a] -> [a] -> [a]
++ [Char]
"/File"))


-- | Call @fsync@ on the opened directory file descriptor. Accepts an arbitary
-- string for error reporting.
fsyncDirectoryFd :: String -> DirFd -> IO ()
fsyncDirectoryFd :: [Char] -> DirFd -> IO ()
fsyncDirectoryFd [Char]
fname = forall (m :: * -> *). MonadIO m => [Char] -> Fd -> m ()
fsyncFileDescriptor ([Char]
fname forall a. [a] -> [a] -> [a]
++ [Char]
"/Directory") forall b c a. (b -> c) -> (a -> b) -> a -> c
. DirFd -> Fd
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 :: forall (m :: * -> *).
MonadIO m =>
DirFd -> [Char] -> IOMode -> m Handle
openFileFromDir DirFd
dirFd filePath :: [Char]
filePath@(ShowS
takeFileName -> [Char]
fileName) IOMode
iomode =
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
  forall a. [Char] -> (CFilePath -> IO a) -> IO a
withFilePath [Char]
fileName forall a b. (a -> b) -> a -> b
$ \CFilePath
cFileName ->
    forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracketOnError
      (do CInt
fileFd <-
            forall a. (Eq a, Num a) => [Char] -> IO a -> IO a
throwErrnoIfMinus1Retry [Char]
"openFileFromDir" forall a b. (a -> b) -> a -> b
$
            DirFd -> CFilePath -> CFlag -> CMode -> IO CInt
c_openat DirFd
dirFd CFilePath
cFileName (IOMode -> CFlag
ioModeToFlags IOMode
iomode) CMode
0o666
            {- Can open directory with read only -}
          CInt
-> IOMode
-> Maybe (IODeviceType, CDev, CIno)
-> Bool
-> Bool
-> IO (FD, IODeviceType)
FD.mkFD
            CInt
fileFd
            IOMode
iomode
            forall a. Maybe a
Nothing {- no stat -}
            Bool
False {- not a socket -}
            Bool
False {- non_blocking -}
           forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`onException`
            CInt -> IO CInt
c_close CInt
fileFd)
      (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IODevice a => a -> IO ()
Device.close forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)
      (\(FD
fD, IODeviceType
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
         forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (IOMode
iomode forall a. Eq a => a -> a -> Bool
== IOMode
WriteMode Bool -> Bool -> Bool
&& IODeviceType
fd_type forall a. Eq a => a -> a -> Bool
== IODeviceType
RegularFile) forall a b. (a -> b) -> a -> b
$
           forall a. IODevice a => a -> Integer -> IO ()
Device.setSize FD
fD Integer
0
         FD
-> IODeviceType
-> [Char]
-> IOMode
-> Bool
-> Maybe TextEncoding
-> IO Handle
HandleFD.mkHandleFromFD FD
fD IODeviceType
fd_type [Char]
filePath IOMode
iomode Bool
False forall a. Maybe a
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 :: forall (m :: * -> *).
MonadIO m =>
Maybe DirFd -> [Char] -> IOMode -> m Handle
openAnonymousTempFileFromDir Maybe DirFd
mDirFd [Char]
filePath IOMode
iomode =
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
  case Maybe DirFd
mDirFd of
    Just DirFd
dirFd -> forall a. [Char] -> (CFilePath -> IO a) -> IO a
withFilePath [Char]
"." ((CFlag -> CMode -> IO CInt) -> IO Handle
openAnonymousWith forall b c a. (b -> c) -> (a -> b) -> a -> c
. DirFd -> CFilePath -> CFlag -> CMode -> IO CInt
c_openat DirFd
dirFd)
    Maybe DirFd
Nothing ->
      forall a. [Char] -> (CFilePath -> IO a) -> IO a
withFilePath (ShowS
takeDirectory [Char]
filePath) ((CFlag -> CMode -> IO CInt) -> IO Handle
openAnonymousWith forall b c a. (b -> c) -> (a -> b) -> a -> c
. CFilePath -> CFlag -> CMode -> IO CInt
c_open)
  where
    fdName :: [Char]
fdName = [Char]
"openAnonymousTempFileFromDir - " forall a. [a] -> [a] -> [a]
++ [Char]
filePath
    ioModeToTmpFlags :: IOMode -> CFlag
    ioModeToTmpFlags :: IOMode -> CFlag
ioModeToTmpFlags =
      \case
        IOMode
ReadMode -> CFlag
o_RDWR -- It is an error to create a O_TMPFILE with O_RDONLY
        IOMode
ReadWriteMode -> CFlag
o_RDWR
        IOMode
_ -> CFlag
o_WRONLY
    openAnonymousWith :: (CFlag -> CMode -> IO CInt) -> IO Handle
openAnonymousWith CFlag -> CMode -> IO CInt
fopen =
      forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracketOnError
        (do CInt
fileFd <-
              forall a. (Eq a, Num a) => [Char] -> IO a -> IO a
throwErrnoIfMinus1Retry [Char]
"openAnonymousTempFileFromDir" forall a b. (a -> b) -> a -> b
$
              CFlag -> CMode -> IO CInt
fopen (CFlag
o_TMPFILE forall a. Bits a => a -> a -> a
.|. IOMode -> CFlag
ioModeToTmpFlags IOMode
iomode) (CMode
s_IRUSR forall a. Bits a => a -> a -> a
.|. CMode
s_IWUSR)
            CInt
-> IOMode
-> Maybe (IODeviceType, CDev, CIno)
-> Bool
-> Bool
-> IO (FD, IODeviceType)
FD.mkFD
              CInt
fileFd
              IOMode
iomode
              forall a. Maybe a
Nothing {- no stat -}
              Bool
False {- not a socket -}
              Bool
False {- non_blocking -}
             forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`onException`
              CInt -> IO CInt
c_close CInt
fileFd)
        (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IODevice a => a -> IO ()
Device.close forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)
        (\(FD
fD, IODeviceType
fd_type) ->
           FD
-> IODeviceType
-> [Char]
-> IOMode
-> Bool
-> Maybe TextEncoding
-> IO Handle
HandleFD.mkHandleFromFD FD
fD IODeviceType
fd_type [Char]
fdName IOMode
iomode Bool
False forall a. Maybe a
Nothing)


atomicDurableTempFileRename ::
     DirFd -> Maybe FileMode -> Handle -> Maybe FilePath -> FilePath -> IO ()
atomicDurableTempFileRename :: DirFd -> Maybe CMode -> Handle -> Maybe [Char] -> [Char] -> IO ()
atomicDurableTempFileRename DirFd
dirFd Maybe CMode
mFileMode Handle
tmpFileHandle Maybe [Char]
mTmpFilePath [Char]
filePath = do
  [Char] -> Handle -> IO ()
fsyncFileHandle [Char]
"atomicDurableTempFileCreate" Handle
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 :: Either Handle [Char]
eTmpFile = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left Handle
tmpFileHandle) forall a b. b -> Either a b
Right Maybe [Char]
mTmpFilePath
  Maybe DirFd
-> Maybe CMode -> Either Handle [Char] -> [Char] -> IO ()
atomicTempFileRename (forall a. a -> Maybe a
Just DirFd
dirFd) Maybe CMode
mFileMode Either Handle [Char]
eTmpFile [Char]
filePath
  -- Important to close the handle, so the we can fsync the directory
  forall (m :: * -> *). MonadIO m => Handle -> m ()
hClose Handle
tmpFileHandle
  -- file path is updated, now we can fsync the directory
  [Char] -> DirFd -> IO ()
fsyncDirectoryFd [Char]
"atomicDurableTempFileCreate" DirFd
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 :: Maybe DirFd -> Maybe CMode -> Handle -> [Char] -> IO ()
atomicTempFileCreate Maybe DirFd
mDirFd Maybe CMode
mFileMode Handle
tmpFileHandle [Char]
filePath =
  forall a. Handle -> (Fd -> IO a) -> IO a
withHandleFd Handle
tmpFileHandle forall a b. (a -> b) -> a -> b
$ \fd :: Fd
fd@(Fd CInt
cFd) ->
    forall a. [Char] -> (CFilePath -> IO a) -> IO a
withFilePath ([Char]
"/proc/self/fd/" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show CInt
cFd) forall a b. (a -> b) -> a -> b
$ \CFilePath
cFromFilePath ->
      forall a. [Char] -> (CFilePath -> IO a) -> IO a
withFilePath [Char]
filePathName forall a b. (a -> b) -> a -> b
$ \CFilePath
cToFilePath -> do
        let fileMode :: CMode
fileMode = forall a. a -> Maybe a -> a
fromMaybe CMode
Posix.stdFileMode Maybe CMode
mFileMode
        -- work around for the glibc bug: https://sourceware.org/bugzilla/show_bug.cgi?id=17523
        Fd -> CMode -> IO ()
Posix.setFdMode Fd
fd CMode
fileMode
        let safeLink :: [Char] -> CFilePath -> IO ()
safeLink [Char]
which CFilePath
to =
              forall a. (Eq a, Num a) => [Char] -> IO a -> IO ()
throwErrnoIfMinus1Retry_
                ([Char]
"atomicFileCreate - c_safe_linkat - " forall a. [a] -> [a] -> [a]
++ [Char]
which) forall a b. (a -> b) -> a -> b
$
              -- see `man linkat` and `man openat` for more info
              CAt -> CFilePath -> Either DirFd CAt -> CFilePath -> CAt -> IO CInt
c_linkat CAt
at_FDCWD CFilePath
cFromFilePath Either DirFd CAt
cDirFd CFilePath
to CAt
at_SYMLINK_FOLLOW
        Either () ()
eExc <-
          forall (m :: * -> *) e b a.
(MonadUnliftIO m, Exception e) =>
(e -> Maybe b) -> m a -> m (Either b a)
tryJust (forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> Bool
isAlreadyExistsError) forall a b. (a -> b) -> a -> b
$
          [Char] -> CFilePath -> IO ()
safeLink [Char]
"anonymous" CFilePath
cToFilePath
        case Either () ()
eExc of
          Right () -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          Left () ->
            forall (m :: * -> *) a.
MonadUnliftIO m =>
[Char] -> ([Char] -> Handle -> m a) -> m a
withBinaryTempFileFor [Char]
filePath forall a b. (a -> b) -> a -> b
$ \[Char]
visTmpFileName Handle
visTmpFileHandle -> do
              forall (m :: * -> *). MonadIO m => Handle -> m ()
hClose Handle
visTmpFileHandle
              [Char] -> IO ()
removeFile [Char]
visTmpFileName
              case Maybe DirFd
mDirFd of
                Maybe DirFd
Nothing -> do
                  forall a. [Char] -> (CFilePath -> IO a) -> IO a
withFilePath [Char]
visTmpFileName ([Char] -> CFilePath -> IO ()
safeLink [Char]
"visible")
                  [Char] -> [Char] -> IO ()
Posix.rename [Char]
visTmpFileName [Char]
filePath
                Just DirFd
dirFd ->
                  forall a. [Char] -> (CFilePath -> IO a) -> IO a
withFilePath (ShowS
takeFileName [Char]
visTmpFileName) forall a b. (a -> b) -> a -> b
$ \CFilePath
cVisTmpFile -> do
                    [Char] -> CFilePath -> IO ()
safeLink [Char]
"visible" CFilePath
cVisTmpFile
                    forall a. (Eq a, Num a) => [Char] -> IO a -> IO ()
throwErrnoIfMinus1Retry_
                        [Char]
"atomicFileCreate - c_safe_renameat" forall a b. (a -> b) -> a -> b
$
                      DirFd -> CFilePath -> DirFd -> CFilePath -> IO CInt
c_renameat DirFd
dirFd CFilePath
cVisTmpFile DirFd
dirFd CFilePath
cToFilePath
  where
    (Either DirFd CAt
cDirFd, [Char]
filePathName) =
      case Maybe DirFd
mDirFd of
        Maybe DirFd
Nothing    -> (forall a b. b -> Either a b
Right CAt
at_FDCWD, [Char]
filePath)
        Just DirFd
dirFd -> (forall a b. a -> Either a b
Left DirFd
dirFd, ShowS
takeFileName [Char]
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 :: Maybe DirFd
-> Maybe CMode -> Either Handle [Char] -> [Char] -> IO ()
atomicTempFileRename Maybe DirFd
mDirFd Maybe CMode
mFileMode Either Handle [Char]
eTmpFile [Char]
filePath =
  case Either Handle [Char]
eTmpFile of
    Left Handle
tmpFileHandle ->
      Maybe DirFd -> Maybe CMode -> Handle -> [Char] -> IO ()
atomicTempFileCreate Maybe DirFd
mDirFd Maybe CMode
mFileMode Handle
tmpFileHandle [Char]
filePath
    Right [Char]
tmpFilePath -> do
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe CMode
mFileMode forall a b. (a -> b) -> a -> b
$ \CMode
fileMode -> [Char] -> CMode -> IO ()
Posix.setFileMode [Char]
tmpFilePath CMode
fileMode
      case Maybe DirFd
mDirFd of
        Maybe DirFd
Nothing -> [Char] -> [Char] -> IO ()
Posix.rename [Char]
tmpFilePath [Char]
filePath
        Just DirFd
dirFd ->
          forall a. [Char] -> (CFilePath -> IO a) -> IO a
withFilePath (ShowS
takeFileName [Char]
filePath) forall a b. (a -> b) -> a -> b
$ \CFilePath
cToFilePath ->
            forall a. [Char] -> (CFilePath -> IO a) -> IO a
withFilePath (ShowS
takeFileName [Char]
tmpFilePath) forall a b. (a -> b) -> a -> b
$ \CFilePath
cTmpFilePath ->
              forall a. (Eq a, Num a) => [Char] -> IO a -> IO ()
throwErrnoIfMinus1Retry_ [Char]
"atomicFileCreate - c_safe_renameat" forall a b. (a -> b) -> a -> b
$
              DirFd -> CFilePath -> DirFd -> CFilePath -> IO CInt
c_renameat DirFd
dirFd CFilePath
cTmpFilePath DirFd
dirFd CFilePath
cToFilePath


withDirectory :: MonadUnliftIO m => FilePath -> (DirFd -> m a) -> m a
withDirectory :: forall (m :: * -> *) a.
MonadUnliftIO m =>
[Char] -> (DirFd -> m a) -> m a
withDirectory [Char]
dirPath = forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket (Fd -> DirFd
DirFd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadIO m => [Char] -> m Fd
openDir [Char]
dirPath) forall (m :: * -> *). MonadIO m => DirFd -> m ()
closeDirectory

withFileInDirectory ::
     MonadUnliftIO m => DirFd -> FilePath -> IOMode -> (Handle -> m a) -> m a
withFileInDirectory :: forall (m :: * -> *) a.
MonadUnliftIO m =>
DirFd -> [Char] -> IOMode -> (Handle -> m a) -> m a
withFileInDirectory DirFd
dirFd [Char]
filePath IOMode
iomode =
  forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket (forall (m :: * -> *).
MonadIO m =>
DirFd -> [Char] -> IOMode -> m Handle
openFileFromDir DirFd
dirFd [Char]
filePath IOMode
iomode) forall (m :: * -> *). MonadIO m => Handle -> m ()
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 :: forall (m :: * -> *) a.
MonadUnliftIO m =>
[Char] -> ([Char] -> Handle -> m a) -> m a
withBinaryTempFileFor [Char]
filePath [Char] -> Handle -> m a
action =
  forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracketOnError
    (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([Char] -> [Char] -> IO ([Char], Handle)
openBinaryTempFile [Char]
dirPath [Char]
tmpFileName))
    (\([Char]
tmpFilePath, Handle
tmpFileHandle) ->
        forall (m :: * -> *). MonadIO m => Handle -> m ()
hClose Handle
tmpFileHandle forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either IOError a)
tryIO ([Char] -> IO ()
removeFile [Char]
tmpFilePath)))
    (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [Char] -> Handle -> m a
action)
  where
    dirPath :: [Char]
dirPath = ShowS
takeDirectory [Char]
filePath
    fileName :: [Char]
fileName = ShowS
takeFileName [Char]
filePath
    tmpFileName :: [Char]
tmpFileName = [Char]
"." forall a. [a] -> [a] -> [a]
++ [Char]
fileName forall a. [a] -> [a] -> [a]
++ [Char]
".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 :: forall (m :: * -> *) a.
MonadUnliftIO m =>
Maybe DirFd -> [Char] -> IOMode -> (Handle -> m a) -> m (Maybe a)
withAnonymousBinaryTempFileFor Maybe DirFd
mDirFd [Char]
filePath IOMode
iomode Handle -> m a
action
  | CFlag
o_TMPFILE forall a. Eq a => a -> a -> Bool
== CFlag
o_TMPFILE_not_supported = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
  | Bool
otherwise =
    forall {m :: * -> *} {a}. MonadUnliftIO m => m a -> m (Maybe a)
trySupported forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket (forall (m :: * -> *).
MonadIO m =>
Maybe DirFd -> [Char] -> IOMode -> m Handle
openAnonymousTempFileFromDir Maybe DirFd
mDirFd [Char]
filePath IOMode
iomode) forall (m :: * -> *). MonadIO m => Handle -> m ()
hClose Handle -> m a
action
  where
    trySupported :: m a -> m (Maybe a)
trySupported m a
m =
      forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either IOError a)
tryIO m a
m forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Right a
res -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just a
res
        Left IOError
exc
          | IOError -> IOErrorType
ioeGetErrorType IOError
exc forall a. Eq a => a -> a -> Bool
== IOErrorType
UnsupportedOperation -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
        Left IOError
exc -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO IOError
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 :: forall (m :: * -> *) a.
MonadUnliftIO m =>
Maybe DirFd -> [Char] -> IOMode -> ([Char] -> Handle -> m a) -> m a
withNonAnonymousBinaryTempFileFor Maybe DirFd
mDirFd [Char]
filePath IOMode
iomode [Char] -> Handle -> m a
action =
  forall (m :: * -> *) a.
MonadUnliftIO m =>
[Char] -> ([Char] -> Handle -> m a) -> m a
withBinaryTempFileFor [Char]
filePath forall a b. (a -> b) -> a -> b
$ \[Char]
tmpFilePath Handle
tmpFileHandle -> do
    forall (m :: * -> *). MonadIO m => Handle -> m ()
hClose Handle
tmpFileHandle
    case Maybe DirFd
mDirFd of
      Maybe DirFd
Nothing -> forall (m :: * -> *) a.
MonadUnliftIO m =>
[Char] -> IOMode -> (Handle -> m a) -> m a
withBinaryFile [Char]
tmpFilePath IOMode
iomode ([Char] -> Handle -> m a
action [Char]
tmpFilePath)
      Just DirFd
dirFd -> forall (m :: * -> *) a.
MonadUnliftIO m =>
DirFd -> [Char] -> IOMode -> (Handle -> m a) -> m a
withFileInDirectory DirFd
dirFd [Char]
tmpFilePath IOMode
iomode ([Char] -> Handle -> m a
action [Char]
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 :: forall (f :: * -> *).
MonadUnliftIO f =>
IOMode -> [Char] -> Handle -> f (Maybe CMode)
copyFileHandle IOMode
iomode [Char]
fromFilePath Handle
toHandle =
  forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
  forall (m :: * -> *) e b a.
(MonadUnliftIO m, Exception e) =>
(e -> Maybe b) -> m a -> m (Either b a)
tryJust
    (forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> Bool
isDoesNotExistError)
    (do FileStatus
fileStatus <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO FileStatus
Posix.getFileStatus [Char]
fromFilePath
        -- Whenever we are not overwriting an existing file, we also need a
        -- copy of the file's contents
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (IOMode
iomode forall a. Eq a => a -> a -> Bool
== IOMode
WriteMode) forall a b. (a -> b) -> a -> b
$ do
          forall (m :: * -> *) a.
MonadUnliftIO m =>
[Char] -> IOMode -> (Handle -> m a) -> m a
withBinaryFile [Char]
fromFilePath IOMode
ReadMode (forall (m :: * -> *). MonadIO m => Handle -> Handle -> m ()
`copyHandleData` Handle
toHandle)
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (IOMode
iomode forall a. Eq a => a -> a -> Bool
== IOMode
AppendMode) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
Handle -> SeekMode -> Integer -> m ()
hSeek Handle
toHandle SeekMode
AbsoluteSeek Integer
0
        -- Get the copy of source file permissions, but only whenever it exists
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ FileStatus -> CMode
Posix.fileMode FileStatus
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 :: forall (m :: * -> *). MonadIO m => Handle -> Handle -> m ()
copyHandleData Handle
hFrom Handle
hTo = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
bufferSize forall {a}. Ptr a -> IO ()
go
  where
    bufferSize :: Int
bufferSize = Int
131072 -- 128 KiB, as coreutils `cp` uses as of May 2014 (see ioblksize.h)
    go :: Ptr a -> IO ()
go Ptr a
buffer = do
      Int
count <- forall a. Handle -> Ptr a -> Int -> IO Int
hGetBuf Handle
hFrom Ptr a
buffer Int
bufferSize
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
count forall a. Ord a => a -> a -> Bool
> Int
0) forall a b. (a -> b) -> a -> b
$ do
        forall a. Handle -> Ptr a -> Int -> IO ()
hPutBuf Handle
hTo Ptr a
buffer Int
count
        Ptr a -> IO ()
go Ptr a
buffer

-- | Thread safe access to the file descriptor in the file handle
withHandleFd :: Handle -> (Fd -> IO a) -> IO a
withHandleFd :: forall a. Handle -> (Fd -> IO a) -> IO a
withHandleFd Handle
h Fd -> IO a
cb =
  case Handle
h of
    HandleFD.FileHandle [Char]
_ MVar Handle__
mv ->
      forall (m :: * -> *) a b.
MonadUnliftIO m =>
MVar a -> (a -> m b) -> m b
withMVar MVar Handle__
mv forall a b. (a -> b) -> a -> b
$ \HandleFD.Handle__{haDevice :: ()
HandleFD.haDevice = dev
dev} ->
        case forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast dev
dev of
          Just FD
fd -> Fd -> IO a
cb forall a b. (a -> b) -> a -> b
$ CInt -> Fd
Fd forall a b. (a -> b) -> a -> b
$ FD -> CInt
FD.fdFD FD
fd
          Maybe FD
Nothing -> forall a. HasCallStack => [Char] -> a
error [Char]
"withHandleFd: not a file handle"
    HandleFD.DuplexHandle {} -> forall a. HasCallStack => [Char] -> a
error [Char]
"withHandleFd: not a file handle"

-- | See `ensureFileDurable`
ensureFileDurable :: MonadIO m => FilePath -> m ()
ensureFileDurable :: forall (m :: * -> *). MonadIO m => [Char] -> m ()
ensureFileDurable [Char]
filePath =
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
  forall (m :: * -> *) a.
MonadUnliftIO m =>
[Char] -> (DirFd -> m a) -> m a
withDirectory (ShowS
takeDirectory [Char]
filePath) forall a b. (a -> b) -> a -> b
$ \DirFd
dirFd ->
    forall (m :: * -> *) a.
MonadUnliftIO m =>
DirFd -> [Char] -> IOMode -> (Handle -> m a) -> m a
withFileInDirectory DirFd
dirFd [Char]
filePath IOMode
ReadMode forall a b. (a -> b) -> a -> b
$ \Handle
fileHandle ->
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
        [Char] -> Handle -> IO ()
fsyncFileHandle [Char]
"ensureFileDurablePosix" Handle
fileHandle
        -- NOTE: Here we are purposefully not fsyncing the directory if the file fails to fsync
        [Char] -> DirFd -> IO ()
fsyncDirectoryFd [Char]
"ensureFileDurablePosix" DirFd
dirFd



-- | See `withBinaryFileDurable`
withBinaryFileDurable ::
     MonadUnliftIO m => FilePath -> IOMode -> (Handle -> m r) -> m r
withBinaryFileDurable :: forall (m :: * -> *) a.
MonadUnliftIO m =>
[Char] -> IOMode -> (Handle -> m a) -> m a
withBinaryFileDurable [Char]
filePath IOMode
iomode Handle -> m r
action =
  case IOMode
iomode of
    IOMode
ReadMode
      -- We do not need to consider durable operations when we are in a
      -- 'ReadMode', so we can use a regular `withBinaryFile`
     -> forall (m :: * -> *) a.
MonadUnliftIO m =>
[Char] -> IOMode -> (Handle -> m a) -> m a
withBinaryFile [Char]
filePath IOMode
iomode Handle -> m r
action
    IOMode
_ {- WriteMode,  ReadWriteMode,  AppendMode -}
     ->
      forall (m :: * -> *) a.
MonadUnliftIO m =>
[Char] -> (DirFd -> m a) -> m a
withDirectory (ShowS
takeDirectory [Char]
filePath) forall a b. (a -> b) -> a -> b
$ \DirFd
dirFd ->
        forall (m :: * -> *) a.
MonadUnliftIO m =>
DirFd -> [Char] -> IOMode -> (Handle -> m a) -> m a
withFileInDirectory DirFd
dirFd [Char]
filePath IOMode
iomode forall a b. (a -> b) -> a -> b
$ \Handle
tmpFileHandle -> do
          r
res <- Handle -> m r
action Handle
tmpFileHandle
          forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
            [Char] -> Handle -> IO ()
fsyncFileHandle [Char]
"withBinaryFileDurablePosix" Handle
tmpFileHandle
            -- NOTE: Here we are purposefully not fsyncing the directory if the file fails to fsync
            [Char] -> DirFd -> IO ()
fsyncDirectoryFd [Char]
"withBinaryFileDurablePosix" DirFd
dirFd
          forall (f :: * -> *) a. Applicative f => a -> f a
pure r
res

-- | See `withBinaryFileDurableAtomic`
withBinaryFileDurableAtomic ::
     MonadUnliftIO m => FilePath -> IOMode -> (Handle -> m r) -> m r
withBinaryFileDurableAtomic :: forall (m :: * -> *) a.
MonadUnliftIO m =>
[Char] -> IOMode -> (Handle -> m a) -> m a
withBinaryFileDurableAtomic [Char]
filePath IOMode
iomode Handle -> m r
action =
  case IOMode
iomode of
    IOMode
ReadMode
      -- We do not need to consider an atomic operation when we are in a
      -- 'ReadMode', so we can use a regular `withBinaryFile`
     -> forall (m :: * -> *) a.
MonadUnliftIO m =>
[Char] -> IOMode -> (Handle -> m a) -> m a
withBinaryFile [Char]
filePath IOMode
iomode Handle -> m r
action
    IOMode
_ {- WriteMode,  ReadWriteMode,  AppendMode -}
     ->
      forall (m :: * -> *) a.
MonadUnliftIO m =>
[Char] -> (DirFd -> m a) -> m a
withDirectory (ShowS
takeDirectory [Char]
filePath) forall a b. (a -> b) -> a -> b
$ \DirFd
dirFd -> do
        Maybe r
mRes <- forall (m :: * -> *) a.
MonadUnliftIO m =>
Maybe DirFd -> [Char] -> IOMode -> (Handle -> m a) -> m (Maybe a)
withAnonymousBinaryTempFileFor (forall a. a -> Maybe a
Just DirFd
dirFd) [Char]
filePath IOMode
iomode forall a b. (a -> b) -> a -> b
$
          DirFd -> Maybe [Char] -> Handle -> m r
durableAtomicAction DirFd
dirFd forall a. Maybe a
Nothing
        case Maybe r
mRes of
          Just r
res -> forall (f :: * -> *) a. Applicative f => a -> f a
pure r
res
          Maybe r
Nothing ->
            forall (m :: * -> *) a.
MonadUnliftIO m =>
Maybe DirFd -> [Char] -> IOMode -> ([Char] -> Handle -> m a) -> m a
withNonAnonymousBinaryTempFileFor (forall a. a -> Maybe a
Just DirFd
dirFd) [Char]
filePath IOMode
iomode forall a b. (a -> b) -> a -> b
$ \[Char]
tmpFilePath ->
              DirFd -> Maybe [Char] -> Handle -> m r
durableAtomicAction DirFd
dirFd (forall a. a -> Maybe a
Just [Char]
tmpFilePath)
  where
    durableAtomicAction :: DirFd -> Maybe [Char] -> Handle -> m r
durableAtomicAction DirFd
dirFd Maybe [Char]
mTmpFilePath Handle
tmpFileHandle = do
      Maybe CMode
mFileMode <- forall (f :: * -> *).
MonadUnliftIO f =>
IOMode -> [Char] -> Handle -> f (Maybe CMode)
copyFileHandle IOMode
iomode [Char]
filePath Handle
tmpFileHandle
      r
res <- Handle -> m r
action Handle
tmpFileHandle
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
        DirFd -> Maybe CMode -> Handle -> Maybe [Char] -> [Char] -> IO ()
atomicDurableTempFileRename
          DirFd
dirFd
          Maybe CMode
mFileMode
          Handle
tmpFileHandle
          Maybe [Char]
mTmpFilePath
          [Char]
filePath
      forall (f :: * -> *) a. Applicative f => a -> f a
pure r
res

-- | See `withBinaryFileAtomic`
withBinaryFileAtomic ::
     MonadUnliftIO m => FilePath -> IOMode -> (Handle -> m r) -> m r
withBinaryFileAtomic :: forall (m :: * -> *) a.
MonadUnliftIO m =>
[Char] -> IOMode -> (Handle -> m a) -> m a
withBinaryFileAtomic [Char]
filePath IOMode
iomode Handle -> m r
action =
  case IOMode
iomode of
    IOMode
ReadMode
      -- We do not need to consider an atomic operation when we are in a
      -- 'ReadMode', so we can use a regular `withBinaryFile`
     -> forall (m :: * -> *) a.
MonadUnliftIO m =>
[Char] -> IOMode -> (Handle -> m a) -> m a
withBinaryFile [Char]
filePath IOMode
iomode Handle -> m r
action
    IOMode
_ {- WriteMode,  ReadWriteMode,  AppendMode -}
     -> do
      Maybe r
mRes <-
        forall (m :: * -> *) a.
MonadUnliftIO m =>
Maybe DirFd -> [Char] -> IOMode -> (Handle -> m a) -> m (Maybe a)
withAnonymousBinaryTempFileFor forall a. Maybe a
Nothing [Char]
filePath IOMode
iomode forall a b. (a -> b) -> a -> b
$
        Maybe [Char] -> Handle -> m r
atomicAction forall a. Maybe a
Nothing
      case Maybe r
mRes of
        Just r
res -> forall (f :: * -> *) a. Applicative f => a -> f a
pure r
res
        Maybe r
Nothing ->
          forall (m :: * -> *) a.
MonadUnliftIO m =>
Maybe DirFd -> [Char] -> IOMode -> ([Char] -> Handle -> m a) -> m a
withNonAnonymousBinaryTempFileFor forall a. Maybe a
Nothing [Char]
filePath IOMode
iomode forall a b. (a -> b) -> a -> b
$ \[Char]
tmpFilePath ->
            Maybe [Char] -> Handle -> m r
atomicAction (forall a. a -> Maybe a
Just [Char]
tmpFilePath)
  where
    atomicAction :: Maybe [Char] -> Handle -> m r
atomicAction Maybe [Char]
mTmpFilePath Handle
tmpFileHandle = do
      let eTmpFile :: Either Handle [Char]
eTmpFile = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left Handle
tmpFileHandle) forall a b. b -> Either a b
Right Maybe [Char]
mTmpFilePath
      Maybe CMode
mFileMode <- forall (f :: * -> *).
MonadUnliftIO f =>
IOMode -> [Char] -> Handle -> f (Maybe CMode)
copyFileHandle IOMode
iomode [Char]
filePath Handle
tmpFileHandle
      r
res <- Handle -> m r
action Handle
tmpFileHandle
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Maybe DirFd
-> Maybe CMode -> Either Handle [Char] -> [Char] -> IO ()
atomicTempFileRename forall a. Maybe a
Nothing Maybe CMode
mFileMode Either Handle [Char]
eTmpFile [Char]
filePath
      forall (f :: * -> *) a. Applicative f => a -> f a
pure r
res