[commit: ghc] wip/nfs-locking: base: Implement file locking in terms of POSIX locks (1cd7473)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/nfs-locking
Link       : http://ghc.haskell.org/trac/ghc/changeset/1cd7473f8e800a99e95180579480a0e62e98040b/ghc

>---------------------------------------------------------------

commit 1cd7473f8e800a99e95180579480a0e62e98040b
Author: Ben Gamari <ben at smart-cactus.org>
Date:   Thu Oct 26 10:40:11 2017 -0400

    base: Implement file locking in terms of POSIX locks
    
    Hopefully these are more robust to NFS malfunction than BSD flock-style locks.
    See #13945.


>---------------------------------------------------------------

1cd7473f8e800a99e95180579480a0e62e98040b
 libraries/base/GHC/IO/Handle/Lock.hsc | 74 ++++++++++++++++++++++++++++++++++-
 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 daf407c..b0a3449 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 af041a7..69ea800 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.])