track exported files in a sqlite database

Went with a separate db per export remote, rather than a single export
database. Mostly because there will probably not be a lot of separate
export remotes, and it might be convenient to be able to delete a given
remote's export database.

This commit was supported by the NSF-funded DataLad project.

1 files changed, 85 insertions, 0 deletions

diff --git a/Database/Export.hs b/Database/Export.hs
new file mode 100644
index 000000000..bc79af29f
--- /dev/null
+++ b/Database/Export.hs
@@ -0,0 +1,85 @@
+{- Sqlite database used for exports to special remotes.
+ -
+ - Copyright 2017 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.Export (
+	ExportHandle,
+	openDb,
+	closeDb,
+	addExportLocation,
+	removeExportLocation,
+	getExportLocation,
+	ExportedId,
+) where
+
+import Database.Types
+import qualified Database.Queue as H
+import Database.Init
+import Annex.Locations
+import Annex.Common hiding (delete)
+import Types.Remote (ExportLocation(..))
+
+import Database.Persist.TH
+import Database.Esqueleto hiding (Key)
+
+data ExportHandle = ExportHandle H.DbQueue
+
+share [mkPersist sqlSettings, mkMigrate "migrateExport"] [persistLowerCase|
+Exported
+  key IKey
+  file SFilePath
+  KeyFileIndex key file
+  UniqueKey key
+|]
+
+{- Opens the database, creating it if it doesn't exist yet. -}
+openDb :: UUID -> Annex ExportHandle
+openDb u = do
+	dbdir <- fromRepo (gitAnnexExportDbDir u)
+	let db = dbdir </> "db"
+	unlessM (liftIO $ doesFileExist db) $ do
+		initDb db $ void $
+			runMigrationSilent migrateExport
+	h <- liftIO $ H.openDbQueue db "exported"
+	return $ ExportHandle h
+
+closeDb :: ExportHandle -> Annex ()
+closeDb (ExportHandle h) = liftIO $ H.closeDbQueue h
+
+queueDb :: ExportHandle -> SqlPersistM () -> IO ()
+queueDb (ExportHandle h) = H.queueDb h checkcommit
+  where
+	-- commit queue after 1000 changes
+	checkcommit sz _lastcommittime
+		| sz > 1000 = return True
+		| otherwise = return False
+
+addExportLocation :: ExportHandle -> Key -> ExportLocation -> IO ()
+addExportLocation h k (ExportLocation f) = queueDb h $ 
+	void $ insertUnique $ Exported (toIKey k) (toSFilePath f)
+
+removeExportLocation :: ExportHandle -> Key -> ExportLocation -> IO ()
+removeExportLocation h k (ExportLocation f) = queueDb h $
+	delete $ from $ \r -> do
+		where_ (r ^. ExportedKey ==. val ik &&. r ^. ExportedFile ==. val ef)
+  where
+	ik = toIKey k
+	ef = toSFilePath f
+
+{- Doesn't know about recently queued changes. -}
+getExportLocation :: ExportHandle -> Key -> IO [ExportLocation]
+getExportLocation (ExportHandle h) k = H.queryDbQueue h $ do
+	l <- select $ from $ \r -> do
+		where_ (r ^. ExportedKey ==. val ik)
+		return (r ^. ExportedFile)
+	return $ map (ExportLocation . fromSFilePath . unValue) l
+  where
+	ik = toIKey k