From 73b6c969bdda1b71b231915199cd10e9c590561f Mon Sep 17 00:00:00 2001 From: voidlizard Date: Sat, 1 Feb 2025 12:45:18 +0300 Subject: [PATCH] wip --- hbs2-git3/app/GitRemoteHelper.hs | 35 +++++++++++++-------------- hbs2-git3/lib/HBS2/Git3/Import.hs | 21 +++++++++++++---- hbs2-git3/lib/HBS2/Git3/Run.hs | 39 ++++++++++++++++++++++++++++++- 3 files changed, 72 insertions(+), 23 deletions(-) diff --git a/hbs2-git3/app/GitRemoteHelper.hs b/hbs2-git3/app/GitRemoteHelper.hs index 9c496568..e1095f35 100644 --- a/hbs2-git3/app/GitRemoteHelper.hs +++ b/hbs2-git3/app/GitRemoteHelper.hs @@ -77,6 +77,7 @@ localDict DeferredOps{..} = makeDict @C do t0 <- getTimeCoarse + waitRepo Nothing =<< getGitRepoKeyThrow importGitRefLog rrefs <- importedRefs @@ -136,26 +137,26 @@ main = flip runContT pure do setupLogger - -- origStderr <- liftIO $ dup stdError - -- (readEnd, writeEnd) <- liftIO createPipe - -- liftIO $ dupTo writeEnd stdError - -- liftIO $ closeFd writeEnd + origStderr <- liftIO $ dup stdError + (readEnd, writeEnd) <- liftIO createPipe + liftIO $ dupTo writeEnd stdError + liftIO $ closeFd writeEnd - -- rStderr <- liftIO $ fdToHandle readEnd - -- origHandle <- liftIO $ fdToHandle origStderr + rStderr <- liftIO $ fdToHandle readEnd + origHandle <- liftIO $ fdToHandle origStderr - -- liftIO $ hSetBuffering origHandle NoBuffering + liftIO $ hSetBuffering origHandle NoBuffering - -- -- liftIO $ IO.hPutStr origHandle "\n" - -- ContT $ withAsync $ liftIO $ forever do - -- -- pause @'Seconds 0.25 - -- wut <- IO.hGetContents rStderr <&> lines - -- for_ wut $ \s -> do - -- IO.hPutStr origHandle (replicate 100 ' ') - -- IO.hPutStr origHandle "\r" - -- IO.hPutStr origHandle s - -- IO.hPutStr origHandle "\r" - -- pause @'Seconds 0.05 + -- liftIO $ IO.hPutStr origHandle "\n" + ContT $ withAsync $ liftIO $ forever do + -- pause @'Seconds 0.25 + wut <- IO.hGetContents rStderr <&> lines + for_ wut $ \s -> do + IO.hPutStr origHandle (replicate 100 ' ') + IO.hPutStr origHandle "\r" + IO.hPutStr origHandle s + IO.hPutStr origHandle "\r" + pause @'Seconds 0.05 ContT $ bracket none $ const do -- IO.hPutStr origHandle (replicate 100 ' ') diff --git a/hbs2-git3/lib/HBS2/Git3/Import.hs b/hbs2-git3/lib/HBS2/Git3/Import.hs index 132aece0..71185adf 100644 --- a/hbs2-git3/lib/HBS2/Git3/Import.hs +++ b/hbs2-git3/lib/HBS2/Git3/Import.hs @@ -148,9 +148,16 @@ importGitRefLog = withStateDo $ ask >>= \case flip fix ImportStart $ \again -> \case ImportDone x -> do notice "import done" - for_ x updateImportedCheckpoint updateReflogIndex - pure x + for_ x updateImportedCheckpoint + + refs <- importedRefs + + if not (null refs && isJust x) then do + pure x + else do + notice $ "no refs arrived - go again" + again ImportStart ImportWait d next -> do @@ -186,6 +193,8 @@ importGitRefLog = withStateDo $ ask >>= \case ImportWIP attempt prev -> do + notice $ "download wip" <+> pretty attempt + r <- try @_ @OperationError $ do excl <- maybe1 prev (pure mempty) $ \p -> do @@ -215,7 +224,10 @@ importGitRefLog = withStateDo $ ask >>= \case next (xs, l) case cp' of - Nothing -> pure Nothing + Nothing -> do + notice "no checkpoints found" + pure Nothing + Just cp -> do notice $ "found checkpoint" <+> pretty cp @@ -242,8 +254,7 @@ importGitRefLog = withStateDo $ ask >>= \case Right cp -> again $ ImportDone cp Left (MissedBlockError2 _) -> notice "missed blocks" >> again (ImportWait Nothing (ImportWIP (succ attempt) prev)) Left MissedBlockError -> notice "missed blocks" >> again (ImportWait Nothing (ImportWIP (succ attempt) prev)) - Left e -> throwIO e - + Left e -> err (viaShow e) >> throwIO e groupKeysFile :: MonadIO m => Git3 m FilePath diff --git a/hbs2-git3/lib/HBS2/Git3/Run.hs b/hbs2-git3/lib/HBS2/Git3/Run.hs index 2fdc96ce..257277ba 100644 --- a/hbs2-git3/lib/HBS2/Git3/Run.hs +++ b/hbs2-git3/lib/HBS2/Git3/Run.hs @@ -176,7 +176,13 @@ compression ; prints compression level let (_, argz) = splitOpts [] syn - hash <- headMay [ x | GitHashLike x <- argz ] & orThrowUser "need sha1" + hash <- case argz of + [ x@StringLike{}, GitHashLike h ] -> do + resolveRepoKeyThrow [x] >>= setGitRepoKey + waitRepo Nothing =<< getGitRepoKeyThrow + pure h + + _ -> throwIO $ BadFormException @C nil idx <- openIndex @@ -361,6 +367,37 @@ compression ; prints compression level print $ pretty n -- notice $ pretty (length new) <+> "new objects" <+> "at" <+> pretty (realToFrac @_ @(Fixed E2) t4) + + entry $ bindMatch "reflog:tx:list:imported" $ nil_ $ \syn -> lift $ connectedDo do + resolveRepoKeyThrow syn >>= setGitRepoKey + waitRepo Nothing =<< getGitRepoKeyThrow + txImported >>= liftIO . print . vcat . (fmap pretty) . HS.toList + + let (opts, argz) = splitOpts [ ("--checkpoints",0) + , ("--segments",0) + ] syn + + let cpOnly = or [ True | ListVal [StringLike "--checkpoints"] <- opts ] + let sOnly = or [ True | ListVal [StringLike "--segments"] <- opts ] + + resolveRepoKeyThrow argz >>= setGitRepoKey + waitRepo Nothing =<< getGitRepoKeyThrow + + hxs <- txListAll Nothing + + liftIO $ forM_ hxs $ \(h,tx) -> do + let decoded = case tx of + TxSegment x | not cpOnly -> + Just ("S" <+> fill 44 (pretty h) <+> fill 44 (pretty x)) + + TxCheckpoint n x | not sOnly -> + Just ("C" <+> fill 44 (pretty h) <+> pretty x <+> fill 8 (pretty n)) + + _ -> Nothing + + forM_ decoded print + + entry $ bindMatch "reflog:tx:list" $ nil_ $ \syn -> lift $ connectedDo do let (opts, argz) = splitOpts [ ("--checkpoints",0)