{-# 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 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 fp :: CFilePath
fp (CFlag flags :: 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 fd :: CInt
fd)) fp :: CFilePath
fp (CFlag flags :: 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 fdFrom :: CInt
fdFrom)) cFpFrom :: CFilePath
cFpFrom (DirFd (Fd fdTo :: CInt
fdTo)) cFpTo :: 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 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
cat oldPath :: CFilePath
oldPath eNewDir :: Either DirFd CAt
eNewDir newPath :: CFilePath
newPath (CAt flags :: 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 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
iomode =
case IOMode
iomode of
ReadMode -> CFlag
read_flags
WriteMode -> CFlag
write_flags
ReadWriteMode -> CFlag
rw_flags
AppendMode -> CFlag
append_flags
newtype DirFd = DirFd
{ DirFd -> Fd
unDirFd :: Fd
}
openDir :: MonadIO m => FilePath -> m Fd
openDir :: String -> m Fd
openDir fp :: 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
$ \cFp :: 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
"openDir"
(CFilePath -> CFlag -> CMode -> IO CInt
c_open CFilePath
cFp (IOMode -> CFlag
ioModeToFlags IOMode
ReadMode) 0o660)
closeDirectory :: MonadIO m => DirFd -> m ()
closeDirectory :: DirFd -> m ()
closeDirectory (DirFd (Fd dirFd :: 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_ "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 name :: String
name fd :: 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 ("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 fname :: String
fname hdl :: 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]
++ "/File"))
fsyncDirectoryFd :: String -> DirFd -> IO ()
fsyncDirectoryFd :: String -> DirFd -> IO ()
fsyncDirectoryFd fname :: String
fname = String -> Fd -> IO ()
forall (m :: * -> *). MonadIO m => String -> Fd -> m ()
fsyncFileDescriptor (String
fname String -> ShowS
forall a. [a] -> [a] -> [a]
++ "/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
dirFd filePath :: String
filePath@(ShowS
takeFileName -> String
fileName) iomode :: 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
$ \cFileName :: 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 "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) 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
fD, fd_type :: 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 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 mDirFd :: Maybe DirFd
mDirFd filePath :: String
filePath iomode :: 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
dirFd -> String -> (CFilePath -> IO Handle) -> IO Handle
forall a. String -> (CFilePath -> IO a) -> IO a
withFilePath "." ((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)
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 = "openAnonymousTempFileFromDir - " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
filePath
ioModeToTmpFlags :: IOMode -> CFlag
ioModeToTmpFlags :: IOMode -> CFlag
ioModeToTmpFlags =
\case
ReadMode -> CFlag
o_RDWR
ReadWriteMode -> CFlag
o_RDWR
_ -> CFlag
o_WRONLY
openAnonymousWith :: (CFlag -> CMode -> IO CInt) -> IO Handle
openAnonymousWith fopen :: 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 "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
fD, fd_type :: 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
dirFd mFileMode :: Maybe CMode
mFileMode tmpFileHandle :: Handle
tmpFileHandle mTmpFilePath :: Maybe String
mTmpFilePath filePath :: String
filePath = do
String -> Handle -> IO ()
fsyncFileHandle "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 "atomicDurableTempFileCreate" DirFd
dirFd
atomicTempFileCreate ::
Maybe DirFd
-> Maybe FileMode
-> Handle
-> FilePath
-> IO ()
atomicTempFileCreate :: Maybe DirFd -> Maybe CMode -> Handle -> String -> IO ()
atomicTempFileCreate mDirFd :: Maybe DirFd
mDirFd mFileMode :: Maybe CMode
mFileMode tmpFileHandle :: Handle
tmpFileHandle filePath :: 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 cFd :: CInt
cFd) ->
String -> (CFilePath -> IO ()) -> IO ()
forall a. String -> (CFilePath -> IO a) -> IO a
withFilePath ("/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
$ \cFromFilePath :: 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
$ \cToFilePath :: 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 which :: String
which to :: CFilePath
to =
String -> IO CInt -> IO ()
forall a. (Eq a, Num a) => String -> IO a -> IO ()
throwErrnoIfMinus1Retry_
("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 "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
$ \visTmpFileName :: String
visTmpFileName visTmpFileHandle :: Handle
visTmpFileHandle -> do
Handle -> IO ()
forall (m :: * -> *). MonadIO m => Handle -> m ()
hClose Handle
visTmpFileHandle
String -> IO ()
removeFile String
visTmpFileName
case Maybe DirFd
mDirFd of
Nothing -> do
String -> (CFilePath -> IO ()) -> IO ()
forall a. String -> (CFilePath -> IO a) -> IO a
withFilePath String
visTmpFileName (String -> CFilePath -> IO ()
safeLink "visible")
String -> String -> IO ()
Posix.rename String
visTmpFileName String
filePath
Just dirFd :: 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
$ \cVisTmpFile :: CFilePath
cVisTmpFile -> do
String -> CFilePath -> IO ()
safeLink "visible" CFilePath
cVisTmpFile
String -> IO CInt -> IO ()
forall a. (Eq a, Num a) => String -> IO a -> IO ()
throwErrnoIfMinus1Retry_
"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
(cDirFd :: Either DirFd CAt
cDirFd, filePathName :: String
filePathName) =
case Maybe DirFd
mDirFd of
Nothing -> (CAt -> Either DirFd CAt
forall a b. b -> Either a b
Right CAt
at_FDCWD, String
filePath)
Just dirFd :: 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 mDirFd :: Maybe DirFd
mDirFd mFileMode :: Maybe CMode
mFileMode eTmpFile :: Either Handle String
eTmpFile filePath :: String
filePath =
case Either Handle String
eTmpFile of
Left tmpFileHandle :: Handle
tmpFileHandle ->
Maybe DirFd -> Maybe CMode -> Handle -> String -> IO ()
atomicTempFileCreate Maybe DirFd
mDirFd Maybe CMode
mFileMode Handle
tmpFileHandle String
filePath
Right tmpFilePath :: 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
$ \fileMode :: CMode
fileMode -> String -> CMode -> IO ()
Posix.setFileMode String
tmpFilePath CMode
fileMode
case Maybe DirFd
mDirFd of
Nothing -> String -> String -> IO ()
Posix.rename String
tmpFilePath String
filePath
Just dirFd :: 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
$ \cToFilePath :: 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
$ \cTmpFilePath :: CFilePath
cTmpFilePath ->
String -> IO CInt -> IO ()
forall a. (Eq a, Num a) => String -> IO a -> IO ()
throwErrnoIfMinus1Retry_ "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 dirPath :: 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
dirFd filePath :: String
filePath iomode :: 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 filePath :: String
filePath action :: 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))
(\(tmpFilePath :: String
tmpFilePath, tmpFileHandle :: 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 -> ShowS
forall a. [a] -> [a] -> [a]
++ String
fileName String -> ShowS
forall a. [a] -> [a] -> [a]
++ ".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 mDirFd :: Maybe DirFd
mDirFd filePath :: String
filePath iomode :: IOMode
iomode action :: 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 :: 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 res :: 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 exc :: 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 exc :: 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 mDirFd :: Maybe DirFd
mDirFd filePath :: String
filePath iomode :: IOMode
iomode action :: 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
$ \tmpFilePath :: String
tmpFilePath tmpFileHandle :: Handle
tmpFileHandle -> do
Handle -> m ()
forall (m :: * -> *). MonadIO m => Handle -> m ()
hClose Handle
tmpFileHandle
case Maybe DirFd
mDirFd of
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 -> 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
iomode fromFilePath :: String
fromFilePath toHandle :: 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 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 hFrom :: Handle
hFrom hTo :: 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 = 131072
go :: Ptr a -> IO ()
go buffer :: 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
> 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 h :: Handle
h cb :: Fd -> IO a
cb =
case Handle
h of
HandleFD.FileHandle _ mv :: 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 -> 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
Nothing -> String -> IO a
forall a. HasCallStack => String -> a
error "withHandleFd: not a file handle"
HandleFD.DuplexHandle {} -> String -> IO a
forall a. HasCallStack => String -> a
error "withHandleFd: not a file handle"
ensureFileDurable :: MonadIO m => FilePath -> m ()
ensureFileDurable :: String -> m ()
ensureFileDurable filePath :: 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 ->
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
$ \fileHandle :: 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 "ensureFileDurablePosix" Handle
fileHandle
String -> DirFd -> IO ()
fsyncDirectoryFd "ensureFileDurablePosix" DirFd
dirFd
withBinaryFileDurable ::
MonadUnliftIO m => FilePath -> IOMode -> (Handle -> m r) -> m r
withBinaryFileDurable :: String -> IOMode -> (Handle -> m r) -> m r
withBinaryFileDurable filePath :: String
filePath iomode :: IOMode
iomode action :: Handle -> m r
action =
case IOMode
iomode of
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
_
->
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 ->
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
$ \tmpFileHandle :: 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 "withBinaryFileDurablePosix" Handle
tmpFileHandle
String -> DirFd -> IO ()
fsyncDirectoryFd "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 filePath :: String
filePath iomode :: IOMode
iomode action :: Handle -> m r
action =
case IOMode
iomode of
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
_
->
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 -> 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 res :: r
res -> r -> m r
forall (f :: * -> *) a. Applicative f => a -> f a
pure r
res
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
$ \tmpFilePath :: 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
dirFd mTmpFilePath :: Maybe String
mTmpFilePath tmpFileHandle :: 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 filePath :: String
filePath iomode :: IOMode
iomode action :: Handle -> m r
action =
case IOMode
iomode of
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
_
-> 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 res :: r
res -> r -> m r
forall (f :: * -> *) a. Applicative f => a -> f a
pure r
res
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
$ \tmpFilePath :: 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 mTmpFilePath :: Maybe String
mTmpFilePath tmpFileHandle :: 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