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