commit more transactions when fscking

This makes interrupt and resume work, robustly.

But, incremental fsck is slowed down by all those transactions..

2 files changed, 30 insertions, 17 deletions

diff --git a/Database/Fsck.hs b/Database/Fsck.hs
index f03a4c009..2b622e844 100644
--- a/Database/Fsck.hs
+++ b/Database/Fsck.hs
@@ -11,6 +11,7 @@
 module Database.Fsck (
 	newPass,
 	openDb,
+	H.commitDb,
 	H.closeDb,
 	H.DbHandle,
 	addDb,
@@ -60,11 +61,11 @@ openDb = do
 		liftIO $ renameFile newdb db
 	liftIO $ H.openDb db
 
-addDb :: H.DbHandle -> Key -> Annex ()
-addDb h = void . liftIO . H.runDb h . insert . Fscked . toSKey
+addDb :: H.DbHandle -> Key -> IO ()
+addDb h = void . H.runDb h . insert . Fscked . toSKey
 
-inDb :: H.DbHandle -> Key -> Annex Bool
-inDb h k = liftIO $ H.runDb h $ do
+inDb :: H.DbHandle -> Key -> IO Bool
+inDb h k = H.runDb h $ do
 	r <- select $ from $ \r -> do
 		where_ (r ^. FsckedKey ==. val (toSKey k))
 		return (r ^. FsckedKey)
diff --git a/Database/Handle.hs b/Database/Handle.hs
index c39dcfd2b..b42c32812 100644
--- a/Database/Handle.hs
+++ b/Database/Handle.hs
@@ -8,8 +8,9 @@
 module Database.Handle (
 	DbHandle,
 	openDb,
-	closeDb,
 	runDb,
+	commitDb,
+	closeDb,
 ) where
 
 import Utility.Exception
@@ -26,27 +27,28 @@ import qualified Data.Text as T
  - the database. It has a MVar which Jobs are submitted to. -}
 data DbHandle = DbHandle (Async ()) (MVar Job)
 
-data Job = Job (SqlPersistM ()) | CloseJob
+data Job = RunJob (SqlPersistM ()) | CommitJob | CloseJob
 
 openDb :: FilePath -> IO DbHandle
 openDb db = do
 	jobs <- newEmptyMVar
-	worker <- async (workerThread db jobs)
+	worker <- async (workerThread (T.pack db) jobs)
 	return $ DbHandle worker jobs
 
-workerThread :: FilePath -> MVar Job -> IO ()
-workerThread db jobs = runSqlite (T.pack db) go
+workerThread :: T.Text -> MVar Job -> IO ()
+workerThread db jobs = go
   where
 	go = do
+		r <- runSqlite db transaction
+		case r of
+			CloseJob -> return ()
+			_ -> go
+	transaction = do
 		job <- liftIO $ takeMVar jobs
 		case job of
-			Job a -> a >> go
-			CloseJob -> return ()
-
-closeDb :: DbHandle -> IO ()
-closeDb (DbHandle worker jobs) = do
-	putMVar jobs CloseJob
-	wait worker
+			RunJob a -> a >> transaction
+			CommitJob -> return CommitJob
+			CloseJob -> return CloseJob
 
 {- Runs an action using the DbHandle.
  -
@@ -59,5 +61,15 @@ closeDb (DbHandle worker jobs) = do
 runDb :: DbHandle -> SqlPersistM a -> IO a
 runDb (DbHandle _ jobs) a = do
 	res <- newEmptyMVar
-	putMVar jobs $ Job $ liftIO . putMVar res =<< tryNonAsync a
+	putMVar jobs $ RunJob $ liftIO . putMVar res =<< tryNonAsync a
 	either throwIO return =<< takeMVar res
+
+{- Commits any transaction that was created by the previous calls to runDb,
+ - and starts a new transaction. -}
+commitDb :: DbHandle -> IO ()
+commitDb (DbHandle _ jobs) = putMVar jobs CommitJob
+
+closeDb :: DbHandle -> IO ()
+closeDb (DbHandle worker jobs) = do
+	putMVar jobs CloseJob
+	wait worker