{-# OPTIONS_GHC -fno-warn-orphans #-}
module Data.IPCVar.File (newIPCVar) where
import Control.Applicative
import Control.Exception
import Data.Binary
import Data.IPCVar.Backend
import Data.Text.Lazy as T
import Data.Text.Lazy.Encoding
import System.Directory
import System.IO hiding (hGetContents)
import System.Posix.Files
import System.Posix.IO
import System.Posix.Types
withLock :: FilePath -> OpenMode -> LockRequest -> (Fd -> IO a) -> IO a
withLock path mode req f = do
fd <- openFd path mode (Just ownerModes) defaultFileFlags
go fd `finally` closeFd fd
where
go fd =
(waitToSetLock fd (req, AbsoluteSeek, 0, 0) >> f fd)
`finally` waitToSetLock fd (Unlock, AbsoluteSeek, 0, 0)
fileIPCBackend :: Binary a => FilePath -> IPCVarBackend a
fileIPCBackend path = IPCVarBackend
{ readValue = withLock path ReadOnly ReadLock decodeFd
, writeValue = \x -> withLock path WriteOnly WriteLock $ flip encodeFd x
, swapValue = \x -> withLock path ReadWrite WriteLock $ \fd ->
decodeFd fd <* encodeFd fd x
, deleteValue = removeFile path
, encodeState = encodeUtf8 (T.pack path)
}
newIPCVar :: Binary a => a -> IO (IPCVar a)
newIPCVar x = do
tmpDir <- getTemporaryDirectory
(path, h) <- openBinaryTempFile tmpDir "shmvar."
go path h `onException` removeFile path
where
go path h = do
hClose h
let var = IPCVar (fileIPCBackend path)
writeValue (getIPCVarBackend var) x
return var