add annex.dbdir (WIP)

WIP: This is mostly complete, but there is a problem: createDirectoryUnder
throws an error when annex.dbdir is set to outside the git repo.

annex.dbdir is a workaround for filesystems where sqlite does not work,
due to eg, the filesystem not properly supporting locking.

It's intended to be set before initializing the repository. Changing it
in an existing repository can be done, but would be the same as making a
new repository and moving all the annexed objects into it. While the
databases get recreated from the git-annex branch in that situation, any
information that is in the databases but not stored in the branch gets
lost. It may be that no information ever gets stored in the databases
that cannot be reconstructed from the branch, but I have not verified
that.

Sponsored-by: Dartmouth College's Datalad project

Database/ContentIdentifier.hs

@@ -78,7 +78,7 @@ AnnexBranch
  -}
 openDb :: Annex ContentIdentifierHandle
 openDb = do
-	dbdir <- fromRepo gitAnnexContentIdentifierDbDir
+	dbdir <- calcRepo' gitAnnexContentIdentifierDbDir
 	let db = dbdir P.</> "db"
 	ifM (liftIO $ not <$> R.doesPathExist db)
 		( initDb db $ void $ 

Database/Export.hs

@@ -99,7 +99,7 @@ ExportTreeCurrent
  -}
 openDb :: UUID -> Annex ExportHandle
 openDb u = do
-	dbdir <- fromRepo (gitAnnexExportDbDir u)
+	dbdir <- calcRepo' (gitAnnexExportDbDir u)
 	let db = dbdir P.</> "db"
 	unlessM (liftIO $ R.doesPathExist db) $ do
 		initDb db $ void $
@@ -263,8 +263,9 @@ updateExportDb = runExportDiffUpdater $ mkExportDiffUpdater removeold addnew
  -}
 writeLockDbWhile :: ExportHandle -> Annex a -> Annex a
 writeLockDbWhile db@(ExportHandle _ u) a = do
-	updatelck <- takeExclusiveLock (gitAnnexExportUpdateLock u)
-	withExclusiveLock (gitAnnexExportLock u) $ do
+	updatelck <- takeExclusiveLock =<< calcRepo' (gitAnnexExportUpdateLock u)
+	exlck <- calcRepo' (gitAnnexExportLock u)
+	withExclusiveLock exlck $ do
 		bracket_ (setup updatelck) cleanup a
   where
 	setup updatelck = do
@@ -285,15 +286,17 @@ data ExportUpdateResult = ExportUpdateSuccess | ExportUpdateConflict
  - not. Either way, it will block until the update is complete.
  -}
 updateExportTreeFromLog :: ExportHandle -> Annex ExportUpdateResult
-updateExportTreeFromLog db@(ExportHandle _ u) =
+updateExportTreeFromLog db@(ExportHandle _ u) = do
 	-- If another process or thread is performing the update,
 	-- this will block until it's done.
-	withExclusiveLock (gitAnnexExportUpdateLock u) $ do
+	exlck <- calcRepo' (gitAnnexExportUpdateLock u)
+	withExclusiveLock exlck $ do
+		lck <- calcRepo' (gitAnnexExportLock u)
 		-- 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) $
+		mr <- tryExclusiveLock lck $
 			updateExportTreeFromLog' db
 		case mr of
 			Just r -> return r

Database/Fsck.hs

@@ -60,29 +60,31 @@ Fscked
  - or unknown behavior.
  -}
 newPass :: UUID -> Annex Bool
-newPass u = isJust <$> tryExclusiveLock (gitAnnexFsckDbLock u) go
+newPass u = do
+	lck <- calcRepo' (gitAnnexFsckDbLock u)
+	isJust <$> tryExclusiveLock lck go
   where
 	go = do
-		removedb =<< fromRepo (gitAnnexFsckDbDir u)
-		removedb =<< fromRepo (gitAnnexFsckDbDirOld u)
+		removedb =<< calcRepo' (gitAnnexFsckDbDir u)
+		removedb =<< calcRepo' (gitAnnexFsckDbDirOld u)
 	removedb = liftIO . void . tryIO . removeDirectoryRecursive . fromRawFilePath
 
 {- Opens the database, creating it if it doesn't exist yet. -}
 openDb :: UUID -> Annex FsckHandle
 openDb u = do
-	dbdir <- fromRepo (gitAnnexFsckDbDir u)
+	dbdir <- calcRepo' (gitAnnexFsckDbDir u)
 	let db = dbdir P.</> "db"
 	unlessM (liftIO $ R.doesPathExist db) $ do
 		initDb db $ void $
 			runMigrationSilent migrateFsck
-	lockFileCached =<< fromRepo (gitAnnexFsckDbLock u)
+	lockFileCached =<< calcRepo' (gitAnnexFsckDbLock u)
 	h <- liftIO $ H.openDbQueue db "fscked"
 	return $ FsckHandle h u
 
 closeDb :: FsckHandle -> Annex ()
 closeDb (FsckHandle h u) = do
 	liftIO $ H.closeDbQueue h
-	unlockFile =<< fromRepo (gitAnnexFsckDbLock u)
+	unlockFile =<< calcRepo' (gitAnnexFsckDbLock u)
 
 addDb :: FsckHandle -> Key -> IO ()
 addDb (FsckHandle h _) k = H.queueDb h checkcommit $

Database/Init.hs

@@ -10,6 +10,7 @@
 module Database.Init where
 
 import Annex.Common
+import qualified Annex
 import Annex.Perms
 import Utility.FileMode
 import Utility.Directory.Create
@@ -34,7 +35,10 @@ initDb db migration = do
 	let tmpdbdir = dbdir <> ".tmp"
 	let tmpdb = tmpdbdir P.</> "db"
 	let tdb = T.pack (fromRawFilePath tmpdb)
-	top <- parentDir <$> fromRepo gitAnnexDir
+	gc <- Annex.getGitConfig
+	top <- case annexDbDir gc of
+		Just topdbdir -> pure $ parentDir $ topdbdir
+		Nothing -> parentDir <$> fromRepo gitAnnexDir
 	liftIO $ do
 		createDirectoryUnder top tmpdbdir
 		runSqliteInfo (enableWAL tdb) migration

Database/Keys.hs

@@ -118,15 +118,17 @@ runWriterIO a = runWriter (liftIO . a)
 openDb :: Bool -> DbState -> Annex DbState
 openDb _ st@(DbOpen _) = return st
 openDb False DbUnavailable = return DbUnavailable
-openDb forwrite _ = catchPermissionDenied permerr $ withExclusiveLock gitAnnexKeysDbLock $ do
-	dbdir <- fromRepo gitAnnexKeysDb
-	let db = dbdir P.</> "db"
-	dbexists <- liftIO $ R.doesPathExist db
-	case dbexists of
-		True -> open db
-		False -> do
-			initDb db SQL.createTables
-			open db
+openDb forwrite _ = do
+	lck <- calcRepo' gitAnnexKeysDbLock
+	catchPermissionDenied permerr $ withExclusiveLock lck $ do
+		dbdir <- calcRepo' gitAnnexKeysDbDir
+		let db = dbdir P.</> "db"
+		dbexists <- liftIO $ R.doesPathExist db
+		case dbexists of
+			True -> open db
+			False -> do
+				initDb db SQL.createTables
+				open db
   where
 	-- If permissions don't allow opening the database, and it's being
 	-- opened for read, treat it as if it does not exist.
@@ -248,7 +250,7 @@ isInodeKnown i s = or <$> runReaderIO ((:[]) <$$> SQL.isInodeKnown i s)
 reconcileStaged :: H.DbQueue -> Annex ()
 reconcileStaged qh = unlessM (Git.Config.isBare <$> gitRepo) $ do
 	gitindex <- inRepo currentIndexFile
-	indexcache <- fromRawFilePath <$> fromRepo gitAnnexKeysDbIndexCache
+	indexcache <- fromRawFilePath <$> calcRepo' gitAnnexKeysDbIndexCache
 	withTSDelta (liftIO . genInodeCache gitindex) >>= \case
 		Just cur -> readindexcache indexcache >>= \case
 			Nothing -> go cur indexcache =<< getindextree