voidlizard
/
hbs2
mirror of https://github.com/voidlizard/hbs2
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

wip, better wait for blocks

This commit is contained in:
voidlizard 2025-01-22 11:02:51 +03:00
parent b263bfbdc9
commit 3d78882f62
1 changed files with 61 additions and 46 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

49
hbs2-git3/lib/HBS2/Git3/Import.hs
View File

@ -110,7 +110,7 @@ writeAsGitPack dir href = do
data ImportStage = data ImportStage =
ImportStart ImportStart
| ImportWIP Int (Maybe HashRef) | ImportWIP Int (Maybe HashRef)
| ImportWait ImportStage | ImportWait (Maybe Int) ImportStage
| ImportDone (Maybe HashRef) | ImportDone (Maybe HashRef)
importGitRefLog :: forall m . ( HBS2GitPerks m importGitRefLog :: forall m . ( HBS2GitPerks m
@ -134,13 +134,26 @@ importGitRefLog = withStateDo $ ask >>= \case
sto <- getStorage sto <- getStorage
flip fix ImportStart $ \again -> \case already_ <- newTVarIO (mempty :: HashSet HashRef)
ImportDone x -> pure x
ImportWait next -> do flip fix ImportStart $ \again -> \case
notice "wait some time..." ImportDone x -> do
pause @'Seconds 3 for_ x updateImportedCheckpoint
again next updateReflogIndex
pure x
ImportWait d next -> do
down <- callRpcWaitMay @RpcDownloadList (TimeoutSec 1) peerAPI ()
>>= orThrow RpcTimeout
<&> fromIntegral . L.length
notice $ "wait some time..." <+> parens (pretty down)
case d of
Nothing -> again (ImportWait (Just down) next)
Just n | down < n -> pause @'Seconds 3 >> again next
| otherwise -> pause @'Seconds 3 >> again next
ImportStart -> do ImportStart -> do
@ -156,7 +169,7 @@ importGitRefLog = withStateDo $ ask >>= \case
ImportWIP attempt prev -> do ImportWIP attempt prev -> do
updateReflogIndex r <- try @_ @OperationError $ do
excl <- maybe1 prev (pure mempty) $ \p -> do excl <- maybe1 prev (pure mempty) $ \p -> do
txListAll (Just p) <&> HS.fromList . fmap fst txListAll (Just p) <&> HS.fromList . fmap fst
@ -185,31 +198,33 @@ importGitRefLog = withStateDo $ ask >>= \case
next (xs, l) next (xs, l)
case cp' of case cp' of
Nothing -> again $ ImportDone Nothing Nothing -> pure Nothing
Just cp -> do Just cp -> do
notice $ "found checkpoint" <+> pretty cp notice $ "found checkpoint" <+> pretty cp
txs <- txList ( pure . not . flip HS.member excl ) (Just cp) txs <- txList ( pure . not . flip HS.member excl ) (Just cp)
r <- liftIO $ try @_ @SomeException $ withGit3Env env do
forConcurrently_ txs $ \case forConcurrently_ txs $ \case
(_, TxCheckpoint{}) -> none (_, TxCheckpoint{}) -> none
(h, TxSegment tree) -> do (h, TxSegment tree) -> do
new <- readTVarIO already_ <&> not . HS.member tree
when new do
s <- writeAsGitPack packs tree s <- writeAsGitPack packs tree
for_ s $ \file -> do for_ s $ \file -> do
gitRunCommand [qc|git index-pack {file}|] gitRunCommand [qc|git index-pack {file}|]
>>= orThrowPassIO >>= orThrowPassIO
atomically $ modifyTVar already_ (HS.insert tree)
notice $ "imported" <+> pretty h notice $ "imported" <+> pretty h
updateImportedCheckpoint cp pure (Just cp)
case r of case r of
Right _ -> again $ ImportDone (Just cp) Right cp -> again $ ImportDone cp
Left e -> do Left (MissedBlockError2 _) -> again $ ImportWait Nothing (ImportWIP (succ attempt) prev)
case (fromException e :: Maybe OperationError) of Left MissedBlockError -> again $ ImportWait Nothing (ImportWIP (succ attempt) prev)
Just (MissedBlockError2 _) -> again $ ImportWait (ImportWIP (succ attempt) prev) Left e -> throwIO e
Just MissedBlockError -> again $ ImportWait (ImportWIP (succ attempt) prev)
_ -> throwIO e