Improved locking when multiple git-annex processes are writing to the .git/index file

Annex.hs

@@ -75,7 +75,6 @@ import Control.Concurrent
 import Control.Concurrent.Async
 import Control.Concurrent.STM
 import qualified Control.Monad.Fail as Fail
-import qualified Control.Concurrent.SSem as SSem
 import qualified Data.Map.Strict as M
 import qualified Data.Set as S
 
@@ -116,7 +115,6 @@ data AnnexState = AnnexState
 	, daemon :: Bool
 	, branchstate :: BranchState
 	, repoqueue :: Maybe Git.Queue.Queue
-	, repoqueuesem :: SSem.SSem
 	, catfilehandles :: M.Map FilePath CatFileHandle
 	, hashobjecthandle :: Maybe HashObjectHandle
 	, checkattrhandle :: Maybe CheckAttrHandle
@@ -159,7 +157,6 @@ newState c r = do
 	emptyactivekeys <- newTVarIO M.empty
 	o <- newMessageState
 	sc <- newTMVarIO False
-	qsem <- SSem.new 1
 	return $ AnnexState
 		{ repo = r
 		, repoadjustment = return
@@ -175,7 +172,6 @@ newState c r = do
 		, daemon = False
 		, branchstate = startBranchState
 		, repoqueue = Nothing
-		, repoqueuesem = qsem
 		, catfilehandles = M.empty
 		, hashobjecthandle = Nothing
 		, checkattrhandle = Nothing

Annex/Concurrent.hs

@@ -43,9 +43,7 @@ dupState = do
 	st <- Annex.getState id
 	return $ st
 		{ Annex.workers = []
-		-- each thread has its own repoqueue, but the repoqueuesem
+		-- each thread has its own repoqueue
-		-- is shared to prevent more than one thread flushing its
-		-- queue at the same time
 		, Annex.repoqueue = Nothing
 		-- avoid sharing eg, open file handles
 		, Annex.catfilehandles = M.empty

Annex/Locations.hs

@@ -61,6 +61,7 @@ module Annex.Locations (
 	gitAnnexMergeDir,
 	gitAnnexJournalDir,
 	gitAnnexJournalLock,
+	gitAnnexGitQueueLock,
 	gitAnnexPreCommitLock,
 	gitAnnexMergeLock,
 	gitAnnexIndex,
@@ -410,6 +411,11 @@ gitAnnexJournalDir r = addTrailingPathSeparator $ gitAnnexDir r </> "journal"
 gitAnnexJournalLock :: Git.Repo -> FilePath
 gitAnnexJournalLock r = gitAnnexDir r </> "journal.lck"
 
+{- Lock file for flushing a git queue that writes to the git index or
+ - other git state that should only have one writer at a time. -}
+gitAnnexGitQueueLock :: Git.Repo -> FilePath
+gitAnnexGitQueueLock r = gitAnnexDir r </> "gitqueue.lck"
+
 {- Lock file for the pre-commit hook. -}
 gitAnnexPreCommitLock :: Git.Repo -> FilePath
 gitAnnexPreCommitLock r = gitAnnexDir r </> "precommit.lck"

Annex/Queue.hs

@@ -1,6 +1,6 @@
 {- git-annex command queue
  -
- - Copyright 2011, 2012 Joey Hess <id@joeyh.name>
+ - Copyright 2011, 2012, 2019 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU AGPL version 3 or higher.
  -}
@@ -20,11 +20,10 @@ module Annex.Queue (
 
 import Annex.Common
 import Annex hiding (new)
+import Annex.LockFile
 import qualified Git.Queue
 import qualified Git.UpdateIndex
 
-import qualified Control.Concurrent.SSem as SSem
-
 {- Adds a git command to the queue. -}
 addCommand :: String -> [CommandParam] -> [FilePath] -> Annex ()
 addCommand command params files = do
@@ -59,20 +58,14 @@ flush = do
 		store =<< flush' q
 
 {- When there are multiple worker threads, each has its own queue.
+ - And of course multiple git-annex processes may be running each with its
+ - own queue.
  -
  - But, flushing two queues at the same time could lead to failures due to
  - git locking files. So, only one queue is allowed to flush at a time.
- - The repoqueuesem is shared between threads.
  -}
 flush' :: Git.Queue.Queue -> Annex Git.Queue.Queue
-flush' q = bracket lock unlock go
+flush' q = withExclusiveLock gitAnnexGitQueueLock $ do
-  where
-	lock = do
-		s <- getState repoqueuesem
-		liftIO $ SSem.wait s
-		return s
-	unlock = liftIO . SSem.signal
-	go _ = do
 	showStoringStateAction
 	inRepo $ Git.Queue.flush q
 

CHANGELOG

@@ -2,6 +2,8 @@ git-annex (7.20190504) UNRELEASED; urgency=medium
 
   * Fix reversion in last release that caused wrong tree to be written
     to remote tracking branch after an export of a subtree.
+  * Improved locking when multiple git-annex processes are writing to 
+    the .git/index file
 
  -- Joey Hess <id@joeyh.name>  Mon, 06 May 2019 13:52:02 -0400
 

doc/todo/only_allow_one_git_queue_to_be_flushed_at_a_time.mdwn

@@ -9,3 +9,5 @@ at a time. That locking is handled in `Annex.Queue.flush'` using a
 semaphore.
 
 Seems that it would be better to use a lock file. --[[Joey]]
+
+> [[done]] --[[Joey]]