fix export db locking deadlock

Annex/Import.hs

@@ -128,15 +128,15 @@ buildImportCommit remote importtreeconfig importcommitconfig importable =
 					importedtree
 				return (Just commit)
 
-	updateexportdb importedtree = 
-		withExclusiveLock (gitAnnexExportLock (Remote.uuid remote)) $ do
-			db <- Export.openDb (Remote.uuid remote)
+	updateexportdb importedtree = do
+		db <- Export.openDb (Remote.uuid remote)
+		Export.writeLockDbWhile db $ do
 			prevtree <- liftIO $ fromMaybe emptyTree
 				<$> Export.getExportTreeCurrent db
 			when (importedtree /= prevtree) $ do
 				Export.updateExportDb db prevtree importedtree
 				liftIO $ Export.recordExportTreeCurrent db importedtree
-			Export.closeDb db
+		Export.closeDb db
 	
 	updateexportlog importedtree = do
 		oldexport <- getExport (Remote.uuid remote)

Annex/Locations.hs

@@ -48,6 +48,7 @@ module Annex.Locations (
 	gitAnnexSmudgeLock,
 	gitAnnexExportDbDir,
 	gitAnnexExportLock,
+	gitAnnexExportUpdateLock,
 	gitAnnexContentIdentifierDbDir,
 	gitAnnexContentIdentifierLock,
 	gitAnnexScheduleState,
@@ -350,6 +351,10 @@ gitAnnexExportDbDir u r = gitAnnexExportDir u r </> "db"
 gitAnnexExportLock :: UUID -> Git.Repo -> FilePath
 gitAnnexExportLock u r = gitAnnexExportDbDir u r ++ ".lck"
 
+{- Lock file for updating the export state for a special remote. -}
+gitAnnexExportUpdateLock :: UUID -> Git.Repo -> FilePath
+gitAnnexExportUpdateLock u r = gitAnnexExportDbDir u r ++ ".upl"
+
 {- Directory containing database used to record remote content ids. -}
 gitAnnexContentIdentifierDbDir :: Git.Repo -> FilePath
 gitAnnexContentIdentifierDbDir r = gitAnnexDir r </> "cid"

Command/Export.hs

@@ -24,7 +24,6 @@ import Annex.Export
 import Annex.Content
 import Annex.Transfer
 import Annex.CatFile
-import Annex.LockFile
 import Annex.RemoteTrackingBranch
 import Logs.Location
 import Logs.Export
@@ -84,12 +83,12 @@ seek o = do
 	tree <- fromMaybe (giveup "unknown tree") <$>
 		inRepo (Git.Ref.tree (fromMaybe (exportTreeish o) (fmap snd mtbcommitsha)))
 
-	withExclusiveLock (gitAnnexExportLock (uuid r)) $ do
-		db <- openDb (uuid r)
+	db <- openDb (uuid r)
+	writeLockDbWhile db $ do
 		changeExport r db tree
 		unlessM (Annex.getState Annex.fast) $ do
 			void $ fillExport r db tree mtbcommitsha
-		closeDb db
+	closeDb db
 
 -- | When the treeish is a branch like master or refs/heads/master
 -- (but not refs/remotes/...), find the commit it points to

Command/Sync.hs

@@ -59,7 +59,6 @@ import Annex.Ssh
 import Annex.BloomFilter
 import Annex.UpdateInstead
 import Annex.Export
-import Annex.LockFile
 import Annex.TaggedPush
 import Annex.CurrentBranch
 import qualified Database.Export as Export
@@ -691,8 +690,11 @@ syncFile ebloom rs af k = onlyActionOn' k $ do
 seekExportContent :: [Remote] -> CurrBranch -> Annex Bool
 seekExportContent rs (currbranch, _) = or <$> forM rs go
   where
-	go r = withExclusiveLock (gitAnnexExportLock (Remote.uuid r)) $ do
-		db <- Export.openDb (Remote.uuid r)
+	go r = bracket
+		(Export.openDb (Remote.uuid r))
+		Export.closeDb
+		(\db -> Export.writeLockDbWhile db (go' r db))
+	go' r db = do
 		(exported, mtbcommitsha) <- case remoteAnnexTrackingBranch (Remote.gitconfig r) of
 			Nothing -> nontracking r
 			Just b -> do
@@ -706,7 +708,7 @@ seekExportContent rs (currbranch, _) = or <$> forM rs go
 					Just cur -> do
 						Command.Export.changeExport r db cur
 						return ([mkExported cur []], mtbcommitsha)
-		Export.closeDb db `after` fillexport r db (exportedTreeishes exported) mtbcommitsha
+		fillexport r db (exportedTreeishes exported) mtbcommitsha
 		
 	nontracking r = do
 		exported <- getExport (Remote.uuid r)

Database/Export.hs

@@ -15,6 +15,7 @@ module Database.Export (
 	ExportHandle,
 	openDb,
 	closeDb,
+	writeLockDbWhile,
 	flushDbQueue,
 	addExportedLocation,
 	removeExportedLocation,
@@ -48,6 +49,7 @@ import Types.Export
 import Annex.Export
 import qualified Logs.Export as Log
 import Annex.LockFile
+import Annex.LockPool
 import Git.Types
 import Git.Sha
 import Git.FilePath
@@ -258,22 +260,72 @@ updateExportDb = runExportDiffUpdater $ mkExportDiffUpdater removeold addnew
 		addExportTree h k loc
 		addExportedLocation h k loc
 
+{- Runs an action with the database locked for write. Waits for any other
+ - writers to finish first. The queue is flushed at the end.
+ -
+ - This first updates the ExportTree table with any new information 
+ - from the git-annex branch export log.
+ -}
+writeLockDbWhile :: ExportHandle -> Annex a -> Annex a
+writeLockDbWhile db@(ExportHandle _ u) a = do
+	updatelck <- takeExclusiveLock (gitAnnexExportUpdateLock u)
+	withExclusiveLock (gitAnnexExportLock u) $ do
+		bracket_ (setup updatelck) cleanup a
+  where
+	setup updatelck = do
+		void $ updateExportTreeFromLog' db
+		-- flush the update so it's available immediately to
+		-- anything waiting on the updatelck
+		liftIO $ flushDbQueue db
+		liftIO $ dropLock updatelck
+	cleanup = liftIO $ flushDbQueue db
+
 data ExportUpdateResult = ExportUpdateSuccess | ExportUpdateConflict
 	deriving (Eq)
 
+{- Updates the ExportTree table with information from the
+ - git-annex branch export log.
+ -
+ - This can safely be called whether the database is locked for write or
+ - not. Either way, it will block until the update is complete.
+ -}
 updateExportTreeFromLog :: ExportHandle -> Annex ExportUpdateResult
-updateExportTreeFromLog db@(ExportHandle _ u) = 
-	withExclusiveLock (gitAnnexExportLock u) $ do
-		old <- liftIO $ fromMaybe emptyTree
-			<$> getExportTreeCurrent db
-		l <- Log.getExport u
-		case Log.exportedTreeishes l of
-			[] -> return ExportUpdateSuccess
-			(new:[]) 
-				| new /= old -> do
-					updateExportTree db old new
-					liftIO $ recordExportTreeCurrent db new
-					liftIO $ flushDbQueue db
-					return ExportUpdateSuccess
-				| new == old -> return ExportUpdateSuccess
-			_ts -> return ExportUpdateConflict
+updateExportTreeFromLog db@(ExportHandle _ u) =
+	-- If another process or thread is performing the update,
+	-- this will block until it's done.
+	withExclusiveLock (gitAnnexExportUpdateLock u) $ do
+		-- If the database is locked by something else,
+		-- this will not run the update. But, in that case,
+		-- writeLockDbWhile is running, and has already
+		-- completed the update, so we don't need to do anything.
+		mr <- tryExclusiveLock (gitAnnexExportLock u) $
+			updateExportTreeFromLog' db
+		case mr of
+			Just r -> return r
+			Nothing -> do
+				old <- liftIO $ fromMaybe emptyTree
+					<$> getExportTreeCurrent db
+				l <- Log.getExport u
+				return $ case Log.exportedTreeishes l of
+					[] -> ExportUpdateSuccess
+					(new:[]) 
+						| new /= old -> ExportUpdateSuccess
+						| new == old -> ExportUpdateSuccess
+					_ts -> ExportUpdateConflict
+
+{- The database should be locked when calling this. -}
+updateExportTreeFromLog' :: ExportHandle -> Annex ExportUpdateResult
+updateExportTreeFromLog' db@(ExportHandle _ u) = do
+	old <- liftIO $ fromMaybe emptyTree
+		<$> getExportTreeCurrent db
+	l <- Log.getExport u
+	case Log.exportedTreeishes l of
+		[] -> return ExportUpdateSuccess
+		(new:[]) 
+			| new /= old -> do
+				updateExportTree db old new
+				liftIO $ recordExportTreeCurrent db new
+				liftIO $ flushDbQueue db
+				return ExportUpdateSuccess
+			| new == old -> return ExportUpdateSuccess
+		_ts -> return ExportUpdateConflict