associated files database

Database/AssociatedFiles.hs

@@ -0,0 +1,94 @@
+{- Sqlite database used for tracking a key's associated files.
+ -
+ - Copyright 2015 Joey Hess <id@joeyh.name>
+ -:
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell #-}
+{-# LANGUAGE OverloadedStrings, GADTs, FlexibleContexts #-}
+{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE RankNTypes #-}
+
+module Database.AssociatedFiles (
+	DbHandle,
+	openDb,
+	closeDb,
+	addDb,
+	getDb,
+	removeDb,
+	AssociatedId,
+) where
+
+import Database.Types
+import qualified Database.Handle as H
+import Locations
+import Common hiding (delete)
+import Annex
+import Types.Key
+import Annex.Perms
+import Annex.LockFile
+import Messages
+
+import Database.Persist.TH
+import Database.Esqueleto hiding (Key)
+
+newtype DbHandle = DbHandle H.DbHandle
+
+share [mkPersist sqlSettings, mkMigrate "migrateAssociated"] [persistLowerCase|
+Associated
+  key SKey
+  file FilePath
+  KeyFileIndex key file
+|]
+
+{- Opens the database, creating it if it doesn't exist yet. -}
+openDb :: Annex DbHandle
+openDb = withExclusiveLock gitAnnexAssociatedFilesDbLock $ do
+	dbdir <- fromRepo gitAnnexAssociatedFilesDb
+	let db = dbdir </> "db"
+	unlessM (liftIO $ doesFileExist db) $ do
+		liftIO $ do
+			createDirectoryIfMissing True dbdir
+			H.initDb db $ void $
+				runMigrationSilent migrateAssociated
+		setAnnexDirPerm dbdir
+		setAnnexFilePerm db
+	h <- liftIO $ H.openDb db "associated"
+
+	-- work around https://github.com/yesodweb/persistent/issues/474
+	liftIO setConsoleEncoding
+
+	return $ DbHandle h
+
+closeDb :: DbHandle -> IO ()
+closeDb (DbHandle h) = H.closeDb h
+
+addDb :: DbHandle -> Key -> FilePath -> IO ()
+addDb (DbHandle h) k f = H.queueDb h (\_ _ -> pure True) $ do
+	-- If the same file was associated with a different key before,
+	-- remove that.
+	delete $ from $ \r -> do
+		where_ (r ^. AssociatedFile ==. val f &&. r ^. AssociatedKey ==. val sk)
+	void $ insertUnique $ Associated sk f
+  where
+	sk = toSKey k
+
+{- Note that the files returned used to be associated with the key, but
+ - some of them may not be any longer. -}
+getDb :: DbHandle -> Key -> IO [FilePath]
+getDb (DbHandle h) = H.queryDb h . getDb' . toSKey
+
+getDb' :: SKey -> SqlPersistM [FilePath]
+getDb' sk = do
+	l <- select $ from $ \r -> do
+		where_ (r ^. AssociatedKey ==. val sk)
+		return (r ^. AssociatedFile)
+	return $ map unValue l
+
+removeDb :: DbHandle -> Key -> FilePath -> IO ()
+removeDb (DbHandle h) k f =  H.queueDb h (\_ _ -> pure True) $
+	delete $ from $ \r -> do
+		where_ (r ^. AssociatedKey ==. val sk &&. r ^. AssociatedFile ==. val f)
+  where
+	sk = toSKey k

Database/Fsck.hs

@@ -59,7 +59,7 @@ newPass u = isJust <$> tryExclusiveLock (gitAnnexFsckDbLock u) go
 	go = liftIO . void . tryIO . removeDirectoryRecursive
 		=<< fromRepo (gitAnnexFsckDbDir u)
 
-{- Opens the database, creating it atomically if it doesn't exist yet. -}
+{- Opens the database, creating it if it doesn't exist yet. -}
 openDb :: UUID -> Annex FsckHandle
 openDb u = do
 	dbdir <- fromRepo (gitAnnexFsckDbDir u)

Locations.hs

@@ -29,6 +29,8 @@ module Locations (
 	gitAnnexBadDir,
 	gitAnnexBadLocation,
 	gitAnnexUnusedLog,
+	gitAnnexAssociatedFilesDb,
+	gitAnnexAssociatedFilesDbLock,
 	gitAnnexFsckState,
 	gitAnnexFsckDbDir,
 	gitAnnexFsckDbLock,
@@ -237,6 +239,14 @@ gitAnnexBadLocation key r = gitAnnexBadDir r </> keyFile key
 gitAnnexUnusedLog :: FilePath -> Git.Repo -> FilePath
 gitAnnexUnusedLog prefix r = gitAnnexDir r </> (prefix ++ "unused")
 
+{- .git/annex/map/ contains a database for the associated files map -}
+gitAnnexAssociatedFilesDb :: Git.Repo -> FilePath
+gitAnnexAssociatedFilesDb r = gitAnnexDir r </> "map"
+
+{- Lock file for the associated files map database. -}
+gitAnnexAssociatedFilesDbLock :: Git.Repo -> FilePath
+gitAnnexAssociatedFilesDbLock r = gitAnnexAssociatedFilesDb r ++ "lck"
+
 {- .git/annex/fsck/uuid/ is used to store information about incremental
  - fscks. -}
 gitAnnexFsckDir :: UUID -> Git.Repo -> FilePath