T228

[phadej]

On top of #231, fixes #228

--- /code/ghc/libraries/base/GHC/IO/Handle/Lock.hsc	2019-04-03 01:58:28.555548614 +0300
+++ hackage-security/src/Hackage/Security/Util/FileLock.hsc	2019-10-22 21:31:28.072930649 +0300
@@ -1,9 +1,13 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE InterruptibleFFI #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE MultiWayIf #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-module GHC.IO.Handle.Lock (
+{-# LANGUAGE DeriveDataTypeable #-}
+
+-- | This compat module can be removed once base-4.10 (ghc-8.2) is the minimum
+-- required version. Though note that the locking functionality is not in
+-- public modules in base-4.10, just in the "GHC.IO.Handle.Lock" module.
+--
+-- Copied from @cabal-install@ codebase "Distribution.Client.Compat.FileLock".
+module Hackage.Security.Util.FileLock (
     FileLockingNotSupported(..)
   , LockMode(..)
   , hLock
@@ -11,9 +15,38 @@
   , hUnlock
   ) where
 
-#include "HsBaseConfig.h"
+#if MIN_VERSION_base(4,11,0)
+
+import GHC.IO.Handle.Lock
 
-#if HAVE_FLOCK
+#elif MIN_VERSION_base(4,10,0)
+
+import GHC.IO.Handle.Lock
+
+-- N.B. base-4.10 (GHC 8.2) didn't have hUnlock. For the time being we simply
+-- define this to be a no-op since we generally close the lock handle anyways.
+--
+-- However, do note that on Windows it can take longer for an outstanding
+-- lock to be released after its handle is closed than if the lock were
+-- explicitly released.
+
+hUnlock :: Handle -> IO ()
+hUnlock hdl = return ()
+
+#else
+
+-- The remainder of this file is a modified copy
+-- of GHC.IO.Handle.Lock from ghc-8.9.x
+--
+-- The modifications were just to the imports and the CPP, since we do not have
+-- access to the HAVE_FLOCK from the ./configure script. We approximate the
+-- lack of HAVE_FLOCK with @defined(solaris2_HOST_OS) || defined(aix_HOST_OS)@
+-- instead since those are known major Unix platforms lacking @flock()@ or
+-- having broken one.
+
+-- We avoid using #define as it breaks older hsc2hs
+
+#if defined(solaris2_HOST_OS) || defined(aix_HOST_OS)
 
 #include <sys/file.h>
 
@@ -21,7 +54,6 @@
 import Data.Function
 import Foreign.C.Error
 import Foreign.C.Types
-import GHC.IO.Exception
 import GHC.IO.FD
 import GHC.IO.Handle.FD
 
@@ -52,20 +84,20 @@
 
 import GHC.IO (throwIO)
 
-#endif
+#endif /* HAVE_FLOCK */
 
 import Data.Functor
 import GHC.Base
 import GHC.Exception
 import GHC.IO.Handle.Types
 import GHC.Show
+import Data.Typeable (Typeable)
 
 -- | Exception thrown by 'hLock' on non-Windows platforms that don't support
 -- 'flock'.
 data FileLockingNotSupported = FileLockingNotSupported
-  deriving Show -- ^ @since 4.10.0.0
+  deriving (Typeable, Show)
 
--- ^ @since 4.10.0.0
 instance Exception FileLockingNotSupported
 
 -- | Indicates a mode in which a file should be locked.
@@ -147,10 +179,11 @@
       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
+        _ -> getErrno >>= \errno ->
+          case () of
+            _ | 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}
@@ -180,13 +213,16 @@
 lockImpl h ctx mode block = do
   FD{fdFD = fd} <- handleToFd h
   let flags = cmode .|. (if block then 0 else #{const LOCK_NB})
-  fix $ \retry -> c_flock fd flags >>= \case
-    0 -> return True
-    _ -> getErrno >>= \errno -> if
-      | not block
-      , errno == eAGAIN || errno == eACCES -> return False
-      | errno == eINTR -> retry
-      | otherwise -> ioException $ errnoToIOError ctx errno (Just h) Nothing
+  fix $ \retry -> do
+    ret <- c_flock fd flags
+    case ret of
+      0 -> return True
+      _ -> getErrno >>= \errno ->
+        case () of
+          _ | not block
+            , errno == eAGAIN || errno == eACCES -> return False
+            | errno == eINTR -> retry
+            | otherwise -> ioException $ errnoToIOError ctx errno (Just h) Nothing
   where
     cmode = case mode of
       SharedLock    -> #{const LOCK_SH}
@@ -214,12 +250,15 @@
     -- "locking a region that goes beyond the current end-of-file position is
     -- not an error", hence we pass maximum value as the number of bytes to
     -- lock.
-    fix $ \retry -> c_LockFileEx wh flags 0 0xffffffff 0xffffffff ovrlpd >>= \case
-      True  -> return True
-      False -> getLastError >>= \err -> if
-        | not block && err == #{const ERROR_LOCK_VIOLATION} -> return False
-        | err == #{const ERROR_OPERATION_ABORTED} -> retry
-        | otherwise -> failWith ctx err
+    fix $ \retry -> do
+      ret <- c_LockFileEx wh flags 0 0xffffffff 0xffffffff ovrlpd
+      case ret of
+        True  -> return True
+        False -> getLastError >>= \err ->
+          case () of
+            _ | not block && err == #{const ERROR_LOCK_VIOLATION} -> return False
+              | err == #{const ERROR_OPERATION_ABORTED} -> retry
+              | otherwise -> failWith ctx err
   where
     sizeof_OVERLAPPED = #{size OVERLAPPED}
 
@@ -233,7 +272,8 @@
   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
+    ret <- c_UnlockFileEx wh 0 0xffffffff 0xffffffff ovrlpd
+    case ret of
       True  -> return ()
       False -> getLastError >>= failWith "hUnlock"
   where
@@ -262,3 +302,5 @@
 unlockImpl _ = throwIO FileLockingNotSupported
 
 #endif
+
+#endif /* MIN_VERSION_base(4,10,0) */

[Avi-D-coder]

Is anything still blocking this?

[hvr]

This became moot with #235