add ExportTree table to export db

New table needed to look up what filenames are used in the currently
exported tree, for reasons explained in export.mdwn.

Also, added smart constructors for ExportLocation and ExportDirectory to
make sure they contain filepaths with the right direction slashes.

And some code refactoring.

This commit was sponsored by Francois Marier on Patreon.

Database/Export.hs

@@ -14,13 +14,19 @@ module Database.Export (
 	ExportHandle,
 	openDb,
 	closeDb,
-	addExportLocation,
-	removeExportLocation,
 	flushDbQueue,
-	getExportLocation,
+	recordDataSource,
+	getDataSource,
+	addExportedLocation,
+	removeExportedLocation,
+	getExportedLocation,
 	isExportDirectoryEmpty,
+	getExportTree,
+	updateExportTree,
 	ExportedId,
+	ExportTreeId,
 	ExportedDirectoryId,
+	DataSourceId,
 ) where
 
 import Database.Types
@@ -29,6 +35,11 @@ import Database.Init
 import Annex.Locations
 import Annex.Common hiding (delete)
 import Types.Export
+import Annex.Export
+import Git.Types
+import Git.Sha
+import Git.FilePath
+import qualified Git.DiffTree
 
 import Database.Persist.TH
 import Database.Esqueleto hiding (Key)
@@ -36,14 +47,26 @@ import Database.Esqueleto hiding (Key)
 newtype ExportHandle = ExportHandle H.DbQueue
 
 share [mkPersist sqlSettings, mkMigrate "migrateExport"] [persistLowerCase|
+-- Files that have been exported to the remote.
 Exported
   key IKey
   file SFilePath
-  KeyFileIndex key file
+  ExportedIndex key file
+-- The tree that has been exported to the remote. 
+-- Not all of these files are necessarily present on the remote yet.
+ExportTree
+  key IKey
+  file SFilePath
+  ExportTreeIndex key file
+-- Directories that exist on the remote, and the files that are in them.
 ExportedDirectory
   subdir SFilePath
   file SFilePath
-  SubdirFileIndex subdir file
+  ExportedDirectoryIndex subdir file
+-- Record of what tree the current database content comes from.
+DataSource
+  tree SRef
+  UniqueTree tree
 |]
 
 {- Opens the database, creating it if it doesn't exist yet. -}
@@ -68,48 +91,110 @@ queueDb (ExportHandle h) = H.queueDb h checkcommit
 		| sz > 1000 = return True
 		| otherwise = return False
 
-addExportLocation :: ExportHandle -> Key -> ExportLocation -> IO ()
-addExportLocation h k el@(ExportLocation f) = queueDb h $ do
+flushDbQueue :: ExportHandle -> IO ()
+flushDbQueue (ExportHandle h) = H.flushDbQueue h
+
+recordDataSource :: ExportHandle -> Sha -> IO ()
+recordDataSource h s = queueDb h $ do
+	delete $ from $ \r -> do
+		where_ (r ^. DataSourceTree ==. r ^. DataSourceTree)
+	void $ insertUnique $ DataSource (toSRef s)
+
+getDataSource :: ExportHandle -> IO (Maybe Sha)
+getDataSource (ExportHandle h) = H.queryDbQueue h $ do
+	l <- select $ from $ \r -> do
+		where_ (r ^. DataSourceTree ==. r ^. DataSourceTree)
+		return (r ^. DataSourceTree)
+	case l of
+		(s:[]) -> return (Just (fromSRef (unValue s)))
+		_ -> return Nothing
+
+addExportedLocation :: ExportHandle -> Key -> ExportLocation -> IO ()
+addExportedLocation h k el = queueDb h $ do
 	void $ insertUnique $ Exported ik ef
 	insertMany_ $ map
-		(\(ExportDirectory d) -> ExportedDirectory (toSFilePath d) ef)
+		(\ed -> ExportedDirectory (toSFilePath (fromExportDirectory ed)) ef)
 		(exportDirectories el)
   where
 	ik = toIKey k
-	ef = toSFilePath f
+	ef = toSFilePath (fromExportLocation el)
 
-removeExportLocation :: ExportHandle -> Key -> ExportLocation -> IO ()
-removeExportLocation h k el@(ExportLocation f) = queueDb h $ do
+removeExportedLocation :: ExportHandle -> Key -> ExportLocation -> IO ()
+removeExportedLocation h k el = queueDb h $ do
 	delete $ from $ \r -> do
 		where_ (r ^. ExportedKey ==. val ik &&. r ^. ExportedFile ==. val ef)
-	let subdirs = map (\(ExportDirectory d) -> toSFilePath d)
+	let subdirs = map (toSFilePath . fromExportDirectory)
 		(exportDirectories el)
 	delete $ from $ \r -> do
 		where_ (r ^. ExportedDirectoryFile ==. val ef
 			&&. r ^. ExportedDirectorySubdir `in_` valList subdirs)
   where
 	ik = toIKey k
-	ef = toSFilePath f
-
-flushDbQueue :: ExportHandle -> IO ()
-flushDbQueue (ExportHandle h) = H.flushDbQueue h
+	ef = toSFilePath (fromExportLocation el)
 
 {- Note that this does not see recently queued changes. -}
-getExportLocation :: ExportHandle -> Key -> IO [ExportLocation]
-getExportLocation (ExportHandle h) k = H.queryDbQueue h $ do
+getExportedLocation :: ExportHandle -> Key -> IO [ExportLocation]
+getExportedLocation (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
+	return $ map (mkExportLocation . fromSFilePath . unValue) l
   where
 	ik = toIKey k
 
 {- Note that this does not see recently queued changes. -}
 isExportDirectoryEmpty :: ExportHandle -> ExportDirectory -> IO Bool
-isExportDirectoryEmpty (ExportHandle h) (ExportDirectory d) = H.queryDbQueue h $ do
+isExportDirectoryEmpty (ExportHandle h) d = H.queryDbQueue h $ do
 	l <- select $ from $ \r -> do
 		where_ (r ^. ExportedDirectorySubdir ==. val ed)
 		return (r ^. ExportedDirectoryFile)
 	return $ null l
   where
-	ed = toSFilePath d
+	ed = toSFilePath $ fromExportDirectory d
+
+{- Get locations in the export that might contain a key. -}
+getExportTree :: ExportHandle -> Key -> IO [ExportLocation]
+getExportTree (ExportHandle h) k = H.queryDbQueue h $ do
+	l <- select $ from $ \r -> do
+		where_ (r ^. ExportTreeKey ==. val ik)
+		return (r ^. ExportTreeFile)
+	return $ map (mkExportLocation . fromSFilePath . unValue) l
+  where
+	ik = toIKey k
+
+addExportTree :: ExportHandle -> Key -> ExportLocation -> IO ()
+addExportTree h k loc = queueDb h $
+	void $ insertUnique $ Exported ik ef
+  where
+	ik = toIKey k
+	ef = toSFilePath (fromExportLocation loc)
+
+removeExportTree :: ExportHandle -> Key -> ExportLocation -> IO ()
+removeExportTree h k loc = queueDb h $ 
+	delete $ from $ \r ->
+		where_ (r ^. ExportTreeKey ==. val ik &&. r ^. ExportTreeFile ==. val ef)
+  where
+	ik = toIKey k
+	ef = toSFilePath (fromExportLocation loc)
+
+{- Diff from the old to the new tree and update the ExportTree table. -}
+updateExportTree :: ExportHandle -> Sha -> Sha -> Annex ()
+updateExportTree h old new = do
+	(diff, cleanup) <- inRepo $
+		Git.DiffTree.diffTreeRecursive old new
+	forM_ diff $ \i -> do
+		let loc = mkExportLocation $ getTopFilePath $
+			Git.DiffTree.file i
+		srcek <- getek (Git.DiffTree.srcsha i)
+		case srcek of
+			Nothing -> return ()
+			Just k -> liftIO $ removeExportTree h (asKey k) loc
+		dstek <- getek (Git.DiffTree.dstsha i)
+		case dstek of
+			Nothing -> return ()
+			Just k -> liftIO $ addExportTree h (asKey k) loc
+	void $ liftIO cleanup
+  where
+	getek sha
+		| sha == nullSha = return Nothing
+		| otherwise = Just <$> exportKey sha

Database/Types.hs

@@ -1,6 +1,6 @@
 {- types for SQL databases
  -
- - Copyright 2015-2016 Joey Hess <id@joeyh.name>
+ - Copyright 2015-2017 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -16,6 +16,7 @@ import Data.Char
 import Utility.PartialPrelude
 import Key
 import Utility.InodeCache
+import Git.Types (Ref(..))
 
 -- A serialized Key
 newtype SKey = SKey String
@@ -93,3 +94,21 @@ fromSFilePath (SFilePath s) = s
 
 derivePersistField "SFilePath"
 
+-- A serialized Ref
+newtype SRef = SRef Ref
+
+-- Note that Read instance does not work when used in any kind of complex
+-- data structure.
+instance Read SRef where
+	readsPrec _ s = [(SRef (Ref s), "")]
+
+instance Show SRef where
+	show (SRef (Ref s)) = s
+
+derivePersistField "SRef"
+
+toSRef :: Ref -> SRef
+toSRef = SRef
+
+fromSRef :: SRef -> Ref
+fromSRef (SRef r) = r