log migration trees to git-annex branch

This will allow distributed migration: Start a migration in one clone of
a repo, and then update other clones.

commitMigration is a bit of a bear.. There is some inversion of control
that needs some TMVars. Also streamLogFile's finalizer does not handle
recording the trees, so an interrupt at just the wrong time can cause
migration.log to be emptied but the git-annex branch not updated.

Sponsored-by: Graham Spencer on Patreon

1 files changed, 26 insertions, 14 deletions

diff --git a/Git/Tree.hs b/Git/Tree.hs
index c811b111c8..5c41f2882d 100644
--- a/Git/Tree.hs
+++ b/Git/Tree.hs
@@ -23,6 +23,7 @@ module Git.Tree (
 	graftTree',
 	withMkTreeHandle,
 	MkTreeHandle,
+	mkTree,
 	treeMode,
 ) where
 
@@ -91,28 +92,39 @@ recordTree :: Tree -> Repo -> IO Sha
 recordTree t repo = withMkTreeHandle repo $ \h -> recordTree' h t
 
 recordTree' :: MkTreeHandle -> Tree -> IO Sha
-recordTree' h (Tree l) = mkTree h =<< mapM (recordSubTree h) l
+recordTree' h (Tree l) = mkTree' h =<< mapM (recordSubTree h) l
 
 {- Note that the returned RecordedSubTree does not have its [TreeContent]
  - list populated. This is a memory optimisation, since the list is not
  - used. -}
 recordSubTree :: MkTreeHandle -> TreeContent -> IO TreeContent
 recordSubTree h (NewSubTree d l) = do
-	sha <- mkTree h =<< mapM (recordSubTree h) l
+	sha <- mkTree' h =<< mapM (recordSubTree h) l
 	return (RecordedSubTree d sha [])
 recordSubTree _ alreadyrecorded = return alreadyrecorded
- 
-mkTree :: MkTreeHandle -> [TreeContent] -> IO Sha
-mkTree (MkTreeHandle cp) l = CoProcess.query cp send receive
+
+{- Note that this creates a single tree. It cannot create a recursive tree
+ - with subtrees in a single call. -}
+mkTree
+	:: (MonadIO m, MonadCatch m)
+	=> MkTreeHandle
+	-> ((FileMode -> ObjectType -> Sha -> TopFilePath -> m ()) -> m ())
+	-> m Sha
+mkTree (MkTreeHandle cp) a = CoProcess.query cp send receive
   where
 	send h = do
-		forM_ l $ \i ->	hPutStr h $ case i of
-			TreeBlob f fm s -> mkTreeOutput fm BlobObject s f
-			RecordedSubTree f s _ -> mkTreeOutput treeMode TreeObject s f
-			NewSubTree _ _ -> error "recordSubTree internal error; unexpected NewSubTree"
-			TreeCommit f fm s -> mkTreeOutput fm CommitObject s f
-		hPutStr h "\NUL" -- signal end of tree to --batch
-	receive h = getSha "mktree" (S8.hGetLine h)
+		a $ \fm ot s f -> liftIO $ hPutStr h (mkTreeOutput fm ot s f)
+		-- NUL to signal end of tree to --batch
+		liftIO $ hPutStr h "\NUL"
+	receive h = liftIO $ getSha "mktree" (S8.hGetLine h)
+
+mkTree' :: MkTreeHandle -> [TreeContent] -> IO Sha
+mkTree' h l = mkTree h $ \send -> 
+	forM_ l $ \case
+		TreeBlob f fm s -> send fm BlobObject s f
+		RecordedSubTree f s _ -> send treeMode TreeObject s f
+		NewSubTree _ _ -> error "recordSubTree internal error; unexpected NewSubTree"
+		TreeCommit f fm s -> send fm CommitObject s f
 
 treeMode :: FileMode
 treeMode = 0o040000
@@ -221,7 +233,7 @@ adjustTree adjusttreeitem addtreeitems resolveaddconflict removefiles r repo =
 		(l, cleanup) <- liftIO $ lsTreeWithObjects LsTree.LsTreeRecursive r repo
 		(l', _, _) <- go h False [] 1 inTopTree l
 		l'' <- adjustlist h 0 inTopTree (const True) l'
-		sha <- liftIO $ mkTree h l''
+		sha <- liftIO $ mkTree' h l''
 		void $ liftIO cleanup
 		return sha
   where
@@ -332,7 +344,7 @@ graftTree' subtree graftloc basetree repo hdl = go basetree subdirs graftdirs
 							return $ RecordedSubTree tloc tsha'' []
 					_ -> graftin (topmostgraphdir:restgraphdirs)
 				return (newshas ++ rest)
-		mkTree hdl t'
+		mkTree' hdl t'
 	go _ _ [] = return subtree
 	go _ [] _ = return subtree