From 7f15d3641d57f525c6622cb6dfcfd4ff1b7175d0 Mon Sep 17 00:00:00 2001
From: Oleg Grenrus <oleg.grenrus@iki.fi>
Date: Wed, 13 Nov 2019 13:58:50 +0200
Subject: [PATCH] Use lukko for file-locking
---
.../Distribution/Client/Compat/FileLock.hsc | 201 ------------------
cabal-install/Distribution/Client/Store.hs | 37 +++-
cabal-install/bootstrap.sh | 7 +-
cabal-install/cabal-install.cabal | 12 +-
cabal-install/cabal-install.cabal.pp | 12 +-
5 files changed, 55 insertions(+), 214 deletions(-)
delete mode 100644 cabal-install/Distribution/Client/Compat/FileLock.hsc
diff --git a/cabal-install/Distribution/Client/Compat/FileLock.hsc b/cabal-install/Distribution/Client/Compat/FileLock.hsc
deleted file mode 100644
index eafaee8884..0000000000
--- a/cabal-install/Distribution/Client/Compat/FileLock.hsc
+++ /dev/null
@@ -1,201 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE InterruptibleFFI #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE MultiWayIf #-}
-{-# 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.
-module Distribution.Client.Compat.FileLock (
- FileLockingNotSupported(..)
- , LockMode(..)
- , hLock
- , hTryLock
- ) where
-
-#if MIN_VERSION_base(4,10,0)
-
-import GHC.IO.Handle.Lock
-
-#else
-
--- The remainder of this file is a modified copy
--- of GHC.IO.Handle.Lock from ghc-8.2.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) instead since that is the
--- only known major Unix platform lacking flock().
-
-import Control.Exception (Exception)
-import Data.Typeable
-
-#if defined(solaris2_HOST_OS)
-
-import Control.Exception (throwIO)
-import System.IO (Handle)
-
-#else
-
-import Data.Bits
-import Data.Function
-import Control.Concurrent.MVar
-
-import Foreign.C.Error
-import Foreign.C.Types
-
-import GHC.IO.Handle.Types
-import GHC.IO.FD
-import GHC.IO.Exception
-
-#if defined(mingw32_HOST_OS)
-
-#if defined(i386_HOST_ARCH)
-## define WINDOWS_CCONV stdcall
-#elif defined(x86_64_HOST_ARCH)
-## define WINDOWS_CCONV ccall
-#else
-# error Unknown mingw32 arch
-#endif
-
-#include <windows.h>
-
-import Foreign.Marshal.Alloc
-import Foreign.Marshal.Utils
-import Foreign.Ptr
-import GHC.Windows
-
-#else /* !defined(mingw32_HOST_OS), so assume unix with flock() */
-
-#include <sys/file.h>
-
-#endif /* !defined(mingw32_HOST_OS) */
-
-#endif /* !defined(solaris2_HOST_OS) */
-
-
--- | Exception thrown by 'hLock' on non-Windows platforms that don't support
--- 'flock'.
-data FileLockingNotSupported = FileLockingNotSupported
- deriving (Typeable, Show)
-
-instance Exception FileLockingNotSupported
-
-
--- | Indicates a mode in which a file should be locked.
-data LockMode = SharedLock | ExclusiveLock
-
--- | If a 'Handle' references a file descriptor, attempt to lock contents of the
--- underlying file in appropriate mode. If the file is already locked in
--- incompatible mode, this function blocks until the lock is established. The
--- lock is automatically released upon closing a 'Handle'.
---
--- Things to be aware of:
---
--- 1) This function may block inside a C call. If it does, in order to be able
--- to interrupt it with asynchronous exceptions and/or for other threads to
--- continue working, you MUST use threaded version of the runtime system.
---
--- 2) The implementation uses 'LockFileEx' on Windows and 'flock' otherwise,
--- hence all of their caveats also apply here.
---
--- 3) On non-Windows plaftorms that don't support 'flock' (e.g. Solaris) this
--- function throws 'FileLockingNotImplemented'. We deliberately choose to not
--- provide fcntl based locking instead because of its broken semantics.
---
--- @since 4.10.0.0
-hLock :: Handle -> LockMode -> IO ()
-hLock h mode = lockImpl h "hLock" mode True >> return ()
-
--- | Non-blocking version of 'hLock'.
---
--- @since 4.10.0.0
-hTryLock :: Handle -> LockMode -> IO Bool
-hTryLock h mode = lockImpl h "hTryLock" mode False
-
-----------------------------------------
-
-#if defined(solaris2_HOST_OS)
-
--- | No-op implementation.
-lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool
-lockImpl _ _ _ _ = throwIO FileLockingNotSupported
-
-#else /* !defined(solaris2_HOST_OS) */
-
-#if defined(mingw32_HOST_OS)
-
-lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool
-lockImpl h ctx mode block = do
- FD{fdFD = fd} <- handleToFd h
- wh <- throwErrnoIf (== iNVALID_HANDLE_VALUE) ctx $ c_get_osfhandle fd
- allocaBytes sizeof_OVERLAPPED $ \ovrlpd -> do
- fillBytes ovrlpd (fromIntegral sizeof_OVERLAPPED) 0
- let flags = cmode .|. (if block then 0 else #{const LOCKFILE_FAIL_IMMEDIATELY})
- -- We want to lock the whole file without looking up its size to be
- -- consistent with what flock does. According to documentation of LockFileEx
- -- "locking a region that goes beyond the current end-of-file position is
- -- not an error", however e.g. Windows 10 doesn't accept maximum possible
- -- value (a pair of MAXDWORDs) for mysterious reasons. Work around that by
- -- trying 2^32-1.
- fix $ \retry -> c_LockFileEx wh flags 0 0xffffffff 0x0 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
- where
- sizeof_OVERLAPPED = #{size OVERLAPPED}
-
- cmode = case mode of
- SharedLock -> 0
- ExclusiveLock -> #{const LOCKFILE_EXCLUSIVE_LOCK}
-
--- https://msdn.microsoft.com/en-us/library/aa297958.aspx
-foreign import ccall unsafe "_get_osfhandle"
- c_get_osfhandle :: CInt -> IO HANDLE
-
--- https://msdn.microsoft.com/en-us/library/windows/desktop/aa365203.aspx
-foreign import WINDOWS_CCONV interruptible "LockFileEx"
- c_LockFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> DWORD -> Ptr () -> IO BOOL
-
-#else /* !defined(mingw32_HOST_OS), so assume unix with flock() */
-
-lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool
-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 == eWOULDBLOCK -> return False
- | errno == eINTR -> retry
- | otherwise -> ioException $ errnoToIOError ctx errno (Just h) Nothing
- where
- cmode = case mode of
- SharedLock -> #{const LOCK_SH}
- ExclusiveLock -> #{const LOCK_EX}
-
-foreign import ccall interruptible "flock"
- c_flock :: CInt -> CInt -> IO CInt
-
-#endif /* !defined(mingw32_HOST_OS) */
-
--- | Turn an existing Handle into a file descriptor. This function throws an
--- IOError if the Handle does not reference a file descriptor.
-handleToFd :: Handle -> IO FD
-handleToFd h = case h of
- FileHandle _ mv -> do
- Handle__{haDevice = dev} <- readMVar mv
- case cast dev of
- Just fd -> return fd
- Nothing -> throwErr "not a file descriptor"
- DuplexHandle{} -> throwErr "not a file handle"
- where
- throwErr msg = ioException $ IOError (Just h)
- InappropriateType "handleToFd" msg Nothing Nothing
-
-#endif /* defined(solaris2_HOST_OS) */
-
-#endif /* MIN_VERSION_base */
diff --git a/cabal-install/Distribution/Client/Store.hs b/cabal-install/Distribution/Client/Store.hs
index d7a9830c35..b92b14e16c 100644
--- a/cabal-install/Distribution/Client/Store.hs
+++ b/cabal-install/Distribution/Client/Store.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}
+{-# LANGUAGE CPP, RecordWildCards, NamedFieldPuns #-}
-- | Management for the installed package store.
@@ -23,7 +23,6 @@ module Distribution.Client.Store (
import Prelude ()
import Distribution.Client.Compat.Prelude
-import Distribution.Client.Compat.FileLock
import Distribution.Client.DistDirLayout
import Distribution.Client.RebuildMonad
@@ -41,8 +40,16 @@ import Control.Exception
import Control.Monad (forM_)
import System.FilePath
import System.Directory
-import System.IO
+#ifdef MIN_VERSION_lukko
+import Lukko
+#else
+import System.IO (openFile, IOMode(ReadWriteMode), hClose)
+import GHC.IO.Handle.Lock (hLock, hTryLock, LockMode(ExclusiveLock))
+#if MIN_VERSION_base(4,11,0)
+import GHC.IO.Handle.Lock (hUnlock)
+#endif
+#endif
-- $concurrency
--
@@ -235,6 +242,26 @@ withIncomingUnitIdLock verbosity StoreDirLayout{storeIncomingLock}
compid unitid action =
bracket takeLock releaseLock (\_hnd -> action)
where
+#ifdef MIN_VERSION_lukko
+ takeLock
+ | fileLockingSupported = do
+ fd <- fdOpen (storeIncomingLock compid unitid)
+ gotLock <- fdTryLock fd ExclusiveLock
+ unless gotLock $ do
+ info verbosity $ "Waiting for file lock on store entry "
+ ++ display compid </> display unitid
+ fdLock fd ExclusiveLock
+ return fd
+
+ -- if there's no locking, do nothing. Be careful on AIX.
+ | otherwise = return undefined -- :(
+
+ releaseLock fd
+ | fileLockingSupported = do
+ fdUnlock fd
+ fdClose fd
+ | otherwise = return ()
+#else
takeLock = do
h <- openFile (storeIncomingLock compid unitid) ReadWriteMode
-- First try non-blocking, but if we would have to wait then
@@ -246,5 +273,5 @@ withIncomingUnitIdLock verbosity StoreDirLayout{storeIncomingLock}
hLock h ExclusiveLock
return h
- releaseLock = hClose
-
+ releaseLock h = hUnlock h >> hClose h
+#endif
diff --git a/cabal-install/bootstrap.sh b/cabal-install/bootstrap.sh
index 35930a9c1a..220ff8b8f1 100755
--- a/cabal-install/bootstrap.sh
+++ b/cabal-install/bootstrap.sh
@@ -266,8 +266,7 @@ TAR_VER="0.5.1.0"; TAR_VER_REGEXP="0\.5\.([1-9]|1[0-9]|0\.[3-9]|0\.1[0-9])\.
# >= 0.5.0.3 && < 0.6
DIGEST_VER="0.0.1.2"; DIGEST_REGEXP="0\.0\.(1\.[2-9]|[2-9]\.?)"
# >= 0.0.1.2 && < 0.1
-ZIP_ARCHIVE_VER="0.3.3"; ZIP_ARCHIVE_REGEXP="0\.3\.[3-9]"
- # >= 0.3.3 && < 0.4
+LUKKO_VER="0.1"; LUKKO_VER_REGEXP="0\.1\.?"
HACKAGE_URL="https://hackage.haskell.org/package"
@@ -471,7 +470,7 @@ info_pkg "edit-distance" ${EDIT_DISTANCE_VER} ${EDIT_DISTANCE_VER_REGEXP}
info_pkg "ed25519" ${ED25519_VER} ${ED25519_VER_REGEXP}
info_pkg "tar" ${TAR_VER} ${TAR_VER_REGEXP}
info_pkg "digest" ${DIGEST_VER} ${DIGEST_REGEXP}
-info_pkg "zip-archive" ${ZIP_ARCHIVE_VER} ${ZIP_ARCHIVE_REGEXP}
+info_pkg "lukko" ${LUKKO_VER} ${LUKKO_REGEXP}
info_pkg "hackage-security" ${HACKAGE_SECURITY_VER} \
${HACKAGE_SECURITY_VER_REGEXP}
@@ -509,7 +508,7 @@ do_pkg "edit-distance" ${EDIT_DISTANCE_VER} ${EDIT_DISTANCE_VER_REGEXP}
do_pkg "ed25519" ${ED25519_VER} ${ED25519_VER_REGEXP}
do_pkg "tar" ${TAR_VER} ${TAR_VER_REGEXP}
do_pkg "digest" ${DIGEST_VER} ${DIGEST_REGEXP}
-do_pkg "zip-archive" ${ZIP_ARCHIVE_VER} ${ZIP_ARCHIVE_REGEXP}
+do_pkg "lukko" ${LUKKO_VER} ${LUKKO_REGEXP}
do_pkg "hackage-security" ${HACKAGE_SECURITY_VER} \
${HACKAGE_SECURITY_VER_REGEXP}
diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal
index 4daa0e7823..36bb306af1 100644
--- a/cabal-install/cabal-install.cabal
+++ b/cabal-install/cabal-install.cabal
@@ -21,7 +21,6 @@ Category: Distribution
Build-type: Custom
Extra-Source-Files:
README.md bash-completion/cabal bootstrap.sh changelog
- tests/README.md
-- Generated with 'make gen-extra-source-files'
-- Do NOT edit this section manually; instead, run the script.
@@ -122,6 +121,11 @@ Flag debug-tracetree
default: False
manual: True
+Flag lukko
+ description: Use @lukko@ for file-locking
+ default: True
+ manual: True
+
custom-setup
setup-depends:
Cabal >= 2.2,
@@ -176,7 +180,6 @@ executable cabal
Distribution.Client.CmdSdist
Distribution.Client.Compat.Directory
Distribution.Client.Compat.ExecutablePath
- Distribution.Client.Compat.FileLock
Distribution.Client.Compat.FilePerms
Distribution.Client.Compat.Prelude
Distribution.Client.Compat.Process
@@ -352,6 +355,11 @@ executable cabal
else
build-depends: unix >= 2.5 && < 2.9
+ if flag(lukko)
+ build-depends: lukko >= 0.1 && <0.2
+ else
+ build-depends: base >= 4.10
+
if flag(debug-expensive-assertions)
cpp-options: -DDEBUG_EXPENSIVE_ASSERTIONS
diff --git a/cabal-install/cabal-install.cabal.pp b/cabal-install/cabal-install.cabal.pp
index 7afd09753e..1d3f227203 100644
--- a/cabal-install/cabal-install.cabal.pp
+++ b/cabal-install/cabal-install.cabal.pp
@@ -61,6 +61,11 @@ Version: 3.1.0.0
build-depends: Win32 >= 2 && < 3
else
build-depends: unix >= 2.5 && < 2.9
+
+ if flag(lukko)
+ build-depends: lukko >= 0.1 && <0.2
+ else
+ build-depends: base >= 4.10
%enddef
%def CABAL_COMPONENTCOMMON
default-language: Haskell2010
@@ -106,7 +111,6 @@ Version: 3.1.0.0
Distribution.Client.CmdSdist
Distribution.Client.Compat.Directory
Distribution.Client.Compat.ExecutablePath
- Distribution.Client.Compat.FileLock
Distribution.Client.Compat.FilePerms
Distribution.Client.Compat.Prelude
Distribution.Client.Compat.Process
@@ -275,7 +279,6 @@ Build-type: Custom
%endif
Extra-Source-Files:
README.md bash-completion/cabal bootstrap.sh changelog
- tests/README.md
-- Generated with 'make gen-extra-source-files'
-- Do NOT edit this section manually; instead, run the script.
@@ -376,6 +379,11 @@ Flag debug-tracetree
default: False
manual: True
+Flag lukko
+ description: Use @lukko@ for file-locking
+ default: True
+ manual: True
+
%if CABAL_FLAG_LIB
%else
custom-setup
--
GitLab