Lock store creation against concurrent processes

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)
@@ -254,6 +257,7 @@ import qualified Data.Version as DV
 import Distribution.Compat.Process (proc)
 import Foreign.C.Error (Errno (..), ePIPE)
 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
@@ -286,13 +290,15 @@ import System.FilePath as FilePath
 import System.IO
   ( BufferMode (..)
   , Handle
+  , IOMode (..)
   , hClose
   , hFlush
   , hGetContents
   , hPutStr
   , 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
 

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

cabal-install/src/Distribution/Client/Store.hs

@@ -31,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
 --
@@ -241,20 +239,10 @@ 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
-
-      releaseLock h = hUnlock h >> hClose h
+      waitMsg =
+        "Waiting for file lock on store entry "
+          ++ prettyShow compid
+          </> prettyShow unitid

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)

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.