From 9e2257f9ef398a628423a5160bc7fc86f3d98be6 Mon Sep 17 00:00:00 2001 From: voidlizard Date: Thu, 13 Feb 2025 10:41:54 +0300 Subject: [PATCH] wip, console logs --- hbs2-git3/app/GitRemoteHelper.hs | 68 ++++++++++++++++++++++++------- hbs2-git3/lib/HBS2/Git3/Import.hs | 20 ++++----- hbs2-git3/lib/HBS2/Git3/Logger.hs | 2 + 3 files changed, 66 insertions(+), 24 deletions(-) diff --git a/hbs2-git3/app/GitRemoteHelper.hs b/hbs2-git3/app/GitRemoteHelper.hs index 7e634d93..da84a809 100644 --- a/hbs2-git3/app/GitRemoteHelper.hs +++ b/hbs2-git3/app/GitRemoteHelper.hs @@ -15,6 +15,8 @@ import HBS2.Git3.Logger import Data.Config.Suckless +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import Data.Time.Format (formatTime, defaultTimeLocale) import System.Posix.Signals import System.IO qualified as IO import System.Posix.IO @@ -31,6 +33,10 @@ import System.Exit hiding (die) import System.Console.ANSI +formatTs :: Int -> String +formatTs ts = + formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S" (posixSecondsToUTCTime (fromIntegral ts)) + {- HLINT ignore "Use isEOF" -} {- HLINT ignore "Use putStrLn" -} @@ -132,6 +138,7 @@ localDict DeferredOps{..} = makeDict @C do runTop :: (ParseSExp what, MonadUnliftIO m) => Dict C m -> what -> m () runTop dict s = parseTop s & either (const none) (void . run dict) + {- HLINT ignore "Functor law" -} main :: IO () main = flip runContT pure do @@ -150,23 +157,53 @@ main = flip runContT pure do 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 + lift $ void $ installHandler sigPIPE Ignore Nothing - hClearLine origHandle - hSetCursorColumn origHandle 0 - IO.hPutStr origHandle s - hSetCursorColumn origHandle 0 - -- pause @'Seconds 0.05 + cp_ <- newTVarIO Nothing + + ContT $ withAsync $ liftIO $ flip runContT pure do + callCC \finished -> do + forever do + + pause @'Seconds 0.1 + + wut <- liftIO $ IO.hGetContents rStderr <&> lines + for_ wut $ \s -> do + + let what = parseTop s & fromRight mempty + + case what of + [ListVal [SymbolVal "checkpoint", TextLike w, LitIntVal r]] -> do + atomically $ writeTVar cp_ (Just (w,r)) + + [ListVal [SymbolVal "status", TextLike "FLUSH"]] -> do + finished () + + _ -> none + + liftIO do + hClearLine origHandle + hSetCursorColumn origHandle 0 + IO.hPutStr origHandle s + hSetCursorColumn origHandle 0 ContT $ bracket none $ const do + + cp <- readTVarIO cp_ + + let cpHash = fst <$> cp + let ts = maybe 0 (fromIntegral . snd) cp & formatTs + hClearLine origHandle hSetCursorColumn origHandle 0 - lift $ void $ installHandler sigPIPE Ignore Nothing + when (isJust cp) do + hPutDoc origHandle $ "fetched from checkpoint" <+> pretty ts <+> pretty cpHash <> line + + hPutDoc origHandle $ "use" <+> yellow "git fetch" <+> "to get latest versions" <> line + + hFlush origHandle + env <- nullGit3Env ops <- DeferredOps <$> newTQueueIO @@ -198,7 +235,7 @@ main = flip runContT pure do waitRepo Nothing =<< getGitRepoKeyThrow - notice "WAIT-FOR-REPO-DONE" + notice "wait-for-repo-done" void $ run dict conf @@ -207,6 +244,10 @@ main = flip runContT pure do flip fix Plain $ \next -> \case Plain -> do + closed <- hIsEOF stdin + + when closed $ next End + inp <- try @_ @IOError getLine <&> fromRight mempty when (null (words inp)) $ next End @@ -222,10 +263,9 @@ main = flip runContT pure do End -> do sendLine "" - liftIO exitSuccess + notice "status FLUSH" _ -> do sendLine "" next Plain - -- liftIO exitSuccess diff --git a/hbs2-git3/lib/HBS2/Git3/Import.hs b/hbs2-git3/lib/HBS2/Git3/Import.hs index d0bb0575..38a47cd3 100644 --- a/hbs2-git3/lib/HBS2/Git3/Import.hs +++ b/hbs2-git3/lib/HBS2/Git3/Import.hs @@ -191,7 +191,7 @@ importGitRefLog = do ProbeSnapshotElement "Download.wip" n -> Just n _ -> Nothing - notice $ "wait some time..." <+> parens (pretty down) + notice $ "wait-for-download" <+> parens (pretty down) case d of Just n | down /= n || down == 0 -> again next @@ -227,7 +227,7 @@ importGitRefLog = do hxs <- txList ( pure . not . flip HS.member excl ) rv cp' <- flip fix (fmap snd hxs, Nothing) $ \next -> \case - ([], r) -> pure (gitTxTree <$> r) + ([], r) -> pure r (TxSegment{}:xs, l) -> next (xs, l) (cp@(TxCheckpoint n tree) : xs, l) -> do @@ -241,14 +241,10 @@ importGitRefLog = do next (xs, l) case cp' of - Nothing -> do - notice "no checkpoints found" - pure Nothing + Just TxCheckpoint{..} -> do - Just cp -> do - - notice $ "found checkpoint" <+> pretty cp - txs <- txList ( pure . not . flip HS.member excl ) (Just cp) + notice $ "checkpoint" <+> pretty gitTxTree <+> pretty gitTxRank + txs <- txList ( pure . not . flip HS.member excl ) (Just gitTxTree) forConcurrently_ txs $ \case (_, TxCheckpoint{}) -> none @@ -265,7 +261,11 @@ importGitRefLog = do atomically $ modifyTVar already_ (HS.insert tree) notice $ "imported" <+> pretty h - pure (Just cp) + pure (Just gitTxTree) + + _ -> do + notice "no checkpoints found" + pure Nothing case r of Right cp -> again $ ImportDone cp diff --git a/hbs2-git3/lib/HBS2/Git3/Logger.hs b/hbs2-git3/lib/HBS2/Git3/Logger.hs index c4ecd980..84f04702 100644 --- a/hbs2-git3/lib/HBS2/Git3/Logger.hs +++ b/hbs2-git3/lib/HBS2/Git3/Logger.hs @@ -16,6 +16,7 @@ setupLogger = do setLogging @ERROR $ toStderr . logPrefix "[error] " setLogging @WARN $ toStderr . logPrefix "[warn] " setLogging @NOTICE $ toStderr . logPrefix "" + setLogging @INFO $ toStderr . logPrefix "" pure () flushLoggers :: MonadIO m => m () @@ -28,5 +29,6 @@ silence = do setLoggingOff @ERROR setLoggingOff @WARN setLoggingOff @NOTICE + setLoggingOff @INFO