From c803bcb1f6ddfc50a0f6454f877538e3cfe9a7e5 Mon Sep 17 00:00:00 2001 From: Curtis Chin Jen Sem Date: Tue, 14 Jul 2026 21:37:47 +0200 Subject: [PATCH 1/4] Lock store creation against concurrent processes When several cabal processes share one `--store-dir` and that store is cold, they all race `createPackageDBIfMissing`. Precisely hitting the warning above it, noting that it is not thread-safe. Fix this by using a fd-based lock, prior to attempting to create the index. --- .../Distribution/Client/ProjectBuilding.hs | 21 +++++- .../src/Distribution/Client/Store.hs | 39 ++++++---- .../concurrent-store-init.test.hs | 75 +++++++++++++++++++ 3 files changed, 117 insertions(+), 18 deletions(-) create mode 100644 cabal-testsuite/PackageTests/ConcurrentStorePackageDb/concurrent-store-init.test.hs diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding.hs b/cabal-install/src/Distribution/Client/ProjectBuilding.hs index 98b724aab8f..9041a13b064 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding.hs @@ -92,7 +92,7 @@ import Control.Exception (assert, handle) import qualified Distribution.Client.IndexUtils as IndexUtils import Distribution.Simple.PackageIndex (InstalledPackageIndex) import System.Directory (doesDirectoryExist, doesFileExist, renameDirectory) -import System.FilePath (makeRelative, normalise, takeDirectory, (<.>), ()) +import System.FilePath (makeRelative, normalise, takeDirectory, takeFileName, (<.>), ()) import System.Semaphore (SemaphoreIdentifier) import Distribution.Client.Errors @@ -502,8 +502,7 @@ configuring individual packages. invocation. -} --- | Create a package DB if it does not currently exist. Note that this action --- is /not/ safe to run concurrently. +-- | Create a package DB if it does not currently exist. createPackageDBIfMissing :: Verbosity -> Compiler @@ -515,12 +514,26 @@ createPackageDBIfMissing compiler progdb (SpecificPackageDB dbPath) = do + -- If it already exists, skip locking. exists <- Cabal.doesPackageDBExist dbPath unless exists $ do createDirectoryIfMissingVerbose verbosity True (takeDirectory dbPath) - Cabal.createPackageDB verbosity compiler progdb dbPath + withPackageDBLock verbosity dbPath $ do + -- Re-check under the lock. Another process may have created the DB + -- while we were waiting. + exists' <- Cabal.doesPackageDBExist dbPath + unless exists' $ + Cabal.createPackageDB verbosity compiler progdb dbPath createPackageDBIfMissing _ _ _ _ = return () +-- | Hold an exclusive cross-process lock while initialising a package DB. +withPackageDBLock :: Verbosity -> FilePath -> IO a -> IO a +withPackageDBLock verbosity dbPath = + withFileLock verbosity lockPath waitMsg + where + lockPath = takeDirectory dbPath ('.' : takeFileName dbPath) <.> "lock" + waitMsg = "Waiting for file lock on package database " ++ dbPath + -- | Given all the context and resources, (re)build an individual package. rebuildTarget :: Verbosity diff --git a/cabal-install/src/Distribution/Client/Store.hs b/cabal-install/src/Distribution/Client/Store.hs index 93bc857fa03..07a2b30b5a2 100644 --- a/cabal-install/src/Distribution/Client/Store.hs +++ b/cabal-install/src/Distribution/Client/Store.hs @@ -15,6 +15,9 @@ module Distribution.Client.Store , newStoreEntry , NewStoreEntryOutcome (..) + -- * Cross-process locking + , withFileLock + -- * Concurrency strategy -- $concurrency ) where @@ -241,20 +244,28 @@ withIncomingUnitIdLock compiler unitid action = - bracket takeLock releaseLock (\_hnd -> action) + withFileLock verbosity (storeIncomingLock compiler unitid) waitMsg action where compid = compilerId compiler - takeLock = do - h <- openFile (storeIncomingLock compiler unitid) ReadWriteMode - -- First try non-blocking, but if we would have to wait then - -- log an explanation and do it again in blocking mode. - gotlock <- hTryLock h ExclusiveLock - unless gotlock $ do - info verbosity $ - "Waiting for file lock on store entry " - ++ prettyShow compid - prettyShow unitid - hLock h ExclusiveLock - return h + waitMsg = + "Waiting for file lock on store entry " + ++ prettyShow compid + prettyShow unitid + +-- | Hold an exclusive cross-process lock on @lockPath@ for the duration of +-- @action@, creating the lock file if it does not exist. +withFileLock :: Verbosity -> FilePath -> String -> IO a -> IO a +withFileLock verbosity lockPath waitMsg action = + bracket takeLock releaseLock (const action) + where + takeLock = do + h <- openFile lockPath ReadWriteMode + -- First try non-blocking, but if we would have to wait then + -- log an explanation and do it again in blocking mode. + gotlock <- hTryLock h ExclusiveLock + unless gotlock $ do + info verbosity waitMsg + hLock h ExclusiveLock + return h - releaseLock h = hUnlock h >> hClose h + releaseLock h = hUnlock h `finally` hClose h diff --git a/cabal-testsuite/PackageTests/ConcurrentStorePackageDb/concurrent-store-init.test.hs b/cabal-testsuite/PackageTests/ConcurrentStorePackageDb/concurrent-store-init.test.hs new file mode 100644 index 00000000000..716ef80daa0 --- /dev/null +++ b/cabal-testsuite/PackageTests/ConcurrentStorePackageDb/concurrent-store-init.test.hs @@ -0,0 +1,75 @@ +-- | Regression test for #11329 +-- +-- When several cabal processes share one --store-dir and that store is cold, +-- they all race 'createPackageDBIfMissing'. +-- +-- This test builds N independent trivial projects concurrently against one +-- shared store. Each project gets its own build dir so the only shared state +-- is the store package DB. + +import Control.Concurrent +import Control.Exception (SomeException, throwIO, try) +import Control.Monad (forM, forM_) +import Data.List (isInfixOf) +import System.Directory (createDirectoryIfMissing, removePathForcibly) +import System.Exit (ExitCode (..)) +import Test.Cabal.Prelude + +main = cabalTest $ do + env <- getTestEnv + cabalPath <- programPath <$> requireProgramM cabalProgram + let n = 10 + ids = [1 .. n] :: [Int] + root = testCurrentDir env + store = testWorkDir env "shared-store" + projDir i = root ("p" ++ show i) + build i = + run + (Just (projDir i)) + (testEnvironment env) + cabalPath + ["--store-dir=" ++ store, "build", "--builddir=" ++ projDir i "dist"] + Nothing + + -- Generate N independent trivial projects. + liftIO $ forM_ ids $ \i -> do + let p = projDir i + createDirectoryIfMissing True p + writeFile (p ("p" ++ show i ++ ".cabal")) $ + unlines + [ "cabal-version: 2.4" + , "name: p" ++ show i + , "version: 0.1" + , "executable p" ++ show i + , " main-is: Main.hs" + , " build-depends: base" + , " default-language: Haskell2010" + ] + + writeFile (p "Main.hs") "main :: IO ()\nmain = return ()\n" + writeFile (p "cabal.project") "packages: .\n" + + -- Make sure the shared store package DB is cold right before the burst. + liftIO $ removePathForcibly store + + -- Build all projects concurrently against the cold shared store. + results <- liftIO $ do + slots <- forM ids $ \i -> do + mv <- newEmptyMVar + _ <- forkIO $ do + r <- try (build i) :: IO (Either SomeException Result) + putMVar mv (i, r) + return mv + forM slots $ \mv -> do + (i, r) <- takeMVar mv + either throwIO (\res -> pure (i, res)) r + + liftIO $ forM_ results $ \(i, r) -> do + let out = resultOutput r + assertBool + ("cabal build for p" ++ show i ++ " hit the store package.db init race:\n" ++ out) + (not ("already exists" `isInfixOf` out)) + assertEqual + ("cabal build for p" ++ show i ++ " failed:\n" ++ out) + ExitSuccess + (resultExitCode r) From 8b835a4db3b70de3dd6bb5382d924a5617173d09 Mon Sep 17 00:00:00 2001 From: Curtis Chin Jen Sem Date: Tue, 14 Jul 2026 22:05:35 +0200 Subject: [PATCH 2/4] Add changelog entry --- changelog.d/pr-12114.md | 12 ++++++++++++ 1 file changed, 12 insertions(+) create mode 100644 changelog.d/pr-12114.md diff --git a/changelog.d/pr-12114.md b/changelog.d/pr-12114.md new file mode 100644 index 00000000000..bfc7cd8bbd1 --- /dev/null +++ b/changelog.d/pr-12114.md @@ -0,0 +1,12 @@ +--- +synopsis: Fix concurrent store creations +packages: [Cabal] +prs: 12114 +issues: [11329] +--- + +Previously, when several cabal processes share one `--store-dir` and that store +is cold, they all race `createPackageDBIfMissing`. Precisely hitting the warning +above it, noting that it is not thread-safe. + +Fix this by using a fd-based lock, prior to attempting to create the index. From 4014da0fa5a6557bc39386e52b3b32902a2704f3 Mon Sep 17 00:00:00 2001 From: Curtis Chin Jen Sem Date: Tue, 14 Jul 2026 23:12:38 +0200 Subject: [PATCH 3/4] Move `withFileLock` to `Distribution.Simple.Utils` --- Cabal/src/Distribution/Simple/Utils.hs | 24 ++++++++++++++++++ .../src/Distribution/Client/Store.hs | 25 +------------------ 2 files changed, 25 insertions(+), 24 deletions(-) diff --git a/Cabal/src/Distribution/Simple/Utils.hs b/Cabal/src/Distribution/Simple/Utils.hs index d23c22ba18e..2e726c84ae6 100644 --- a/Cabal/src/Distribution/Simple/Utils.hs +++ b/Cabal/src/Distribution/Simple/Utils.hs @@ -209,6 +209,9 @@ module Distribution.Simple.Utils , isAbsoluteOnAnyPlatform , isRelativeOnAnyPlatform , exceptionWithCallStackPrefix + + -- * Cross-process locking + , withFileLock ) where import Distribution.Compat.Async (waitCatch, withAsyncNF) @@ -253,6 +256,7 @@ import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime) import qualified Data.Version as DV import Distribution.Compat.Process (proc) import Foreign.C.Error (Errno (..), ePIPE) +import GHC.IO.Handle.Lock (LockMode (..), hLock, hTryLock, hUnlock) import qualified GHC.IO.Exception as GHC import GHC.Stack (HasCallStack) import Numeric (showFFloat) @@ -286,6 +290,7 @@ import System.FilePath as FilePath import System.IO ( BufferMode (..) , Handle + , IOMode (..) , hClose , hFlush , hGetContents @@ -293,6 +298,7 @@ import System.IO , hPutStrLn , hSetBinaryMode , hSetBuffering + , openFile , stderr , stdin , stdout @@ -1605,6 +1611,24 @@ getDirectoryContentsRecursive topdir = recurseDirectories [""] then collect files (dirEntry : dirs') entries else collect (dirEntry : files) dirs' entries +-- | Hold an exclusive cross-process lock on @lockPath@ for the duration of +-- @action@, creating the lock file if it does not exist. +withFileLock :: Verbosity -> FilePath -> String -> IO a -> IO a +withFileLock verbosity lockPath waitMsg action = + Exception.bracket takeLock releaseLock (const action) + where + takeLock = do + h <- openFile lockPath ReadWriteMode + -- First try non-blocking, but if we would have to wait then + -- log an explanation and do it again in blocking mode. + gotlock <- hTryLock h ExclusiveLock + unless gotlock $ do + info verbosity waitMsg + hLock h ExclusiveLock + return h + + releaseLock h = hUnlock h `Exception.finally` hClose h + ------------------------ -- Environment variables diff --git a/cabal-install/src/Distribution/Client/Store.hs b/cabal-install/src/Distribution/Client/Store.hs index 07a2b30b5a2..636e771fc42 100644 --- a/cabal-install/src/Distribution/Client/Store.hs +++ b/cabal-install/src/Distribution/Client/Store.hs @@ -15,9 +15,6 @@ module Distribution.Client.Store , newStoreEntry , NewStoreEntryOutcome (..) - -- * Cross-process locking - , withFileLock - -- * Concurrency strategy -- $concurrency ) where @@ -34,15 +31,13 @@ import Distribution.Simple.Compiler (Compiler (..)) import Distribution.Simple.Utils ( debug , info + , withFileLock , withTempDirectory ) -import Control.Exception import qualified Data.Set as Set -import GHC.IO.Handle.Lock (LockMode (ExclusiveLock), hLock, hTryLock, hUnlock) import System.Directory import System.FilePath -import System.IO (IOMode (ReadWriteMode), hClose, openFile) -- $concurrency -- @@ -251,21 +246,3 @@ withIncomingUnitIdLock "Waiting for file lock on store entry " ++ prettyShow compid prettyShow unitid - --- | Hold an exclusive cross-process lock on @lockPath@ for the duration of --- @action@, creating the lock file if it does not exist. -withFileLock :: Verbosity -> FilePath -> String -> IO a -> IO a -withFileLock verbosity lockPath waitMsg action = - bracket takeLock releaseLock (const action) - where - takeLock = do - h <- openFile lockPath ReadWriteMode - -- First try non-blocking, but if we would have to wait then - -- log an explanation and do it again in blocking mode. - gotlock <- hTryLock h ExclusiveLock - unless gotlock $ do - info verbosity waitMsg - hLock h ExclusiveLock - return h - - releaseLock h = hUnlock h `finally` hClose h From 0c85e56f3bfb39d3130f0b5e2b4316c7f32d3b1c Mon Sep 17 00:00:00 2001 From: Curtis Chin Jen Sem Date: Tue, 14 Jul 2026 23:16:07 +0200 Subject: [PATCH 4/4] fixup! Move `withFileLock` to `Distribution.Simple.Utils` --- Cabal/src/Distribution/Simple/Utils.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Cabal/src/Distribution/Simple/Utils.hs b/Cabal/src/Distribution/Simple/Utils.hs index 2e726c84ae6..43dd18c1a16 100644 --- a/Cabal/src/Distribution/Simple/Utils.hs +++ b/Cabal/src/Distribution/Simple/Utils.hs @@ -256,8 +256,8 @@ import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime) import qualified Data.Version as DV import Distribution.Compat.Process (proc) import Foreign.C.Error (Errno (..), ePIPE) -import GHC.IO.Handle.Lock (LockMode (..), hLock, hTryLock, hUnlock) import qualified GHC.IO.Exception as GHC +import GHC.IO.Handle.Lock (LockMode (..), hLock, hTryLock, hUnlock) import GHC.Stack (HasCallStack) import Numeric (showFFloat) import System.Directory