{-# LANGUAGE ForeignFunctionInterface, CPP #-}
module ProjectM36.Persist (writeFileSync,
writeSerialiseSync,
renameSync,
printFdCount,
DiskSync(..)) where
import qualified Data.Text as T
import Codec.Winery
import qualified Data.ByteString.FastBuilder as BB
#if defined(linux_HOST_OS)
# define FDCOUNTSUPPORTED 1
# define FDDIR "/proc/self/fd"
#elif defined(darwin_HOST_OS)
# define FDCOUNTSUPPORTED 1
# define FDDIR "/dev/fd"
#else
# define FDCOUNTSUPPORTED 0
#endif
#if FDCOUNTSUPPORTED
import System.Directory
#endif
#if defined(mingw32_HOST_OS)
import qualified System.Win32 as Win32
#else
import qualified System.Posix as Posix
#if defined(linux_HOST_OS)
import System.Posix.Unistd (fileSynchroniseDataOnly)
#else
import System.Posix.Unistd (fileSynchronise)
#endif
import System.Posix.IO (handleToFd, closeFd)
import Foreign.C
#endif
import System.IO (withFile, IOMode(WriteMode), Handle, withBinaryFile)
import qualified Data.ByteString as BS
import qualified Data.Text.Encoding as TE
#if defined(mingw32_HOST_OS)
import ProjectM36.Win32Handle
#else
foreign import ccall unsafe "cDirectoryFsync" cHSDirectoryFsync :: CString -> IO CInt
#endif
data DiskSync = NoDiskSync | FsyncDiskSync
writeFileSync :: DiskSync -> FilePath -> T.Text -> IO()
writeFileSync :: DiskSync -> FilePath -> Text -> IO ()
writeFileSync DiskSync
sync FilePath
path Text
strOut = FilePath -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withFile FilePath
path IOMode
WriteMode Handle -> IO ()
handler
where
handler :: Handle -> IO ()
handler Handle
handle = do
Handle -> ByteString -> IO ()
BS.hPut Handle
handle (Text -> ByteString
TE.encodeUtf8 Text
strOut)
DiskSync -> Handle -> IO ()
syncHandle DiskSync
sync Handle
handle
renameSync :: DiskSync -> FilePath -> FilePath -> IO ()
renameSync :: DiskSync -> FilePath -> FilePath -> IO ()
renameSync DiskSync
sync FilePath
srcPath FilePath
dstPath = do
FilePath -> FilePath -> IO ()
atomicRename FilePath
srcPath FilePath
dstPath
DiskSync -> FilePath -> IO ()
syncDirectory DiskSync
sync FilePath
dstPath
{-# ANN atomicRename ("HLint: ignore Eta reduce" :: String) #-}
atomicRename :: FilePath -> FilePath -> IO ()
atomicRename :: FilePath -> FilePath -> IO ()
atomicRename FilePath
srcPath FilePath
dstPath =
#if defined(mingw32_HOST_OS)
#if MIN_VERSION_Win32(2,6,0)
let dst = Just dstPath
#else
let dst = dstPath
#endif
in
Win32.moveFileEx srcPath dst Win32.mOVEFILE_REPLACE_EXISTING
#else
FilePath -> FilePath -> IO ()
Posix.rename FilePath
srcPath FilePath
dstPath
#endif
syncHandle :: DiskSync -> Handle -> IO ()
syncHandle :: DiskSync -> Handle -> IO ()
syncHandle DiskSync
FsyncDiskSync Handle
handle =
#if defined(mingw32_HOST_OS)
withHandleToHANDLE handle (\h -> Win32.flushFileBuffers h)
#elif defined(linux_HOST_OS)
do
Fd
fd <- Handle -> IO Fd
handleToFd Handle
handle
Fd -> IO ()
fileSynchroniseDataOnly Fd
fd
Fd -> IO ()
closeFd Fd
fd
#else
do
fd <- handleToFd handle
fileSynchronise fd
closeFd fd
#endif
syncHandle DiskSync
NoDiskSync Handle
_ = () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
syncDirectory :: DiskSync -> FilePath -> IO ()
syncDirectory :: DiskSync -> FilePath -> IO ()
syncDirectory DiskSync
FsyncDiskSync FilePath
path = FilePath -> IO ()
directoryFsync FilePath
path
syncDirectory DiskSync
NoDiskSync FilePath
_ = () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
writeSerialiseSync :: Serialise a => DiskSync -> FilePath -> a -> IO ()
writeSerialiseSync :: DiskSync -> FilePath -> a -> IO ()
writeSerialiseSync DiskSync
sync FilePath
path a
val =
FilePath -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile FilePath
path IOMode
WriteMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
handle -> do
Handle -> Builder -> IO ()
BB.hPutBuilder Handle
handle (Builder -> IO ()) -> Builder -> IO ()
forall a b. (a -> b) -> a -> b
$ a -> Builder
forall a. Serialise a => a -> Builder
toBuilderWithSchema a
val
DiskSync -> Handle -> IO ()
syncHandle DiskSync
sync Handle
handle
directoryFsync :: FilePath -> IO ()
#if defined(mingw32_HOST_OS)
directoryFsync _ = pure ()
#else
directoryFsync :: FilePath -> IO ()
directoryFsync FilePath
path = FilePath -> IO CInt -> IO ()
forall a. (Eq a, Num a) => FilePath -> IO a -> IO ()
throwErrnoIfMinus1Retry_ FilePath
"directoryFsync" (FilePath -> (CString -> IO CInt) -> IO CInt
forall a. FilePath -> (CString -> IO a) -> IO a
withCString FilePath
path ((CString -> IO CInt) -> IO CInt)
-> (CString -> IO CInt) -> IO CInt
forall a b. (a -> b) -> a -> b
$ \CString
cpath -> CString -> IO CInt
cHSDirectoryFsync CString
cpath)
#endif
printFdCount :: IO ()
printFdCount :: IO ()
printFdCount =
#if FDCOUNTSUPPORTED
do
Int
fdc <- IO Int
fdCount
FilePath -> IO ()
putStrLn (FilePath
"Fd count: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
fdc)
#else
putStrLn "Fd count not supported on this OS."
#endif
#if FDCOUNTSUPPORTED
fdCount :: IO Int
fdCount :: IO Int
fdCount = do
[FilePath]
fds <- FilePath -> IO [FilePath]
getDirectoryContents FDDIR
Int -> IO Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([FilePath] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [FilePath]
fds) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2)
#endif