{-# 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
newtype CFlag =
CFlag CInt
deriving (CFlag -> CFlag -> Bool
(CFlag -> CFlag -> Bool) -> (CFlag -> CFlag -> Bool) -> Eq CFlag
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 -> String
(Int -> CFlag -> ShowS)
-> (CFlag -> String) -> ([CFlag] -> ShowS) -> Show CFlag
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CFlag] -> ShowS
$cshowList :: [CFlag] -> ShowS
show :: CFlag -> String
$cshow :: CFlag -> String
showsPrec :: Int -> CFlag -> ShowS
$cshowsPrec :: Int -> CFlag -> ShowS
Show, Eq CFlag
CFlag
Eq CFlag
-> (CFlag -> CFlag -> CFlag)
-> (CFlag -> CFlag -> CFlag)
-> (CFlag -> CFlag -> CFlag)
-> (CFlag -> CFlag)
-> (CFlag -> Int -> CFlag)
-> (CFlag -> Int -> CFlag)
-> CFlag
-> (Int -> CFlag)
-> (CFlag -> Int -> CFlag)
-> (CFlag -> Int -> CFlag)
-> (CFlag -> Int -> CFlag)
-> (CFlag -> Int -> Bool)
-> (CFlag -> Maybe Int)
-> (CFlag -> Int)
-> (CFlag -> Bool)
-> (CFlag -> Int -> CFlag)
-> (CFlag -> Int -> CFlag)
-> (CFlag -> Int -> CFlag)
-> (CFlag -> Int -> CFlag)
-> (CFlag -> Int -> CFlag)
-> (CFlag -> Int -> CFlag)
-> (CFlag -> Int)
-> Bits 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
$cp1Bits :: Eq 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
foreign import ccall unsafe "file-posix.c unliftio_o_tmpfile" o_TMPFILE :: CFlag
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
(CAt -> CAt -> Bool) -> (CAt -> CAt -> Bool) -> Eq CAt
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 -> String
(Int -> CAt -> ShowS)
-> (CAt -> String) -> ([CAt] -> ShowS) -> Show CAt
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CAt] -> ShowS
$cshowList :: [CAt] -> ShowS
show :: CAt -> String
$cshow :: CAt -> String
showsPrec :: Int -> CAt -> ShowS
$cshowsPrec :: Int -> CAt -> ShowS
Show, Eq CAt
CAt
Eq CAt
-> (CAt -> CAt -> CAt)
-> (CAt -> CAt -> CAt)
-> (CAt -> CAt -> CAt)
-> (CAt -> CAt)
-> (CAt -> Int -> CAt)
-> (CAt -> Int -> CAt)
-> CAt
-> (Int -> CAt)
-> (CAt -> Int -> CAt)
-> (CAt -> Int -> CAt)
-> (CAt -> Int -> CAt)
-> (CAt -> Int -> Bool)
-> (CAt -> Maybe Int)
-> (CAt -> Int)
-> (CAt -> Bool)
-> (CAt -> Int -> CAt)
-> (CAt -> Int -> CAt)
-> (CAt -> Int -> CAt)
-> (CAt -> Int -> CAt)
-> (CAt -> Int -> CAt)
-> (CAt -> Int -> CAt)
-> (CAt -> Int)
-> Bits 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
$cp1Bits :: Eq 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 = (DirFd -> CInt) -> (CAt -> CInt) -> Either DirFd CAt -> CInt
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Fd -> CInt
unFd (Fd -> CInt) -> (DirFd -> Fd) -> DirFd -> CInt
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 CFlag -> CFlag -> CFlag
forall a. Bits a => a -> a -> a
.|. CFlag
o_CREAT
read_flags :: CFlag
read_flags = CFlag
std_flags CFlag -> CFlag -> CFlag
forall a. Bits a => a -> a -> a
.|. CFlag
o_RDONLY
write_flags :: CFlag
write_flags = CFlag
output_flags CFlag -> CFlag -> CFlag
forall a. Bits a => a -> a -> a
.|. CFlag
o_WRONLY
rw_flags :: CFlag
rw_flags = CFlag
output_flags CFlag -> CFlag -> CFlag
forall a. Bits a => a -> a -> a
.|. CFlag
o_RDWR
append_flags :: CFlag
append_flags = CFlag
write_flags CFlag -> CFlag -> CFlag
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
}
openDir :: MonadIO m => FilePath -> m Fd
openDir :: String -> m Fd
openDir String
fp
=
IO Fd -> m Fd
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Fd -> m Fd) -> IO Fd -> m Fd
forall a b. (a -> b) -> a -> b
$
String -> (CFilePath -> IO Fd) -> IO Fd
forall a. String -> (CFilePath -> IO a) -> IO a
withFilePath String
fp ((CFilePath -> IO Fd) -> IO Fd) -> (CFilePath -> IO Fd) -> IO Fd
forall a b. (a -> b) -> a -> b
$ \CFilePath
cFp ->
CInt -> Fd
Fd (CInt -> Fd) -> IO CInt -> IO Fd
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
String -> IO CInt -> IO CInt
forall a. (Eq a, Num a) => String -> IO a -> IO a
throwErrnoIfMinus1Retry
String
"openDir"
(CFilePath -> CFlag -> CMode -> IO CInt
c_open CFilePath
cFp (IOMode -> CFlag
ioModeToFlags IOMode
ReadMode) CMode
0o660)
closeDirectory :: MonadIO m => DirFd -> m ()
closeDirectory :: DirFd -> m ()
closeDirectory (DirFd (Fd CInt
dirFd)) =
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
String -> IO CInt -> IO ()
forall a. (Eq a, Num a) => String -> IO a -> IO ()
throwErrnoIfMinus1Retry_ String
"closeDirectory" (IO CInt -> IO ()) -> IO CInt -> IO ()
forall a b. (a -> b) -> a -> b
$ CInt -> IO CInt
c_close CInt
dirFd
fsyncFileDescriptor
:: MonadIO m
=> String
-> Fd
-> m ()
fsyncFileDescriptor :: String -> Fd -> m ()
fsyncFileDescriptor String
name Fd
fd =
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IO CInt -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO CInt -> IO ()) -> IO CInt -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO CInt -> IO CInt
forall a. (Eq a, Num a) => String -> IO a -> IO a
throwErrnoIfMinus1 (String
"fsync - " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name) (IO CInt -> IO CInt) -> IO CInt -> IO CInt
forall a b. (a -> b) -> a -> b
$ Fd -> IO CInt
c_fsync Fd
fd
fsyncFileHandle :: String -> Handle -> IO ()
fsyncFileHandle :: String -> Handle -> IO ()
fsyncFileHandle String
fname Handle
hdl = Handle -> (Fd -> IO ()) -> IO ()
forall a. Handle -> (Fd -> IO a) -> IO a
withHandleFd Handle
hdl (String -> Fd -> IO ()
forall (m :: * -> *). MonadIO m => String -> Fd -> m ()
fsyncFileDescriptor (String
fname String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"/File"))
fsyncDirectoryFd :: String -> DirFd -> IO ()
fsyncDirectoryFd :: String -> DirFd -> IO ()
fsyncDirectoryFd String
fname = String -> Fd -> IO ()
forall (m :: * -> *). MonadIO m => String -> Fd -> m ()
fsyncFileDescriptor (String
fname String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"/Directory") (Fd -> IO ()) -> (DirFd -> Fd) -> DirFd -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DirFd -> Fd
unDirFd
openFileFromDir :: MonadIO m => DirFd -> FilePath -> IOMode -> m Handle
openFileFromDir :: DirFd -> String -> IOMode -> m Handle
openFileFromDir DirFd
dirFd filePath :: String
filePath@(ShowS
takeFileName -> String
fileName) IOMode
iomode =
IO Handle -> m Handle
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Handle -> m Handle) -> IO Handle -> m Handle
forall a b. (a -> b) -> a -> b
$
String -> (CFilePath -> IO Handle) -> IO Handle
forall a. String -> (CFilePath -> IO a) -> IO a
withFilePath String
fileName ((CFilePath -> IO Handle) -> IO Handle)
-> (CFilePath -> IO Handle) -> IO Handle
forall a b. (a -> b) -> a -> b
$ \CFilePath
cFileName ->
IO (FD, IODeviceType)
-> ((FD, IODeviceType) -> IO ())
-> ((FD, IODeviceType) -> IO Handle)
-> IO Handle
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracketOnError
(do CInt
fileFd <-
String -> IO CInt -> IO CInt
forall a. (Eq a, Num a) => String -> IO a -> IO a
throwErrnoIfMinus1Retry String
"openFileFromDir" (IO CInt -> IO CInt) -> IO CInt -> IO CInt
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
CInt
-> IOMode
-> Maybe (IODeviceType, CDev, CIno)
-> Bool
-> Bool
-> IO (FD, IODeviceType)
FD.mkFD
CInt
fileFd
IOMode
iomode
Maybe (IODeviceType, CDev, CIno)
forall a. Maybe a
Nothing
Bool
False
Bool
False
IO (FD, IODeviceType) -> IO CInt -> IO (FD, IODeviceType)
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`onException`
CInt -> IO CInt
c_close CInt
fileFd)
(IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ())
-> ((FD, IODeviceType) -> IO ()) -> (FD, IODeviceType) -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FD -> IO ()
forall a. IODevice a => a -> IO ()
Device.close (FD -> IO ())
-> ((FD, IODeviceType) -> FD) -> (FD, IODeviceType) -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FD, IODeviceType) -> FD
forall a b. (a, b) -> a
fst)
(\(FD
fD, IODeviceType
fd_type)
-> do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (IOMode
iomode IOMode -> IOMode -> Bool
forall a. Eq a => a -> a -> Bool
== IOMode
WriteMode Bool -> Bool -> Bool
&& IODeviceType
fd_type IODeviceType -> IODeviceType -> Bool
forall a. Eq a => a -> a -> Bool
== IODeviceType
RegularFile) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
FD -> Integer -> IO ()
forall a. IODevice a => a -> Integer -> IO ()
Device.setSize FD
fD Integer
0
FD
-> IODeviceType
-> String
-> IOMode
-> Bool
-> Maybe TextEncoding
-> IO Handle
HandleFD.mkHandleFromFD FD
fD IODeviceType
fd_type String
filePath IOMode
iomode Bool
False Maybe TextEncoding
forall a. Maybe a
Nothing)
openAnonymousTempFileFromDir ::
MonadIO m =>
Maybe DirFd
-> FilePath
-> IOMode
-> m Handle
openAnonymousTempFileFromDir :: Maybe DirFd -> String -> IOMode -> m Handle
openAnonymousTempFileFromDir Maybe DirFd
mDirFd String
filePath IOMode
iomode =
IO Handle -> m Handle
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Handle -> m Handle) -> IO Handle -> m Handle
forall a b. (a -> b) -> a -> b
$
case Maybe DirFd
mDirFd of
Just DirFd
dirFd -> String -> (CFilePath -> IO Handle) -> IO Handle
forall a. String -> (CFilePath -> IO a) -> IO a
withFilePath String
"." ((CFlag -> CMode -> IO CInt) -> IO Handle
openAnonymousWith ((CFlag -> CMode -> IO CInt) -> IO Handle)
-> (CFilePath -> CFlag -> CMode -> IO CInt)
-> CFilePath
-> IO Handle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DirFd -> CFilePath -> CFlag -> CMode -> IO CInt
c_openat DirFd
dirFd)
Maybe DirFd
Nothing ->
String -> (CFilePath -> IO Handle) -> IO Handle
forall a. String -> (CFilePath -> IO a) -> IO a
withFilePath (ShowS
takeDirectory String
filePath) ((CFlag -> CMode -> IO CInt) -> IO Handle
openAnonymousWith ((CFlag -> CMode -> IO CInt) -> IO Handle)
-> (CFilePath -> CFlag -> CMode -> IO CInt)
-> CFilePath
-> IO Handle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CFilePath -> CFlag -> CMode -> IO CInt
c_open)
where
fdName :: String
fdName = String
"openAnonymousTempFileFromDir - " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
filePath
ioModeToTmpFlags :: IOMode -> CFlag
ioModeToTmpFlags :: IOMode -> CFlag
ioModeToTmpFlags =
\case
IOMode
ReadMode -> CFlag
o_RDWR
IOMode
ReadWriteMode -> CFlag
o_RDWR
IOMode
_ -> CFlag
o_WRONLY
openAnonymousWith :: (CFlag -> CMode -> IO CInt) -> IO Handle
openAnonymousWith CFlag -> CMode -> IO CInt
fopen =
IO (FD, IODeviceType)
-> ((FD, IODeviceType) -> IO ())
-> ((FD, IODeviceType) -> IO Handle)
-> IO Handle
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracketOnError
(do CInt
fileFd <-
String -> IO CInt -> IO CInt
forall a. (Eq a, Num a) => String -> IO a -> IO a
throwErrnoIfMinus1Retry String
"openAnonymousTempFileFromDir" (IO CInt -> IO CInt) -> IO CInt -> IO CInt
forall a b. (a -> b) -> a -> b
$
CFlag -> CMode -> IO CInt
fopen (CFlag
o_TMPFILE CFlag -> CFlag -> CFlag
forall a. Bits a => a -> a -> a
.|. IOMode -> CFlag
ioModeToTmpFlags IOMode
iomode) (CMode
s_IRUSR CMode -> CMode -> CMode
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
Maybe (IODeviceType, CDev, CIno)
forall a. Maybe a
Nothing
Bool
False
Bool
False
IO (FD, IODeviceType) -> IO CInt -> IO (FD, IODeviceType)
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`onException`
CInt -> IO CInt
c_close CInt
fileFd)
(IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ())
-> ((FD, IODeviceType) -> IO ()) -> (FD, IODeviceType) -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FD -> IO ()
forall a. IODevice a => a -> IO ()
Device.close (FD -> IO ())
-> ((FD, IODeviceType) -> FD) -> (FD, IODeviceType) -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FD, IODeviceType) -> FD
forall a b. (a, b) -> a
fst)
(\(FD
fD, IODeviceType
fd_type) ->
FD
-> IODeviceType
-> String
-> IOMode
-> Bool
-> Maybe TextEncoding
-> IO Handle
HandleFD.mkHandleFromFD FD
fD IODeviceType
fd_type String
fdName IOMode
iomode Bool
False Maybe TextEncoding
forall a. Maybe a
Nothing)
atomicDurableTempFileRename ::
DirFd -> Maybe FileMode -> Handle -> Maybe FilePath -> FilePath -> IO ()
atomicDurableTempFileRename :: DirFd -> Maybe CMode -> Handle -> Maybe String -> String -> IO ()
atomicDurableTempFileRename DirFd
dirFd Maybe CMode
mFileMode Handle
tmpFileHandle Maybe String
mTmpFilePath String
filePath = do
String -> Handle -> IO ()
fsyncFileHandle String
"atomicDurableTempFileCreate" Handle
tmpFileHandle
let eTmpFile :: Either Handle String
eTmpFile = Either Handle String
-> (String -> Either Handle String)
-> Maybe String
-> Either Handle String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Handle -> Either Handle String
forall a b. a -> Either a b
Left Handle
tmpFileHandle) String -> Either Handle String
forall a b. b -> Either a b
Right Maybe String
mTmpFilePath
Maybe DirFd
-> Maybe CMode -> Either Handle String -> String -> IO ()
atomicTempFileRename (DirFd -> Maybe DirFd
forall a. a -> Maybe a
Just DirFd
dirFd) Maybe CMode
mFileMode Either Handle String
eTmpFile String
filePath
Handle -> IO ()
forall (m :: * -> *). MonadIO m => Handle -> m ()
hClose Handle
tmpFileHandle
String -> DirFd -> IO ()
fsyncDirectoryFd String
"atomicDurableTempFileCreate" DirFd
dirFd
atomicTempFileCreate ::
Maybe DirFd
-> Maybe FileMode
-> Handle
-> FilePath
-> IO ()
atomicTempFileCreate :: Maybe DirFd -> Maybe CMode -> Handle -> String -> IO ()
atomicTempFileCreate Maybe DirFd
mDirFd Maybe CMode
mFileMode Handle
tmpFileHandle String
filePath =
Handle -> (Fd -> IO ()) -> IO ()
forall a. Handle -> (Fd -> IO a) -> IO a
withHandleFd Handle
tmpFileHandle ((Fd -> IO ()) -> IO ()) -> (Fd -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \fd :: Fd
fd@(Fd CInt
cFd) ->
String -> (CFilePath -> IO ()) -> IO ()
forall a. String -> (CFilePath -> IO a) -> IO a
withFilePath (String
"/proc/self/fd/" String -> ShowS
forall a. [a] -> [a] -> [a]
++ CInt -> String
forall a. Show a => a -> String
show CInt
cFd) ((CFilePath -> IO ()) -> IO ()) -> (CFilePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \CFilePath
cFromFilePath ->
String -> (CFilePath -> IO ()) -> IO ()
forall a. String -> (CFilePath -> IO a) -> IO a
withFilePath String
filePathName ((CFilePath -> IO ()) -> IO ()) -> (CFilePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \CFilePath
cToFilePath -> do
let fileMode :: CMode
fileMode = CMode -> Maybe CMode -> CMode
forall a. a -> Maybe a -> a
fromMaybe CMode
Posix.stdFileMode Maybe CMode
mFileMode
Fd -> CMode -> IO ()
Posix.setFdMode Fd
fd CMode
fileMode
let safeLink :: String -> CFilePath -> IO ()
safeLink String
which CFilePath
to =
String -> IO CInt -> IO ()
forall a. (Eq a, Num a) => String -> IO a -> IO ()
throwErrnoIfMinus1Retry_
(String
"atomicFileCreate - c_safe_linkat - " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
which) (IO CInt -> IO ()) -> IO CInt -> IO ()
forall a b. (a -> b) -> a -> b
$
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 <-
(IOError -> Maybe ()) -> IO () -> IO (Either () ())
forall (m :: * -> *) e b a.
(MonadUnliftIO m, Exception e) =>
(e -> Maybe b) -> m a -> m (Either b a)
tryJust (Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> (IOError -> Bool) -> IOError -> Maybe ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> Bool
isAlreadyExistsError) (IO () -> IO (Either () ())) -> IO () -> IO (Either () ())
forall a b. (a -> b) -> a -> b
$
String -> CFilePath -> IO ()
safeLink String
"anonymous" CFilePath
cToFilePath
case Either () ()
eExc of
Right () -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Left () ->
String -> (String -> Handle -> IO ()) -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
String -> (String -> Handle -> m a) -> m a
withBinaryTempFileFor String
filePath ((String -> Handle -> IO ()) -> IO ())
-> (String -> Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \String
visTmpFileName Handle
visTmpFileHandle -> do
Handle -> IO ()
forall (m :: * -> *). MonadIO m => Handle -> m ()
hClose Handle
visTmpFileHandle
String -> IO ()
removeFile String
visTmpFileName
case Maybe DirFd
mDirFd of
Maybe DirFd
Nothing -> do
String -> (CFilePath -> IO ()) -> IO ()
forall a. String -> (CFilePath -> IO a) -> IO a
withFilePath String
visTmpFileName (String -> CFilePath -> IO ()
safeLink String
"visible")
String -> String -> IO ()
Posix.rename String
visTmpFileName String
filePath
Just DirFd
dirFd ->
String -> (CFilePath -> IO ()) -> IO ()
forall a. String -> (CFilePath -> IO a) -> IO a
withFilePath (ShowS
takeFileName String
visTmpFileName) ((CFilePath -> IO ()) -> IO ()) -> (CFilePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \CFilePath
cVisTmpFile -> do
String -> CFilePath -> IO ()
safeLink String
"visible" CFilePath
cVisTmpFile
String -> IO CInt -> IO ()
forall a. (Eq a, Num a) => String -> IO a -> IO ()
throwErrnoIfMinus1Retry_
String
"atomicFileCreate - c_safe_renameat" (IO CInt -> IO ()) -> IO CInt -> IO ()
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, String
filePathName) =
case Maybe DirFd
mDirFd of
Maybe DirFd
Nothing -> (CAt -> Either DirFd CAt
forall a b. b -> Either a b
Right CAt
at_FDCWD, String
filePath)
Just DirFd
dirFd -> (DirFd -> Either DirFd CAt
forall a b. a -> Either a b
Left DirFd
dirFd, ShowS
takeFileName String
filePath)
atomicTempFileRename ::
Maybe DirFd
-> Maybe FileMode
-> Either Handle FilePath
-> FilePath
-> IO ()
atomicTempFileRename :: Maybe DirFd
-> Maybe CMode -> Either Handle String -> String -> IO ()
atomicTempFileRename Maybe DirFd
mDirFd Maybe CMode
mFileMode Either Handle String
eTmpFile String
filePath =
case Either Handle String
eTmpFile of
Left Handle
tmpFileHandle ->
Maybe DirFd -> Maybe CMode -> Handle -> String -> IO ()
atomicTempFileCreate Maybe DirFd
mDirFd Maybe CMode
mFileMode Handle
tmpFileHandle String
filePath
Right String
tmpFilePath -> do
Maybe CMode -> (CMode -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe CMode
mFileMode ((CMode -> IO ()) -> IO ()) -> (CMode -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \CMode
fileMode -> String -> CMode -> IO ()
Posix.setFileMode String
tmpFilePath CMode
fileMode
case Maybe DirFd
mDirFd of
Maybe DirFd
Nothing -> String -> String -> IO ()
Posix.rename String
tmpFilePath String
filePath
Just DirFd
dirFd ->
String -> (CFilePath -> IO ()) -> IO ()
forall a. String -> (CFilePath -> IO a) -> IO a
withFilePath (ShowS
takeFileName String
filePath) ((CFilePath -> IO ()) -> IO ()) -> (CFilePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \CFilePath
cToFilePath ->
String -> (CFilePath -> IO ()) -> IO ()
forall a. String -> (CFilePath -> IO a) -> IO a
withFilePath (ShowS
takeFileName String
tmpFilePath) ((CFilePath -> IO ()) -> IO ()) -> (CFilePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \CFilePath
cTmpFilePath ->
String -> IO CInt -> IO ()
forall a. (Eq a, Num a) => String -> IO a -> IO ()
throwErrnoIfMinus1Retry_ String
"atomicFileCreate - c_safe_renameat" (IO CInt -> IO ()) -> IO CInt -> IO ()
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 :: String -> (DirFd -> m a) -> m a
withDirectory String
dirPath = m DirFd -> (DirFd -> m ()) -> (DirFd -> m a) -> m a
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket (Fd -> DirFd
DirFd (Fd -> DirFd) -> m Fd -> m DirFd
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> m Fd
forall (m :: * -> *). MonadIO m => String -> m Fd
openDir String
dirPath) DirFd -> m ()
forall (m :: * -> *). MonadIO m => DirFd -> m ()
closeDirectory
withFileInDirectory ::
MonadUnliftIO m => DirFd -> FilePath -> IOMode -> (Handle -> m a) -> m a
withFileInDirectory :: DirFd -> String -> IOMode -> (Handle -> m a) -> m a
withFileInDirectory DirFd
dirFd String
filePath IOMode
iomode =
m Handle -> (Handle -> m ()) -> (Handle -> m a) -> m a
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket (DirFd -> String -> IOMode -> m Handle
forall (m :: * -> *).
MonadIO m =>
DirFd -> String -> IOMode -> m Handle
openFileFromDir DirFd
dirFd String
filePath IOMode
iomode) Handle -> m ()
forall (m :: * -> *). MonadIO m => Handle -> m ()
hClose
withBinaryTempFileFor ::
MonadUnliftIO m
=> FilePath
-> (FilePath -> Handle -> m a)
-> m a
withBinaryTempFileFor :: String -> (String -> Handle -> m a) -> m a
withBinaryTempFileFor String
filePath String -> Handle -> m a
action =
m (String, Handle)
-> ((String, Handle) -> m (Either IOError ()))
-> ((String, Handle) -> m a)
-> m a
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracketOnError
(IO (String, Handle) -> m (String, Handle)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> String -> IO (String, Handle)
openBinaryTempFile String
dirPath String
tmpFileName))
(\(String
tmpFilePath, Handle
tmpFileHandle) ->
Handle -> m ()
forall (m :: * -> *). MonadIO m => Handle -> m ()
hClose Handle
tmpFileHandle m () -> m (Either IOError ()) -> m (Either IOError ())
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO (Either IOError ()) -> m (Either IOError ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO (Either IOError ())
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either IOError a)
tryIO (String -> IO ()
removeFile String
tmpFilePath)))
((String -> Handle -> m a) -> (String, Handle) -> m a
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry String -> Handle -> m a
action)
where
dirPath :: String
dirPath = ShowS
takeDirectory String
filePath
fileName :: String
fileName = ShowS
takeFileName String
filePath
tmpFileName :: String
tmpFileName = String
"." String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
fileName String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
".tmp"
withAnonymousBinaryTempFileFor ::
MonadUnliftIO m
=> Maybe DirFd
-> FilePath
-> IOMode
-> (Handle -> m a)
-> m (Maybe a)
withAnonymousBinaryTempFileFor :: Maybe DirFd -> String -> IOMode -> (Handle -> m a) -> m (Maybe a)
withAnonymousBinaryTempFileFor Maybe DirFd
mDirFd String
filePath IOMode
iomode Handle -> m a
action
| CFlag
o_TMPFILE CFlag -> CFlag -> Bool
forall a. Eq a => a -> a -> Bool
== CFlag
o_TMPFILE_not_supported = Maybe a -> m (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
| Bool
otherwise =
m a -> m (Maybe a)
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Maybe a)
trySupported (m a -> m (Maybe a)) -> m a -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$
m Handle -> (Handle -> m ()) -> (Handle -> m a) -> m a
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket (Maybe DirFd -> String -> IOMode -> m Handle
forall (m :: * -> *).
MonadIO m =>
Maybe DirFd -> String -> IOMode -> m Handle
openAnonymousTempFileFromDir Maybe DirFd
mDirFd String
filePath IOMode
iomode) Handle -> m ()
forall (m :: * -> *). MonadIO m => Handle -> m ()
hClose Handle -> m a
action
where
trySupported :: m a -> m (Maybe a)
trySupported m a
m =
m a -> m (Either IOError a)
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either IOError a)
tryIO m a
m m (Either IOError a)
-> (Either IOError a -> m (Maybe a)) -> m (Maybe a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Right a
res -> Maybe a -> m (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> m (Maybe a)) -> Maybe a -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
res
Left IOError
exc
| IOError -> IOErrorType
ioeGetErrorType IOError
exc IOErrorType -> IOErrorType -> Bool
forall a. Eq a => a -> a -> Bool
== IOErrorType
UnsupportedOperation -> Maybe a -> m (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
Left IOError
exc -> IOError -> m (Maybe a)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO IOError
exc
withNonAnonymousBinaryTempFileFor ::
MonadUnliftIO m
=> Maybe DirFd
-> FilePath
-> IOMode
-> (FilePath -> Handle -> m a)
-> m a
withNonAnonymousBinaryTempFileFor :: Maybe DirFd -> String -> IOMode -> (String -> Handle -> m a) -> m a
withNonAnonymousBinaryTempFileFor Maybe DirFd
mDirFd String
filePath IOMode
iomode String -> Handle -> m a
action =
String -> (String -> Handle -> m a) -> m a
forall (m :: * -> *) a.
MonadUnliftIO m =>
String -> (String -> Handle -> m a) -> m a
withBinaryTempFileFor String
filePath ((String -> Handle -> m a) -> m a)
-> (String -> Handle -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \String
tmpFilePath Handle
tmpFileHandle -> do
Handle -> m ()
forall (m :: * -> *). MonadIO m => Handle -> m ()
hClose Handle
tmpFileHandle
case Maybe DirFd
mDirFd of
Maybe DirFd
Nothing -> String -> IOMode -> (Handle -> m a) -> m a
forall (m :: * -> *) a.
MonadUnliftIO m =>
String -> IOMode -> (Handle -> m a) -> m a
withBinaryFile String
tmpFilePath IOMode
iomode (String -> Handle -> m a
action String
tmpFilePath)
Just DirFd
dirFd -> DirFd -> String -> IOMode -> (Handle -> m a) -> m a
forall (m :: * -> *) a.
MonadUnliftIO m =>
DirFd -> String -> IOMode -> (Handle -> m a) -> m a
withFileInDirectory DirFd
dirFd String
tmpFilePath IOMode
iomode (String -> Handle -> m a
action String
tmpFilePath)
copyFileHandle ::
MonadUnliftIO f => IOMode -> FilePath -> Handle -> f (Maybe FileMode)
copyFileHandle :: IOMode -> String -> Handle -> f (Maybe CMode)
copyFileHandle IOMode
iomode String
fromFilePath Handle
toHandle =
(() -> Maybe CMode)
-> (CMode -> Maybe CMode) -> Either () CMode -> Maybe CMode
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe CMode -> () -> Maybe CMode
forall a b. a -> b -> a
const Maybe CMode
forall a. Maybe a
Nothing) CMode -> Maybe CMode
forall a. a -> Maybe a
Just (Either () CMode -> Maybe CMode)
-> f (Either () CMode) -> f (Maybe CMode)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
(IOError -> Maybe ()) -> f CMode -> f (Either () CMode)
forall (m :: * -> *) e b a.
(MonadUnliftIO m, Exception e) =>
(e -> Maybe b) -> m a -> m (Either b a)
tryJust
(Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> (IOError -> Bool) -> IOError -> Maybe ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> Bool
isDoesNotExistError)
(do FileStatus
fileStatus <- IO FileStatus -> f FileStatus
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FileStatus -> f FileStatus) -> IO FileStatus -> f FileStatus
forall a b. (a -> b) -> a -> b
$ String -> IO FileStatus
Posix.getFileStatus String
fromFilePath
Bool -> f () -> f ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (IOMode
iomode IOMode -> IOMode -> Bool
forall a. Eq a => a -> a -> Bool
== IOMode
WriteMode) (f () -> f ()) -> f () -> f ()
forall a b. (a -> b) -> a -> b
$ do
String -> IOMode -> (Handle -> f ()) -> f ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
String -> IOMode -> (Handle -> m a) -> m a
withBinaryFile String
fromFilePath IOMode
ReadMode (Handle -> Handle -> f ()
forall (m :: * -> *). MonadIO m => Handle -> Handle -> m ()
`copyHandleData` Handle
toHandle)
Bool -> f () -> f ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (IOMode
iomode IOMode -> IOMode -> Bool
forall a. Eq a => a -> a -> Bool
== IOMode
AppendMode) (f () -> f ()) -> f () -> f ()
forall a b. (a -> b) -> a -> b
$ Handle -> SeekMode -> Integer -> f ()
forall (m :: * -> *).
MonadIO m =>
Handle -> SeekMode -> Integer -> m ()
hSeek Handle
toHandle SeekMode
AbsoluteSeek Integer
0
CMode -> f CMode
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CMode -> f CMode) -> CMode -> f CMode
forall a b. (a -> b) -> a -> b
$ FileStatus -> CMode
Posix.fileMode FileStatus
fileStatus)
copyHandleData :: MonadIO m => Handle -> Handle -> m ()
copyHandleData :: Handle -> Handle -> m ()
copyHandleData Handle
hFrom Handle
hTo = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> (Ptr Any -> IO ()) -> IO ()
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
bufferSize Ptr Any -> IO ()
forall a. Ptr a -> IO ()
go
where
bufferSize :: Int
bufferSize = Int
131072
go :: Ptr a -> IO ()
go Ptr a
buffer = do
Int
count <- Handle -> Ptr a -> Int -> IO Int
forall a. Handle -> Ptr a -> Int -> IO Int
hGetBuf Handle
hFrom Ptr a
buffer Int
bufferSize
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
count Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Handle -> Ptr a -> Int -> IO ()
forall a. Handle -> Ptr a -> Int -> IO ()
hPutBuf Handle
hTo Ptr a
buffer Int
count
Ptr a -> IO ()
go Ptr a
buffer
withHandleFd :: Handle -> (Fd -> IO a) -> IO a
withHandleFd :: Handle -> (Fd -> IO a) -> IO a
withHandleFd Handle
h Fd -> IO a
cb =
case Handle
h of
HandleFD.FileHandle String
_ MVar Handle__
mv ->
MVar Handle__ -> (Handle__ -> IO a) -> IO a
forall (m :: * -> *) a b.
MonadUnliftIO m =>
MVar a -> (a -> m b) -> m b
withMVar MVar Handle__
mv ((Handle__ -> IO a) -> IO a) -> (Handle__ -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \HandleFD.Handle__{haDevice :: ()
HandleFD.haDevice = dev
dev} ->
case dev -> Maybe FD
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast dev
dev of
Just FD
fd -> Fd -> IO a
cb (Fd -> IO a) -> Fd -> IO a
forall a b. (a -> b) -> a -> b
$ CInt -> Fd
Fd (CInt -> Fd) -> CInt -> Fd
forall a b. (a -> b) -> a -> b
$ FD -> CInt
FD.fdFD FD
fd
Maybe FD
Nothing -> String -> IO a
forall a. HasCallStack => String -> a
error String
"withHandleFd: not a file handle"
HandleFD.DuplexHandle {} -> String -> IO a
forall a. HasCallStack => String -> a
error String
"withHandleFd: not a file handle"
ensureFileDurable :: MonadIO m => FilePath -> m ()
ensureFileDurable :: String -> m ()
ensureFileDurable String
filePath =
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
String -> (DirFd -> IO ()) -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
String -> (DirFd -> m a) -> m a
withDirectory (ShowS
takeDirectory String
filePath) ((DirFd -> IO ()) -> IO ()) -> (DirFd -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \DirFd
dirFd ->
DirFd -> String -> IOMode -> (Handle -> IO ()) -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
DirFd -> String -> IOMode -> (Handle -> m a) -> m a
withFileInDirectory DirFd
dirFd String
filePath IOMode
ReadMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
fileHandle ->
IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
String -> Handle -> IO ()
fsyncFileHandle String
"ensureFileDurablePosix" Handle
fileHandle
String -> DirFd -> IO ()
fsyncDirectoryFd String
"ensureFileDurablePosix" DirFd
dirFd
withBinaryFileDurable ::
MonadUnliftIO m => FilePath -> IOMode -> (Handle -> m r) -> m r
withBinaryFileDurable :: String -> IOMode -> (Handle -> m r) -> m r
withBinaryFileDurable String
filePath IOMode
iomode Handle -> m r
action =
case IOMode
iomode of
IOMode
ReadMode
-> String -> IOMode -> (Handle -> m r) -> m r
forall (m :: * -> *) a.
MonadUnliftIO m =>
String -> IOMode -> (Handle -> m a) -> m a
withBinaryFile String
filePath IOMode
iomode Handle -> m r
action
IOMode
_
->
String -> (DirFd -> m r) -> m r
forall (m :: * -> *) a.
MonadUnliftIO m =>
String -> (DirFd -> m a) -> m a
withDirectory (ShowS
takeDirectory String
filePath) ((DirFd -> m r) -> m r) -> (DirFd -> m r) -> m r
forall a b. (a -> b) -> a -> b
$ \DirFd
dirFd ->
DirFd -> String -> IOMode -> (Handle -> m r) -> m r
forall (m :: * -> *) a.
MonadUnliftIO m =>
DirFd -> String -> IOMode -> (Handle -> m a) -> m a
withFileInDirectory DirFd
dirFd String
filePath IOMode
iomode ((Handle -> m r) -> m r) -> (Handle -> m r) -> m r
forall a b. (a -> b) -> a -> b
$ \Handle
tmpFileHandle -> do
r
res <- Handle -> m r
action Handle
tmpFileHandle
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
String -> Handle -> IO ()
fsyncFileHandle String
"withBinaryFileDurablePosix" Handle
tmpFileHandle
String -> DirFd -> IO ()
fsyncDirectoryFd String
"withBinaryFileDurablePosix" DirFd
dirFd
r -> m r
forall (f :: * -> *) a. Applicative f => a -> f a
pure r
res
withBinaryFileDurableAtomic ::
MonadUnliftIO m => FilePath -> IOMode -> (Handle -> m r) -> m r
withBinaryFileDurableAtomic :: String -> IOMode -> (Handle -> m r) -> m r
withBinaryFileDurableAtomic String
filePath IOMode
iomode Handle -> m r
action =
case IOMode
iomode of
IOMode
ReadMode
-> String -> IOMode -> (Handle -> m r) -> m r
forall (m :: * -> *) a.
MonadUnliftIO m =>
String -> IOMode -> (Handle -> m a) -> m a
withBinaryFile String
filePath IOMode
iomode Handle -> m r
action
IOMode
_
->
String -> (DirFd -> m r) -> m r
forall (m :: * -> *) a.
MonadUnliftIO m =>
String -> (DirFd -> m a) -> m a
withDirectory (ShowS
takeDirectory String
filePath) ((DirFd -> m r) -> m r) -> (DirFd -> m r) -> m r
forall a b. (a -> b) -> a -> b
$ \DirFd
dirFd -> do
Maybe r
mRes <- Maybe DirFd -> String -> IOMode -> (Handle -> m r) -> m (Maybe r)
forall (m :: * -> *) a.
MonadUnliftIO m =>
Maybe DirFd -> String -> IOMode -> (Handle -> m a) -> m (Maybe a)
withAnonymousBinaryTempFileFor (DirFd -> Maybe DirFd
forall a. a -> Maybe a
Just DirFd
dirFd) String
filePath IOMode
iomode ((Handle -> m r) -> m (Maybe r)) -> (Handle -> m r) -> m (Maybe r)
forall a b. (a -> b) -> a -> b
$
DirFd -> Maybe String -> Handle -> m r
durableAtomicAction DirFd
dirFd Maybe String
forall a. Maybe a
Nothing
case Maybe r
mRes of
Just r
res -> r -> m r
forall (f :: * -> *) a. Applicative f => a -> f a
pure r
res
Maybe r
Nothing ->
Maybe DirFd -> String -> IOMode -> (String -> Handle -> m r) -> m r
forall (m :: * -> *) a.
MonadUnliftIO m =>
Maybe DirFd -> String -> IOMode -> (String -> Handle -> m a) -> m a
withNonAnonymousBinaryTempFileFor (DirFd -> Maybe DirFd
forall a. a -> Maybe a
Just DirFd
dirFd) String
filePath IOMode
iomode ((String -> Handle -> m r) -> m r)
-> (String -> Handle -> m r) -> m r
forall a b. (a -> b) -> a -> b
$ \String
tmpFilePath ->
DirFd -> Maybe String -> Handle -> m r
durableAtomicAction DirFd
dirFd (String -> Maybe String
forall a. a -> Maybe a
Just String
tmpFilePath)
where
durableAtomicAction :: DirFd -> Maybe String -> Handle -> m r
durableAtomicAction DirFd
dirFd Maybe String
mTmpFilePath Handle
tmpFileHandle = do
Maybe CMode
mFileMode <- IOMode -> String -> Handle -> m (Maybe CMode)
forall (f :: * -> *).
MonadUnliftIO f =>
IOMode -> String -> Handle -> f (Maybe CMode)
copyFileHandle IOMode
iomode String
filePath Handle
tmpFileHandle
r
res <- Handle -> m r
action Handle
tmpFileHandle
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
DirFd -> Maybe CMode -> Handle -> Maybe String -> String -> IO ()
atomicDurableTempFileRename
DirFd
dirFd
Maybe CMode
mFileMode
Handle
tmpFileHandle
Maybe String
mTmpFilePath
String
filePath
r -> m r
forall (f :: * -> *) a. Applicative f => a -> f a
pure r
res
withBinaryFileAtomic ::
MonadUnliftIO m => FilePath -> IOMode -> (Handle -> m r) -> m r
withBinaryFileAtomic :: String -> IOMode -> (Handle -> m r) -> m r
withBinaryFileAtomic String
filePath IOMode
iomode Handle -> m r
action =
case IOMode
iomode of
IOMode
ReadMode
-> String -> IOMode -> (Handle -> m r) -> m r
forall (m :: * -> *) a.
MonadUnliftIO m =>
String -> IOMode -> (Handle -> m a) -> m a
withBinaryFile String
filePath IOMode
iomode Handle -> m r
action
IOMode
_
-> do
Maybe r
mRes <-
Maybe DirFd -> String -> IOMode -> (Handle -> m r) -> m (Maybe r)
forall (m :: * -> *) a.
MonadUnliftIO m =>
Maybe DirFd -> String -> IOMode -> (Handle -> m a) -> m (Maybe a)
withAnonymousBinaryTempFileFor Maybe DirFd
forall a. Maybe a
Nothing String
filePath IOMode
iomode ((Handle -> m r) -> m (Maybe r)) -> (Handle -> m r) -> m (Maybe r)
forall a b. (a -> b) -> a -> b
$
Maybe String -> Handle -> m r
atomicAction Maybe String
forall a. Maybe a
Nothing
case Maybe r
mRes of
Just r
res -> r -> m r
forall (f :: * -> *) a. Applicative f => a -> f a
pure r
res
Maybe r
Nothing ->
Maybe DirFd -> String -> IOMode -> (String -> Handle -> m r) -> m r
forall (m :: * -> *) a.
MonadUnliftIO m =>
Maybe DirFd -> String -> IOMode -> (String -> Handle -> m a) -> m a
withNonAnonymousBinaryTempFileFor Maybe DirFd
forall a. Maybe a
Nothing String
filePath IOMode
iomode ((String -> Handle -> m r) -> m r)
-> (String -> Handle -> m r) -> m r
forall a b. (a -> b) -> a -> b
$ \String
tmpFilePath ->
Maybe String -> Handle -> m r
atomicAction (String -> Maybe String
forall a. a -> Maybe a
Just String
tmpFilePath)
where
atomicAction :: Maybe String -> Handle -> m r
atomicAction Maybe String
mTmpFilePath Handle
tmpFileHandle = do
let eTmpFile :: Either Handle String
eTmpFile = Either Handle String
-> (String -> Either Handle String)
-> Maybe String
-> Either Handle String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Handle -> Either Handle String
forall a b. a -> Either a b
Left Handle
tmpFileHandle) String -> Either Handle String
forall a b. b -> Either a b
Right Maybe String
mTmpFilePath
Maybe CMode
mFileMode <- IOMode -> String -> Handle -> m (Maybe CMode)
forall (f :: * -> *).
MonadUnliftIO f =>
IOMode -> String -> Handle -> f (Maybe CMode)
copyFileHandle IOMode
iomode String
filePath Handle
tmpFileHandle
r
res <- Handle -> m r
action Handle
tmpFileHandle
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Maybe DirFd
-> Maybe CMode -> Either Handle String -> String -> IO ()
atomicTempFileRename Maybe DirFd
forall a. Maybe a
Nothing Maybe CMode
mFileMode Either Handle String
eTmpFile String
filePath
r -> m r
forall (f :: * -> *) a. Applicative f => a -> f a
pure r
res