Commit 3b784d44 authored by Ben Gamari's avatar Ben Gamari Committed by Ben Gamari

base: Implement file locking in terms of POSIX locks

Hopefully these are more robust to NFS malfunction than BSD flock-style
locks.  See #13945.

Test Plan: Validate via @simonpj

Reviewers: austin, hvr

Subscribers: rwbarton, thomie, erikd, simonpj

GHC Trac Issues: #13945

Differential Revision: https://phabricator.haskell.org/D4129
parent 0e953da1
......@@ -104,7 +104,76 @@ hUnlock = unlockImpl
----------------------------------------
#if HAVE_FLOCK
#if HAVE_OFD_LOCKING
-- Linux open file descriptor locking.
--
-- We prefer this over BSD locking (e.g. flock) since the latter appears to
-- break in some NFS configurations. Note that we intentionally do not try to
-- use ordinary POSIX file locking due to its peculiar semantics under
-- multi-threaded environments.
foreign import ccall interruptible "fcntl"
c_fcntl :: CInt -> CInt -> Ptr () -> 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 _ = #{size flock}
alignment _ = #{alignment flock}
poke ptr x = do
fillBytes ptr 0 (sizeOf x)
#{poke flock, l_type} ptr (l_type x)
#{poke flock, l_whence} ptr (l_whence x)
#{poke flock, l_start} ptr (l_start x)
#{poke flock, l_len} ptr (l_len x)
#{poke flock, l_pid} ptr (l_pid x)
peek ptr = do
FLock <$> #{peek flock, l_type} ptr
<*> #{peek flock, l_whence} ptr
<*> #{peek flock, l_start} ptr
<*> #{peek flock, l_len} ptr
<*> #{peek flock, l_pid} 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 <- with flock $ 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 -> #{const F_RDLCK}
ExclusiveLock -> #{const F_WRLCK}
, l_whence = #{const SEEK_SET}
, l_start = 0
, l_len = 0
}
mode
| block = #{const F_SETLKW}
| otherwise = #{const F_SETLK}
unlockImpl :: Handle -> IO ()
unlockImpl h = do
FD{fdFD = fd} <- handleToFd h
let flock = FLock { l_type = #{const F_UNLCK}
, l_whence = #{const SEEK_SET}
, l_start = 0
, l_len = 0
}
throwErrnoIfMinus1_ "hUnlock"
$ with flock $ c_fcntl fd #{const F_SETLK}
#elif HAVE_FLOCK
lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool
lockImpl h ctx mode block = do
......@@ -113,7 +182,8 @@ lockImpl h ctx mode block = do
fix $ \retry -> c_flock fd flags >>= \case
0 -> return True
_ -> getErrno >>= \errno -> if
| not block && errno == eWOULDBLOCK -> return False
| not block
, errno == eAGAIN || errno == eACCES -> return False
| errno == eINTR -> retry
| otherwise -> ioException $ errnoToIOError ctx errno (Just h) Nothing
where
......
......@@ -69,7 +69,12 @@ if test "$ac_cv_header_poll_h" = yes && test "$ac_cv_func_poll" = yes; then
AC_DEFINE([HAVE_POLL], [1], [Define if you have poll support.])
fi
#flock
# Linux open file description locks
AC_CHECK_DECL([F_OFD_SETLK], [
AC_DEFINE([HAVE_OFD_LOCKING], [1], [Define if you have open file descriptor lock support.])
])
# flock
AC_CHECK_FUNCS([flock])
if test "$ac_cv_header_sys_file_h" = yes && test "$ac_cv_func_flock" = yes; then
AC_DEFINE([HAVE_FLOCK], [1], [Define if you have flock support.])
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment