avoid crash when starting fsck --incremental when one is already running

Turns out sqlite does not like having its database deleted out from
underneath it. It might suffice to empty the table, but I would rather
start each fsck over with a new database, so I added a lock file, and
running incremental fscks use a shared lock.

This leaves one concurrency bug left; running two concurrent fsck --more
will lead to: "SQLite3 returned ErrorBusy while attempting to perform step."
and one or both will fail. This is a concurrent writers problem.

Database/Fsck.hs

@@ -11,8 +11,8 @@
 module Database.Fsck (
 	newPass,
 	openDb,
+	closeDb,
 	H.commitDb,
-	H.closeDb,
 	H.DbHandle,
 	addDb,
 	inDb,
@@ -26,6 +26,7 @@ import Utility.Directory
 import Annex
 import Types.Key
 import Annex.Perms
+import Annex.LockFile
 
 import Database.Persist.TH
 import Database.Esqueleto hiding (Key)
@@ -33,6 +34,8 @@ import Control.Monad
 import Control.Monad.IfElse
 import Control.Monad.IO.Class (liftIO)
 import System.Directory
+import Data.Maybe
+import Control.Applicative
 
 {- Each key stored in the database has already been fscked as part
  - of the latest incremental fsck pass. -}
@@ -42,9 +45,16 @@ Fscked
   UniqueKey key
 |]
 
-{- The database is removed when starting a new incremental fsck pass. -}
-newPass :: Annex ()
-newPass = liftIO. nukeFile =<< fromRepo gitAnnexFsckDb
+{- The database is removed when starting a new incremental fsck pass.
+ -
+ - This may fail, if other fsck processes are currently running using the
+ - database. Removing the database in that situation would lead to crashes
+ - or undefined behavior.
+ -}
+newPass :: Annex Bool
+newPass = isJust <$> tryExclusiveLock gitAnnexFsckDbLock go
+  where
+	go = liftIO. nukeFile =<< fromRepo gitAnnexFsckDb
 
 {- Opens the database, creating it atomically if it doesn't exist yet. -}
 openDb :: Annex H.DbHandle
@@ -58,8 +68,14 @@ openDb = do
 		liftIO $ H.closeDb h
 		setAnnexFilePerm newdb
 		liftIO $ renameFile newdb db
+	lockFileShared =<< fromRepo gitAnnexFsckDbLock
 	liftIO $ H.openDb db
 
+closeDb :: H.DbHandle -> Annex ()
+closeDb h = do
+	liftIO $ H.closeDb h
+	unlockFile =<< fromRepo gitAnnexFsckDbLock
+
 addDb :: H.DbHandle -> Key -> IO ()
 addDb h = void . H.runDb' h commitPolicy . insert . Fscked . toSKey