{-# LANGUAGE ForeignFunctionInterface, CPP #-}
--this module is related to persisting Project:M36 structures to disk and not related to the persistent library
module ProjectM36.Persist (writeFileSync, 
                           writeSerialiseSync,
                           renameSync,
                           printFdCount,
                           DiskSync(..)) where
-- on Windows, use FlushFileBuffers and MoveFileEx
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

--using withFile here is OK because we use a WORM strategy- the file is written but not read until after the handle is synced, closed, and unhidden (moved from ".X" to "X") at the top level in the transaction directory 
writeFileSync :: DiskSync -> FilePath -> T.Text -> IO()
writeFileSync :: DiskSync -> [Char] -> Text -> IO ()
writeFileSync DiskSync
sync [Char]
path Text
strOut = forall r. [Char] -> IOMode -> (Handle -> IO r) -> IO r
withFile [Char]
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 -> [Char] -> [Char] -> IO ()
renameSync DiskSync
sync [Char]
srcPath [Char]
dstPath = do
  [Char] -> [Char] -> IO ()
atomicRename [Char]
srcPath [Char]
dstPath
  DiskSync -> [Char] -> IO ()
syncDirectory DiskSync
sync [Char]
dstPath

-- System.Directory's renameFile/renameDirectory almost do exactly what we want except that it needlessly differentiates between directories and files
{-# ANN atomicRename ("HLint: ignore Eta reduce" :: String) #-}
atomicRename :: FilePath -> FilePath -> IO ()
atomicRename :: [Char] -> [Char] -> IO ()
atomicRename [Char]
srcPath [Char]
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
  [Char] -> [Char] -> IO ()
Posix.rename [Char]
srcPath [Char]
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
  --fdatasync doesn't exist on macOS
  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
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

syncDirectory :: DiskSync -> FilePath -> IO ()
syncDirectory :: DiskSync -> [Char] -> IO ()
syncDirectory DiskSync
FsyncDiskSync [Char]
path = [Char] -> IO ()
directoryFsync [Char]
path 
syncDirectory DiskSync
NoDiskSync [Char]
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

--uses lazy bytestring to write to file
writeSerialiseSync :: Serialise a => DiskSync -> FilePath -> a -> IO ()
writeSerialiseSync :: forall a. Serialise a => DiskSync -> [Char] -> a -> IO ()
writeSerialiseSync DiskSync
sync [Char]
path a
val = 
  forall r. [Char] -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile [Char]
path IOMode
WriteMode forall a b. (a -> b) -> a -> b
$ \Handle
handle -> do
    Handle -> Builder -> IO ()
BB.hPutBuilder Handle
handle forall a b. (a -> b) -> a -> b
$ 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 () -- on Windows directory metadata cannot be synchronized- perhaps there is a workaround? resync a file in the directory? 
#else
directoryFsync :: [Char] -> IO ()
directoryFsync [Char]
path = forall a. (Eq a, Num a) => [Char] -> IO a -> IO ()
throwErrnoIfMinus1Retry_ [Char]
"directoryFsync" (forall a. [Char] -> (CString -> IO a) -> IO a
withCString [Char]
path forall a b. (a -> b) -> a -> b
$ \CString
cpath -> CString -> IO CInt
cHSDirectoryFsync CString
cpath)
#endif

--prints out number of consumed file descriptors      
printFdCount :: IO ()
printFdCount :: IO ()
printFdCount =
#if FDCOUNTSUPPORTED
 do
  Int
fdc <- IO Int
fdCount
  [Char] -> IO ()
putStrLn ([Char]
"Fd count: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
fdc)
  --getLine >> pure ()
#else
  putStrLn "Fd count not supported on this OS."
#endif

#if FDCOUNTSUPPORTED
fdCount :: IO Int
fdCount :: IO Int
fdCount = do
  [[Char]]
fds <- [Char] -> IO [[Char]]
getDirectoryContents FDDIR
  forall (f :: * -> *) a. Applicative f => a -> f a
pure ((forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Char]]
fds) forall a. Num a => a -> a -> a
- Int
2)
--not supported on non-linux
#endif