module System.IO.Lock (
LockMode(..),
LockDescriptor,
setLock,
setLockAll,
unLock
) where
import Control.Concurrent
import Control.Monad
import Data.Typeable
import Foreign.C.Error
import Foreign.C.Types
import Foreign
import System.IO
import System.Posix.IO hiding (getLock, setLock, waitToSetLock, LockRequest(..))
import System.Posix.Types
data LockMode = LockRead | LockWrite
deriving (Eq, Ord, Read, Show, Enum, Bounded, Typeable)
newtype LockDescriptor = LD CInt
deriving (Show, Typeable)
foreign import ccall "System_IO_Lock.h System_IO_Lock_get_lock_async"
c_lock :: Ptr CInt -> Ptr CInt -> CInt -> CInt -> CShort -> COff -> COff -> IO CInt
foreign import ccall "unistd.h read"
c_read :: CInt -> Ptr a -> CSize -> IO CSsize
setLock :: Fd -> (LockMode, SeekMode, FileOffset, FileOffset) -> IO LockDescriptor
setLock (Fd fd) (lockmode, seekmode, off, len) =
alloca $ \p_in ->
alloca $ \p_out ->
alloca $ \p_e ->
do
throwErrnoIfMinus1_ __func__ $ c_lock p_in p_out fd lm sm off len
fd_in <- peek p_in
fd_out <- peek p_out
threadWaitRead (Fd fd_in)
throwErrnoIfMinus1Retry_ __func__ $ c_read fd_in p_e (fromIntegral . sizeOf . derefT $ p_e)
e <- peek p_e
closeFd (Fd fd_in)
when (e /= (0 :: CInt)) $ do
closeFd (Fd fd_out)
ioError $ errnoToIOError __func__ (Errno e) Nothing Nothing
return $ LD fd_out
where
__func__ = "System.IO.Lock.setLock"
lm = case lockmode of
LockRead -> 0
LockWrite -> 1
sm = case seekmode of
AbsoluteSeek -> 0
RelativeSeek -> 1
SeekFromEnd -> 2
derefT :: Ptr a -> a
derefT _ = undefined
setLockAll :: Fd -> LockMode -> IO LockDescriptor
setLockAll fd lm = setLock fd (lm, AbsoluteSeek, 0, 0)
unLock :: LockDescriptor -> IO ()
unLock (LD fd) = do
closeFd (Fd fd)