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
This commit is contained in:
Joey Hess 2023-12-06 15:38:01 -04:00
parent b55efc179a
commit 0bd8b17b59
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
12 changed files with 219 additions and 43 deletions

View file

@ -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