[commit: ghc] master: base: Add support for file unlocking (a27bb1b)

[git at git.haskell.org]

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

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/a27bb1bd6206bdd5e6004ec1f7e95144a0fcc4d4/ghc

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

commit a27bb1bd6206bdd5e6004ec1f7e95144a0fcc4d4
Author: Ben Gamari <bgamari.foss at gmail.com>
Date:   Tue Aug 29 14:45:08 2017 -0400

    base: Add support for file unlocking
    
    Reviewers: austin, hvr
    
    Subscribers: rwbarton, thomie
    
    Differential Revision: https://phabricator.haskell.org/D3875


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

a27bb1bd6206bdd5e6004ec1f7e95144a0fcc4d4
 libraries/base/GHC/IO/Handle/Lock.hsc | 30 ++++++++++++++++++++++++++++++
 1 file changed, 30 insertions(+)

diff --git a/libraries/base/GHC/IO/Handle/Lock.hsc b/libraries/base/GHC/IO/Handle/Lock.hsc
index ec62f86..daf407c 100644
--- a/libraries/base/GHC/IO/Handle/Lock.hsc
+++ b/libraries/base/GHC/IO/Handle/Lock.hsc
@@ -8,6 +8,7 @@ module GHC.IO.Handle.Lock (
   , LockMode(..)
   , hLock
   , hTryLock
+  , hUnlock
   ) where
 
 #include "HsBaseConfig.h"
@@ -97,6 +98,10 @@ hLock h mode = void $ lockImpl h "hLock" mode True
 hTryLock :: Handle -> LockMode -> IO Bool
 hTryLock h mode = lockImpl h "hTryLock" mode False
 
+-- | Release a lock taken with 'hLock' or 'hTryLock'.
+hUnlock :: Handle -> IO ()
+hUnlock = unlockImpl
+
 ----------------------------------------
 
 #if HAVE_FLOCK
@@ -116,6 +121,11 @@ lockImpl h ctx mode block = do
       SharedLock    -> #{const LOCK_SH}
       ExclusiveLock -> #{const LOCK_EX}
 
+unlockImpl :: Handle -> IO ()
+unlockImpl h = do
+  FD{fdFD = fd} <- handleToFd h
+  throwErrnoIfMinus1_ "flock" $ c_flock fd #{const LOCK_UN}
+
 foreign import ccall interruptible "flock"
   c_flock :: CInt -> CInt -> IO CInt
 
@@ -146,6 +156,18 @@ lockImpl h ctx mode block = do
       SharedLock    -> 0
       ExclusiveLock -> #{const LOCKFILE_EXCLUSIVE_LOCK}
 
+unlockImpl :: Handle -> IO ()
+unlockImpl h = do
+  FD{fdFD = fd} <- handleToFd h
+  wh <- throwErrnoIf (== iNVALID_HANDLE_VALUE) "hUnlock" $ c_get_osfhandle fd
+  allocaBytes sizeof_OVERLAPPED $ \ovrlpd -> do
+    fillBytes ovrlpd 0 sizeof_OVERLAPPED
+    c_UnlockFileEx wh 0 0xffffffff 0xffffffff ovrlpd >>= \case
+      True  -> return ()
+      False -> getLastError >>= failWith "hUnlock"
+  where
+    sizeof_OVERLAPPED = #{size OVERLAPPED}
+
 -- https://msdn.microsoft.com/en-us/library/aa297958.aspx
 foreign import ccall unsafe "_get_osfhandle"
   c_get_osfhandle :: CInt -> IO HANDLE
@@ -154,10 +176,18 @@ foreign import ccall unsafe "_get_osfhandle"
 foreign import WINDOWS_CCONV interruptible "LockFileEx"
   c_LockFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> DWORD -> Ptr () -> IO BOOL
 
+-- https://msdn.microsoft.com/en-us/library/windows/desktop/aa365716.aspx
+foreign import WINDOWS_CCONV interruptible "UnlockFileEx"
+  c_UnlockFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> Ptr () -> IO BOOL
+
 #else
 
 -- | No-op implementation.
 lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool
 lockImpl _ _ _ _ = throwIO FileLockingNotSupported
 
+-- | No-op implementation.
+unlockImpl :: Handle -> IO ()
+unlockImpl _ = throwIO FileLockingNotSupported
+
 #endif