diff options
author | Ben Gamari <bgamari.foss@gmail.com> | 2017-10-29 20:46:21 -0400 |
---|---|---|
committer | Ben Gamari <ben@smart-cactus.org> | 2017-10-29 20:46:22 -0400 |
commit | 3b784d440d4b01b4c549df7c9a3ed2058edfc780 (patch) | |
tree | 783f115c5f8cd8f82a9a8fe1a89a15ea7098575d | |
parent | 0e953da147c405648356f75ee67eda044fffad49 (diff) | |
download | haskell-3b784d440d4b01b4c549df7c9a3ed2058edfc780.tar.gz |
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
-rw-r--r-- | libraries/base/GHC/IO/Handle/Lock.hsc | 74 | ||||
-rw-r--r-- | libraries/base/configure.ac | 7 |
2 files changed, 78 insertions, 3 deletions
diff --git a/libraries/base/GHC/IO/Handle/Lock.hsc b/libraries/base/GHC/IO/Handle/Lock.hsc index daf407c881..b0a3449a2f 100644 --- a/libraries/base/GHC/IO/Handle/Lock.hsc +++ b/libraries/base/GHC/IO/Handle/Lock.hsc @@ -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 diff --git a/libraries/base/configure.ac b/libraries/base/configure.ac index af041a7ad5..69ea800a7f 100644 --- a/libraries/base/configure.ac +++ b/libraries/base/configure.ac @@ -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.]) |