wip

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 ' ')

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

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)