add debugLocks around database operations

to track down a blocked indefinitely on MVar that seems to occur after
sqlite throws ErrorBusy but that I have not been able to reproduce when
I made commits synthetically throw ErrorBusy.

Sponsored-by: Dartmouth College's Datalad project

Database/Handle.hs

@@ -19,6 +19,7 @@ module Database.Handle (
 
 import Utility.Exception
 import Utility.FileSystemEncoding
+import Utility.DebugLocks
 
 import Database.Persist.Sqlite
 import qualified Database.Sqlite as Sqlite
@@ -57,7 +58,7 @@ openDb db tablename = do
  - auto-close. -}
 closeDb :: DbHandle -> IO ()
 closeDb (DbHandle worker jobs) = do
-	putMVar jobs CloseJob
+	debugLocks $ putMVar jobs CloseJob
 	wait worker
 
 {- Makes a query using the DbHandle. This should not be used to make
@@ -74,8 +75,8 @@ queryDb :: DbHandle -> SqlPersistM a -> IO a
 queryDb (DbHandle _ jobs) a = do
 	res <- newEmptyMVar
 	putMVar jobs $ QueryJob $
-		liftIO . putMVar res =<< tryNonAsync a
-	(either throwIO return =<< takeMVar res)
+		debugLocks $ liftIO . putMVar res =<< tryNonAsync a
+	debugLocks $ (either throwIO return =<< takeMVar res)
 		`catchNonAsync` (\e -> error $ "sqlite query crashed: " ++ show e)
 
 {- Writes a change to the database.
@@ -101,8 +102,8 @@ commitDb' :: DbHandle -> SqlPersistM () -> IO (Either SomeException ())
 commitDb' (DbHandle _ jobs) a = do
 	res <- newEmptyMVar
 	putMVar jobs $ ChangeJob $
-		liftIO . putMVar res =<< tryNonAsync a
-	takeMVar res
+		debugLocks $ liftIO . putMVar res =<< tryNonAsync a
+	debugLocks $ takeMVar res
 
 data Job
 	= QueryJob (SqlPersistM ())

Database/Keys/Handle.hs

@@ -16,6 +16,7 @@ module Database.Keys.Handle (
 
 import qualified Database.Queue as H
 import Utility.Exception
+import Utility.DebugLocks
 
 import Control.Concurrent
 import Control.Monad.IO.Class (liftIO, MonadIO)
@@ -42,16 +43,16 @@ withDbState
 	-> (DbState -> m (v, DbState))
 	-> m v
 withDbState (DbHandle mvar) a = do
-	st <- liftIO $ takeMVar mvar
-	go st `onException` (liftIO $ putMVar mvar st)
+	st <- liftIO $ debugLocks $ takeMVar mvar
+	go st `onException` (liftIO $ debugLocks $ putMVar mvar st)
   where
 	go st = do
 		(v, st') <- a st
-		liftIO $ putMVar mvar st'
+		liftIO $ debugLocks $ putMVar mvar st'
 		return v
 
 flushDbQueue :: DbHandle -> IO ()
-flushDbQueue (DbHandle mvar) = go =<< readMVar mvar
+flushDbQueue (DbHandle mvar) = go =<< debugLocks (readMVar mvar)
   where
 	go (DbOpen qh) = H.flushDbQueue qh
 	go _ = return ()

Database/Queue.hs

@@ -19,6 +19,7 @@ module Database.Queue (
 
 import Utility.Monad
 import Utility.RawFilePath
+import Utility.DebugLocks
 import Database.Handle
 
 import Database.Persist.Sqlite
@@ -51,12 +52,12 @@ closeDbQueue h@(DQ hdl _) = do
 {- Blocks until all queued changes have been written to the database. -}
 flushDbQueue :: DbQueue -> IO ()
 flushDbQueue (DQ hdl qvar) = do
-	q@(Queue sz _ qa) <- takeMVar qvar
+	q@(Queue sz _ qa) <- debugLocks $ takeMVar qvar
 	if sz > 0
 		then do
 			commitDb hdl qa
-			putMVar qvar =<< emptyQueue
-		else putMVar qvar q
+			debugLocks $ putMVar qvar =<< emptyQueue
+		else debugLocks $ putMVar qvar q
 
 {- Makes a query using the DbQueue's database connection.
  - This should not be used to make changes to the database!
@@ -95,10 +96,10 @@ queueDb
 	-> SqlPersistM ()
 	-> IO ()
 queueDb (DQ hdl qvar) commitchecker a = do
-	Queue sz lastcommittime qa <- takeMVar qvar
+	Queue sz lastcommittime qa <- debugLocks $ takeMVar qvar
 	let !sz' = sz + 1
 	let qa' = qa >> a
-	let enqueue = putMVar qvar
+	let enqueue = debugLocks . putMVar qvar
 	ifM (commitchecker sz' lastcommittime)
 		( do
 			r <- commitDb' hdl qa'

Makefile

@@ -35,7 +35,7 @@ install-home:
 tmp/configure-stamp: Build/TestConfig.hs Build/Configure.hs
 	if [ "$(BUILDER)" = ./Setup ]; then $(GHC) --make Setup; fi
 	if [ "$(BUILDER)" != stack ]; then \
-		$(BUILDER) configure $(BUILDERCOMMONOPTIONS) --ghc-options="$(shell Build/collect-ghc-options.sh)"; \
+		$(BUILDER) configure -f debuglocks $(BUILDERCOMMONOPTIONS) --ghc-options="$(shell Build/collect-ghc-options.sh)"; \
 	else \
 		$(BUILDER) setup $(BUILDERCOMMONOPTIONS); \
 	fi

doc/bugs/get_is_busy_doing_nothing/comment_13_bdfbcb8b6052a3c904e46678fce6adeb._comment

@@ -0,0 +1,14 @@
+[[!comment format=mdwn
+ username="joey"
+ subject="""comment 13"""
+ date="2022-06-03T17:52:12Z"
+ content="""
+To hopefully find out what MVar operation is blocking, I have added lock
+debugging instrumentation to all database calls. This will need a special
+build of git-annex with the DebugLocks build flag enabled. 
+
+I have made a standalone tarball built that way available here:
+<https://downloads.kitenet.net/git-annex/linux/debuglocks/>
+
+It should display a backtrace on stderr when the MVar deadlock happens.
+"""]]