module GHC.IO.Handle.Lock.LinuxOFD where
import Data.Function
import Data.Functor
import Foreign.C.Error
import Foreign.C.Types
import Foreign.Marshal.Utils
import Foreign.Storable
import GHC.Base
import GHC.IO.Exception
import GHC.IO.FD
import GHC.IO.Handle.FD
import GHC.IO.Handle.Lock.Common
import GHC.IO.Handle.Types (Handle)
import GHC.Ptr
import System.Posix.Types (COff, CPid)
foreign import ccall interruptible "fcntl"
c_fcntl :: CInt -> CInt -> Ptr FLock -> IO CInt
data FLock = FLock { l_type :: CShort
, l_whence :: CShort
, l_start :: COff
, l_len :: COff
, l_pid :: CPid
}
instance Storable FLock where
sizeOf _ = (32)
alignment _ = 8
poke ptr x = do
fillBytes ptr 0 (sizeOf x)
(\hsc_ptr -> pokeByteOff hsc_ptr 0) ptr (l_type x)
(\hsc_ptr -> pokeByteOff hsc_ptr 2) ptr (l_whence x)
(\hsc_ptr -> pokeByteOff hsc_ptr 8) ptr (l_start x)
(\hsc_ptr -> pokeByteOff hsc_ptr 16) ptr (l_len x)
(\hsc_ptr -> pokeByteOff hsc_ptr 24) ptr (l_pid x)
peek ptr = do
FLock <$> (\hsc_ptr -> peekByteOff hsc_ptr 0) ptr
<*> (\hsc_ptr -> peekByteOff hsc_ptr 2) ptr
<*> (\hsc_ptr -> peekByteOff hsc_ptr 8) ptr
<*> (\hsc_ptr -> peekByteOff hsc_ptr 16) ptr
<*> (\hsc_ptr -> peekByteOff hsc_ptr 24) ptr
lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool
lockImpl h ctx mode block = do
FD{fdFD = fd} <- handleToFd h
with flock $ \flock_ptr -> fix $ \retry -> do
ret <- c_fcntl fd mode' flock_ptr
case ret of
0 -> return True
_ -> getErrno >>= \errno -> if
| not block && errno == eWOULDBLOCK -> return False
| errno == eINTR -> retry
| otherwise -> ioException $ errnoToIOError ctx errno (Just h) Nothing
where
flock = FLock { l_type = case mode of
SharedLock -> 0
ExclusiveLock -> 1
, l_whence = 0
, l_start = 0
, l_len = 0
, l_pid = 0
}
mode'
| block = 38
| otherwise = 37
unlockImpl :: Handle -> IO ()
unlockImpl h = do
FD{fdFD = fd} <- handleToFd h
let flock = FLock { l_type = 2
, l_whence = 0
, l_start = 0
, l_len = 0
, l_pid = 0
}
throwErrnoIfMinus1_ "hUnlock"
$ with flock $ c_fcntl fd 37