fix export db locking deadlock

This commit is contained in:
Joey Hess 2019-03-07 15:59:44 -04:00
parent 7e35c81ada
commit e3a704224f
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
5 changed files with 85 additions and 27 deletions

View file

@ -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