From ca033d2c1c34c71b501846681b88aeb537d2f7a9 Mon Sep 17 00:00:00 2001 From: voidlizard Date: Thu, 20 Feb 2025 07:57:47 +0300 Subject: [PATCH] some documentation and minor refactoring --- hbs2-git3/app/GitRemoteHelper.hs | 2 + hbs2-git3/lib/HBS2/Git3/Logger.hs | 17 +- hbs2-git3/lib/HBS2/Git3/Man.hs | 18 ++ hbs2-git3/lib/HBS2/Git3/Prelude.hs | 1 + hbs2-git3/lib/HBS2/Git3/Repo/Tools.hs | 12 +- hbs2-git3/lib/HBS2/Git3/Repo/Types.hs | 6 +- hbs2-git3/lib/HBS2/Git3/Run.hs | 269 +++++++++--------- hbs2-git3/lib/HBS2/Git3/State.hs | 21 +- .../lib/Data/Config/Suckless/Script.hs | 5 + 9 files changed, 203 insertions(+), 148 deletions(-) diff --git a/hbs2-git3/app/GitRemoteHelper.hs b/hbs2-git3/app/GitRemoteHelper.hs index 5acdcc0f..2b676fe6 100644 --- a/hbs2-git3/app/GitRemoteHelper.hs +++ b/hbs2-git3/app/GitRemoteHelper.hs @@ -230,6 +230,8 @@ main = flip runContT pure do setupLogger + setStatusOn + env <- nullGit3Env ops <- DeferredOps <$> newTQueueIO diff --git a/hbs2-git3/lib/HBS2/Git3/Logger.hs b/hbs2-git3/lib/HBS2/Git3/Logger.hs index 84f04702..246bddc1 100644 --- a/hbs2-git3/lib/HBS2/Git3/Logger.hs +++ b/hbs2-git3/lib/HBS2/Git3/Logger.hs @@ -1,10 +1,15 @@ +{-# Language AllowAmbiguousTypes #-} module HBS2.Git3.Logger ( setupLogger , flushLoggers , silence , debugPrefix + , status, setStatusOn, STATUS ) where -import HBS2.Git3.Prelude +import HBS2.Prelude +import HBS2.System.Logger.Simple.ANSI as Logger + +data STATUS -- debugPrefix :: LoggerEntry -> LoggerEntry -- debugPrefix :: LoggerEntry -> LoggerEntry @@ -31,4 +36,14 @@ silence = do setLoggingOff @NOTICE setLoggingOff @INFO +instance HasLogLevel STATUS where + type instance LogLevel STATUS = 10 + +status :: forall a m . (MonadIO m) => Doc a -> m () +status = Logger.writeLog @STATUS . show + +setStatusOn :: MonadIO m => m () +setStatusOn = do + setLogging @STATUS $ toStderr . logPrefix "" + diff --git a/hbs2-git3/lib/HBS2/Git3/Man.hs b/hbs2-git3/lib/HBS2/Git3/Man.hs index e60e2a0e..a3bc6aa2 100644 --- a/hbs2-git3/lib/HBS2/Git3/Man.hs +++ b/hbs2-git3/lib/HBS2/Git3/Man.hs @@ -51,3 +51,21 @@ hbs2-git3 repo:remotes |] +manGitListObjectsNew :: MakeDictM c m () -> MakeDictM c m () +manGitListObjectsNew = + brief "lists new git objects" + . args [ arg "hash|name" "remote" + , arg "(-r rev)?" "git revision" + ] + +manRepoRelayOnly :: MakeDictM c m () -> MakeDictM c m () +manRepoRelayOnly = brief "subscribe hbs2-peer to repository references (lwwref+reflog)" + . desc description + . args [ arg "public-key" "lwwref"] + + where + description = vcat [ + "useful when you want hbs2-peer to distribute and backup" + <> "the repository data without git fetching/cloning" + ] + diff --git a/hbs2-git3/lib/HBS2/Git3/Prelude.hs b/hbs2-git3/lib/HBS2/Git3/Prelude.hs index 293ba4e5..3e2c2215 100644 --- a/hbs2-git3/lib/HBS2/Git3/Prelude.hs +++ b/hbs2-git3/lib/HBS2/Git3/Prelude.hs @@ -39,6 +39,7 @@ import HBS2.Storage.Operations.Class as Exported import HBS2.System.Logger.Simple.ANSI as Exported import HBS2.Git3.Types as Exported +import HBS2.Git3.Logger as Exported -- import HBS2.Git3.State.Types as Exported import HBS2.System.Dir diff --git a/hbs2-git3/lib/HBS2/Git3/Repo/Tools.hs b/hbs2-git3/lib/HBS2/Git3/Repo/Tools.hs index 69d2b25d..9534543c 100644 --- a/hbs2-git3/lib/HBS2/Git3/Repo/Tools.hs +++ b/hbs2-git3/lib/HBS2/Git3/Repo/Tools.hs @@ -56,8 +56,16 @@ listRemotes = do pure urls -resolveRepoKeyThrow :: MonadIO m => [Syntax C] -> m GitRepoKey -resolveRepoKeyThrow = \case +resolveRepo :: forall c m . (IsContext c, HBS2GitPerks m) => [Syntax c] -> Git3 m () +resolveRepo syn = do + resolveRepoKeyThrow syn >>= setGitRepoKey + waitRepo Nothing =<< getGitRepoKeyThrow + +resolved :: forall c m . (IsContext c, HBS2GitPerks m) => [Syntax c] -> Git3 m () +resolved = resolveRepo + +resolveRepoKeyThrow :: forall c m . (IsContext c, MonadIO m) => [Syntax c] -> m GitRepoKey +resolveRepoKeyThrow s = case maybeToList (headMay s) of [ SignPubKeyLike url ] -> pure url [ RepoURL url ] -> pure url [ StringLike x ] -> do diff --git a/hbs2-git3/lib/HBS2/Git3/Repo/Types.hs b/hbs2-git3/lib/HBS2/Git3/Repo/Types.hs index 422101ca..5c14d7c4 100644 --- a/hbs2-git3/lib/HBS2/Git3/Repo/Types.hs +++ b/hbs2-git3/lib/HBS2/Git3/Repo/Types.hs @@ -7,16 +7,16 @@ import Data.Config.Suckless.Script import Data.HashSet qualified as HS import Data.Text qualified as Text -pattern RepoURL :: GitRemoteKey -> Syntax C +pattern RepoURL :: forall {c} . IsContext c => GitRemoteKey -> Syntax c pattern RepoURL x <- (isRepoURL [ "hbs2", "hbs23" ] -> Just x) -pattern RepoURL3 :: GitRemoteKey -> Syntax C +pattern RepoURL3 :: forall {c} . IsContext c => GitRemoteKey -> Syntax c pattern RepoURL3 x <- (isRepoURL [ "hbs23" ] -> Just x) remoteRepoURL :: GitRemoteKey -> Text remoteRepoURL k = Text.pack $ show $ "hbs23://" <> pretty (AsBase58 k) -isRepoURL :: [Text] -> Syntax C -> Maybe GitRemoteKey +isRepoURL :: forall c . IsContext c => [Text] -> Syntax c -> Maybe GitRemoteKey isRepoURL pref = \case TextLike xs -> case mkList @C (fmap mkStr (Text.splitOn "://" xs)) of ListVal [TextLike pref, SignPubKeyLike puk] | pref `HS.member` prefixes -> Just puk diff --git a/hbs2-git3/lib/HBS2/Git3/Run.hs b/hbs2-git3/lib/HBS2/Git3/Run.hs index 55a26abd..c9710249 100644 --- a/hbs2-git3/lib/HBS2/Git3/Run.hs +++ b/hbs2-git3/lib/HBS2/Git3/Run.hs @@ -96,31 +96,36 @@ compression ; prints compression level _ -> throwIO (BadFormException @C nil) - entry $ bindMatch "segment" $ nil_ $ \case - [ LitIntVal n ] -> lift do - setPackedSegmedSize (fromIntegral n) + brief "sets packed segment size in bytes" + $ entry $ bindMatch "segment" $ nil_ $ \case + [ LitIntVal n ] -> lift do + setPackedSegmedSize (fromIntegral n) - _ -> throwIO (BadFormException @C nil) + _ -> throwIO (BadFormException @C nil) - entry $ bindMatch "quiet" $ nil_ $ const $ lift do - silence + brief "silent mode" + $ entry $ bindMatch "quiet" $ nil_ $ const $ lift do + silence - entry $ bindMatch "index-block-size" $ nil_ \case + hidden $ + entry $ bindMatch "index-block-size" $ nil_ \case [ LitIntVal size ]-> lift do setIndexBlockSize (fromIntegral size) _ -> throwIO (BadFormException @C nil) - entry $ bindMatch "git:tree:ls" $ nil_ $ const do + brief "list current git objects" + $ entry $ bindMatch "git:tree:ls" $ nil_ $ const do r <- gitReadTree "HEAD" for_ r $ \GitTreeEntry{..} -> do - liftIO $ print $ pretty gitEntryHash + liftIO $ print $ fill 40 (pretty gitEntryHash) <+> pretty gitEntryType <+> pretty gitEntrySize <+> pretty gitEntryName - entry $ bindMatch "debug" $ nil_ $ const do - setLogging @DEBUG $ toStderr . logPrefix "[debug] " + brief "turn debug output on" + $ entry $ bindMatch "debug" $ nil_ $ const do + setLogging @DEBUG $ toStderr . logPrefix "[debug] " -- hidden do @@ -176,25 +181,26 @@ compression ; prints compression level liftIO $ print $ "object" <+> pretty h <+> pretty s - entry $ bindMatch "reflog:index:search" $ nil_ $ \syn -> lift $ connectedDo do + hidden $ + entry $ bindMatch "reflog:index:search" $ nil_ $ \syn -> lift $ connectedDo do - let (_, argz) = splitOpts [] syn + let (_, argz) = splitOpts [] syn - hash <- case argz of - [ x@StringLike{}, GitHashLike h ] -> do - resolveRepoKeyThrow [x] >>= setGitRepoKey - waitRepo Nothing =<< getGitRepoKeyThrow - pure h + hash <- case argz of + [ x@StringLike{}, GitHashLike h ] -> do + resolveRepoKeyThrow [x] >>= setGitRepoKey + waitRepo Nothing =<< getGitRepoKeyThrow + pure h - _ -> throwIO $ BadFormException @C nil + _ -> throwIO $ BadFormException @C nil - idx <- openIndex + idx <- openIndex - answ <- indexEntryLookup idx hash + answ <- indexEntryLookup idx hash - for_ answ $ \bs -> do - let a = coerce (BS.take 32 bs) :: HashRef - liftIO $ print $ pretty a + for_ answ $ \bs -> do + let a = coerce (BS.take 32 bs) :: HashRef + liftIO $ print $ pretty a entry $ bindMatch "test:segment:dump" $ nil_ $ \syn -> lift do sto <- getStorage @@ -218,24 +224,30 @@ compression ; prints compression level for_ trees $ \tree -> do writeAsGitPack dir tree - entry $ bindMatch "reflog:index:list:count" $ nil_ $ const $ lift $ connectedDo do - idx <- openIndex - num_ <- newIORef 0 - enumEntries idx $ \_ -> void $ atomicModifyIORef num_ (\x -> (succ x, x)) - readIORef num_ >>= liftIO . print . pretty + brief "prints indexed object count for repo" $ + entry $ bindMatch "repo:index:count" $ nil_ $ \syn -> lift $ connectedDo do - entry $ bindMatch "reflog:index:list" $ nil_ $ const $ lift $ connectedDo do - files <- listObjectIndexFiles - for_ files $ \(ifn,_) -> do - lbs <- liftIO $ LBS.readFile ifn + resolveRepo syn - void $ runConsumeLBS lbs $ readSections $ \s ss -> do + idx <- openIndex + num_ <- newIORef 0 + enumEntries idx $ \_ -> void $ atomicModifyIORef num_ (\x -> (succ x, x)) + readIORef num_ >>= liftIO . print . pretty - let (sha1, blake) = LBS.splitAt 20 ss - & over _1 (coerce @_ @GitHash . LBS.toStrict) - & over _2 (coerce @_ @HashRef . LBS.toStrict) + brief "lists indexed objects for repo" $ + entry $ bindMatch "repo:index:list" $ nil_ $ \syn -> lift $ connectedDo do + resolveRepo syn + files <- listObjectIndexFiles + for_ files $ \(ifn,_) -> do + lbs <- liftIO $ LBS.readFile ifn - liftIO $ hPrint stdout $ pretty sha1 <+> pretty blake + void $ runConsumeLBS lbs $ readSections $ \s ss -> do + + let (sha1, blake) = LBS.splitAt 20 ss + & over _1 (coerce @_ @GitHash . LBS.toStrict) + & over _2 (coerce @_ @HashRef . LBS.toStrict) + + liftIO $ hPrint stdout $ pretty sha1 <+> pretty blake entry $ bindMatch "reflog:index:check" $ nil_ $ \case [ StringLike fn ] -> lift do @@ -246,24 +258,26 @@ compression ; prints compression level _ -> throwIO (BadFormException @C nil) - entry $ bindMatch "reflog:index:compact" $ nil_ $ \_ -> lift $ connectedDo do + entry $ bindMatch "repo:index:compact" $ nil_ $ \syn -> lift $ connectedDo do + resolveRepo syn size <- getIndexBlockSize compactIndex size - entry $ bindMatch "reflog:index:path" $ nil_ $ const $ lift $ connectedDo do + entry $ bindMatch "repo:index:path" $ nil_ $ \syn -> lift $ connectedDo do + resolveRepo syn indexPath >>= liftIO . print . pretty -- let entriesListOf lbs = S.toList_ $ runConsumeLBS lbs $ readSections $ \s ss -> do - entry $ bindMatch "reflog:index:files" $ nil_ $ \syn -> lift $ connectedDo do + entry $ bindMatch "repo:index:files" $ nil_ $ \syn -> lift $ connectedDo do + resolveRepo syn files <- listObjectIndexFiles cur <- pwd for_ files $ \(f',s) -> do let f = makeRelative cur f' liftIO $ print $ fill 10 (pretty s) <+> pretty f - entry $ bindMatch "reflog:index:list:tx" $ nil_ $ \syn -> lift $ connectedDo do - resolveRepoKeyThrow syn >>= setGitRepoKey - waitRepo Nothing =<< getGitRepoKeyThrow + entry $ bindMatch "repo:index:list:tx" $ nil_ $ \syn -> lift $ connectedDo do + resolveRepo syn r <- newIORef ( mempty :: HashSet HashRef ) index <- openIndex enumEntries index $ \bs -> do @@ -275,9 +289,8 @@ compression ; prints compression level for_ z $ \h ->do liftIO $ print $ pretty h - entry $ bindMatch "reflog:index:build" $ nil_ $ \syn -> lift $ connectedDo do - resolveRepoKeyThrow syn >>= setGitRepoKey - waitRepo Nothing =<< getGitRepoKeyThrow + entry $ bindMatch "repo:index:build" $ nil_ $ \syn -> lift $ connectedDo do + resolveRepo syn updateReflogIndex entry $ bindMatch "test:reflog:index:lookup" $ nil_ \case @@ -289,7 +302,9 @@ compression ; prints compression level _ -> throwIO (BadFormException @C nil) entry $ bindMatch "git:commit:list:objects:new" $ nil_ $ \case - [ StringLike what ] -> lift $ connectedDo do + [ repo, StringLike what ] -> lift $ connectedDo do + + resolveRepo [repo] commit <- gitRevParseThrow what @@ -323,59 +338,63 @@ compression ; prints compression level _ -> throwIO (BadFormException @C nil) - entry $ bindMatch "git:list:objects:new" $ nil_ $ \syn -> lift $ connectedDo do - let (opts,argz) = splitOpts [] syn + manGitListObjectsNew $ + entry $ bindMatch "git:list:objects:new" $ nil_ $ \syn -> lift $ connectedDo do - let what = headDef "HEAD" [ x | StringLike x <- argz ] + resolveRepo syn - h0 <- gitRevParseThrow what + let (opts,argz) = splitOpts [("-r", 1)] (tail syn) - no_ <- newTVarIO 0 + let what = headDef "HEAD" [ x | MatchOption "-r" (StringLike x) <- opts ] - void $ flip runContT pure do + h0 <- gitRevParseThrow what - lift updateReflogIndex + no_ <- newTVarIO 0 - idx <- lift openIndex - let req h = lift $ indexEntryLookup idx h <&> isNothing + void $ flip runContT pure do - (t1,r) <- timeItT (lift $ readCommitChainHPSQ req Nothing h0 dontHandle) + lift updateReflogIndex - let s = HPSQ.size r - debug $ pretty s <+> "new commits read at" <+> pretty (realToFrac @_ @(Fixed E3) t1) + idx <- lift openIndex + let req h = lift $ indexEntryLookup idx h <&> isNothing - cap <- liftIO getNumCapabilities - gitCatBatchQ <- contWorkerPool cap do - che <- ContT withGitCat - pure $ gitReadObjectMaybe che + (t1,r) <- timeItT (lift $ readCommitChainHPSQ req Nothing h0 dontHandle) - uniq_ <- newTVarIO mempty - -- c1 <- newCacheFixedHPSQ 1000 - (t3, _) <- timeItT $ lift $ forConcurrently_ (HPSQ.toList r) $ \(commit,_,_) -> do + let s = HPSQ.size r + debug $ pretty s <+> "new commits read at" <+> pretty (realToFrac @_ @(Fixed E3) t1) - (_,self) <- gitCatBatchQ commit - >>= orThrow (GitReadError (show $ pretty commit)) + cap <- liftIO getNumCapabilities + gitCatBatchQ <- contWorkerPool cap do + che <- ContT withGitCat + pure $ gitReadObjectMaybe che - tree <- gitReadCommitTree self + uniq_ <- newTVarIO mempty + -- c1 <- newCacheFixedHPSQ 1000 + (t3, _) <- timeItT $ lift $ forConcurrently_ (HPSQ.toList r) $ \(commit,_,_) -> do - -- читаем только те объекты, которые не в индексе - gitReadTreeObjectsOnly commit - <&> ([commit,tree]<>) - >>= \hs -> atomically (for_ hs (modifyTVar uniq_ . HS.insert)) + (_,self) <- gitCatBatchQ commit + >>= orThrow (GitReadError (show $ pretty commit)) - debug $ "read new objects" <+> pretty (realToFrac @_ @(Fixed E2) t3) + tree <- gitReadCommitTree self - (t4,new) <- lift $ timeItT $ readTVarIO uniq_ >>= indexFilterNewObjects idx + -- читаем только те объекты, которые не в индексе + gitReadTreeObjectsOnly commit + <&> ([commit,tree]<>) + >>= \hs -> atomically (for_ hs (modifyTVar uniq_ . HS.insert)) - liftIO $ for_ new $ \n -> do - print $ pretty n - -- notice $ pretty (length new) <+> "new objects" <+> "at" <+> pretty (realToFrac @_ @(Fixed E2) t4) + debug $ "read new objects" <+> pretty (realToFrac @_ @(Fixed E2) t3) + + (t4,new) <- lift $ timeItT $ readTVarIO uniq_ >>= indexFilterNewObjects idx + + liftIO $ for_ new $ \n -> do + 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 + entry $ bindMatch "repo:tx:list:imported" $ nil_ $ \syn -> lift $ connectedDo do + resolveRepo syn + + txImported >>= liftIO . print . vcat . fmap pretty . HS.toList let (opts, argz) = splitOpts [ ("--checkpoints",0) , ("--segments",0) @@ -402,18 +421,17 @@ compression ; prints compression level forM_ decoded print - entry $ bindMatch "reflog:tx:list" $ nil_ $ \syn -> lift $ connectedDo do + entry $ bindMatch "repo:tx:list" $ nil_ $ \syn -> lift $ connectedDo do + + resolveRepo syn let (opts, argz) = splitOpts [ ("--checkpoints",0) - , ("--segments",0) - ] syn + , ("--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 @@ -428,65 +446,55 @@ compression ; prints compression level forM_ decoded print - entry $ bindMatch "reflog:refs" $ nil_ $ \syn -> lift $ connectedDo do + entry $ bindMatch "repo:refs" $ nil_ $ \syn -> lift $ connectedDo do - resolveRepoKeyThrow syn >>= setGitRepoKey - waitRepo Nothing =<< getGitRepoKeyThrow + resolveRepo syn rrefs <- importedRefs for_ rrefs $ \(r,h) -> do liftIO $ print $ fill 20 (pretty h) <+> pretty r - entry $ bindMatch "reflog:refs:raw" $ nil_ $ \syn -> lift $ connectedDo do - resolveRepoKeyThrow syn >>= setGitRepoKey - waitRepo Nothing =<< getGitRepoKeyThrow - + entry $ bindMatch "repo:refs:raw" $ nil_ $ \syn -> lift $ connectedDo do + resolveRepo syn refsFiles >>= readRefsRaw >>= liftIO . mapM_ (print . pretty) entry $ bindMatch "repo:wait" $ nil_ $ \syn -> lift $ connectedDo do - resolveRepoKeyThrow syn >>= setGitRepoKey - waitRepo Nothing =<< getGitRepoKeyThrow - + resolveRepo syn getRepoManifest >>= liftIO . print . pretty . mkForm "manifest" . coerce manRemotes $ entry $ bindAlias "remotes" "repo:remotes" - hidden $ - manRemotes $ - entry $ bindMatch "repo:remotes" $ nil_ $ const $ lift do - remotes <- listRemotes - liftIO $ for_ remotes $ \(r,k) -> do - print $ fill 44 (pretty (AsBase58 k)) <+> pretty r + manRemotes $ + entry $ bindMatch "repo:remotes" $ nil_ $ const $ lift do + remotes <- listRemotes + liftIO $ for_ remotes $ \(r,k) -> do + print $ fill 44 (pretty (AsBase58 k)) <+> pretty r - entry $ bindMatch "reflog:imported" $ nil_ $ \syn -> lift $ connectedDo do - resolveRepoKeyThrow syn >>= setGitRepoKey - waitRepo Nothing =<< getGitRepoKeyThrow + entry $ bindMatch "repo:imported" $ nil_ $ \syn -> lift $ connectedDo do + resolveRepo syn p <- importedCheckpoint liftIO $ print $ pretty p - entry $ bindMatch "reflog:import" $ nil_ $ \syn -> lift $ connectedDo do - resolveRepoKeyThrow syn >>= setGitRepoKey - waitRepo Nothing =<< getGitRepoKeyThrow - importGitRefLog + hidden do + entry $ bindMatch "repo:import" $ nil_ $ \syn -> lift $ connectedDo do + resolveRepo syn + importGitRefLog brief "shows repo manifest" $ entry $ bindMatch "repo:manifest" $ nil_ $ \syn -> lift $ connectedDo do - resolveRepoKeyThrow syn >>= setGitRepoKey + resolveRepo syn manifest <- Repo.getRepoManifest liftIO $ print $ pretty $ mkForm "manifest" (coerce manifest) brief "shows repo reflog" $ - entry $ bindMatch "repo:reflog" $ nil_ $ const $ lift $ connectedDo do + entry $ bindMatch "repo:reflog" $ nil_ $ \syn -> lift $ connectedDo do + resolveRepo syn repo <- Repo.getRepoManifest - reflog <- getRefLog repo & orThrow GitRepoManifestMalformed - liftIO $ print $ pretty (AsBase58 reflog) entry $ bindMatch "repo:credentials" $ nil_ $ \syn -> lift $ connectedDo $ do - resolveRepoKeyThrow syn >>= setGitRepoKey - waitRepo (Just 10) =<< getGitRepoKeyThrow - + resolveRepo syn (p,_) <- getRepoRefLogCredentials liftIO $ print $ pretty $ mkForm @C "matched" [mkSym (show $ pretty ( AsBase58 p) )] @@ -525,25 +533,21 @@ compression ; prints compression level -- FIXME: maybe-add-default-remote entry $ bindMatch "repo:head" $ nil_ $ \syn -> lift $ connectedDo $ do - resolveRepoKeyThrow syn >>= setGitRepoKey - waitRepo Nothing =<< getGitRepoKeyThrow + resolveRepo syn lww <- getRepoRefMaybe liftIO $ print $ pretty lww entry $ bindMatch "repo:gk:journal:import" $ nil_ $ \syn -> lift $ connectedDo $ do - resolveRepoKeyThrow syn >>= setGitRepoKey - waitRepo Nothing =<< getGitRepoKeyThrow + resolveRepo syn importGroupKeys entry $ bindMatch "repo:gk:journal:imported" $ nil_ $ \syn -> lift $ connectedDo $ do - resolveRepoKeyThrow syn >>= setGitRepoKey - waitRepo Nothing =<< getGitRepoKeyThrow + resolveRepo syn readGroupKeyFile <&> maybe nil (mkSym @C . show . pretty) >>= liftIO . print . pretty entry $ bindMatch "repo:gk:journal" $ nil_ $ \syn -> lift $ connectedDo $ do - resolveRepoKeyThrow syn >>= setGitRepoKey - waitRepo Nothing =<< getGitRepoKeyThrow + resolveRepo syn ref <- getGitRepoKeyThrow @@ -573,12 +577,13 @@ compression ; prints compression level manInit $ entry $ bindAlias "init" "repo:init" - entry $ bindMatch "repo:relay-only" $ nil_ $ \case - [ SignPubKeyLike repo ] -> lift $ connectedDo do - setGitRepoKey repo - waitRepo (Just 10) =<< getGitRepoKeyThrow + manRepoRelayOnly $ + entry $ bindMatch "repo:relay-only" $ nil_ $ \case + [ SignPubKeyLike repo ] -> lift $ connectedDo do + setGitRepoKey repo + waitRepo (Just 10) =<< getGitRepoKeyThrow - _ -> throwIO (BadFormException @C nil) + _ -> throwIO (BadFormException @C nil) exportEntries "reflog:" diff --git a/hbs2-git3/lib/HBS2/Git3/State.hs b/hbs2-git3/lib/HBS2/Git3/State.hs index 32f22169..e4d2b778 100644 --- a/hbs2-git3/lib/HBS2/Git3/State.hs +++ b/hbs2-git3/lib/HBS2/Git3/State.hs @@ -46,6 +46,7 @@ import Codec.Compression.Zstd (maxCLevel) newtype RepoManifest = RepoManifest [Syntax C] + -- FIXME: cache getGK :: forall m . HBS2GitPerks m => Git3 m (Maybe (HashRef, GroupKey 'Symm 'HBS2Basic)) getGK = do @@ -64,7 +65,7 @@ getRefLog mf = lastMay [ x updateRepoKey :: forall m . HBS2GitPerks m => GitRepoKey -> Git3 m () updateRepoKey key = do - notice $ "updateRepoKey" <+> pretty (AsBase58 key) + status $ "updateRepoKey" <+> pretty (AsBase58 key) setGitRepoKey key @@ -72,7 +73,7 @@ updateRepoKey key = do ask >>= \case Git3Connected{..} -> do - notice $ yellow "UPDATED REFLOG" <+> pretty (fmap AsBase58 reflog) + debug $ yellow "UPDATED REFLOG" <+> pretty (fmap AsBase58 reflog) atomically $ writeTVar gitRefLog reflog _ -> none @@ -241,7 +242,7 @@ waitRepo :: forall m . HBS2GitPerks m -> Git3 m () waitRepo timeout repoKey = do - notice $ yellow "waitRepo" <+> pretty (AsBase58 repoKey) + status $ yellow "waitRepo" <+> pretty (AsBase58 repoKey) ask >>= \case Git3Disconnected{} -> throwIO Git3PeerNotConnected @@ -260,7 +261,7 @@ waitRepo timeout repoKey = do callCC \forPeer -> do - notice "wait for peer" + status "wait for peer" lift (callRpcWaitMay @RpcPollAdd (TimeoutSec 2) peerAPI (repoKey, "lwwref", 31)) >>= maybe (wait 1 forPeer ()) (const none) @@ -270,7 +271,7 @@ waitRepo timeout repoKey = do pause @'Seconds 10 lww <- flip fix 2 \next i -> do - notice $ "wait for" <+> pretty (AsBase58 repoKey) + status $ "wait for" <+> pretty (AsBase58 repoKey) lift (callRpcWaitMay @RpcLWWRefGet (TimeoutSec 1) lwwAPI (LWWRefKey repoKey)) >>= \case Just (Just x) -> pure x @@ -278,10 +279,10 @@ waitRepo timeout repoKey = do setGitRepoKey repoKey - notice $ "lwwref value" <+> pretty (lwwValue lww) + status $ "lwwref value" <+> pretty (lwwValue lww) mf <- flip fix 3 $ \next i -> do - notice $ "wait for manifest" <+> pretty i + status $ "wait for manifest" <+> pretty i lift (try @_ @SomeException getRepoManifest) >>= \case Left{} -> wait i next (i*1.10) Right x -> pure x @@ -305,7 +306,7 @@ waitRepo timeout repoKey = do void $ lift $ race waiter do rv <- flip fix 1 \next i -> do - notice $ "wait for reflog" <+> pretty i <+> pretty (AsBase58 reflog) + status $ "wait for reflog" <+> pretty i <+> pretty (AsBase58 reflog) lift (callRpcWaitMay @RpcRefLogGet (TimeoutSec 2) reflogAPI reflog) >>= \case Just (Just x) -> pure x @@ -316,7 +317,7 @@ waitRepo timeout repoKey = do cancel pFetch - notice $ "reflog" <+> pretty (AsBase58 reflog) <+> pretty rv + status $ "reflog" <+> pretty (AsBase58 reflog) <+> pretty rv flip fix 5 $ \next w -> do @@ -325,7 +326,7 @@ waitRepo timeout repoKey = do if L.null missed then do updateRepoKey repoKey else do - notice $ "wait reflog to sync in consistent state" <+> pretty w + status $ "wait reflog to sync in consistent state" <+> pretty w pause @'Seconds w next (w*1.01) diff --git a/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Script.hs b/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Script.hs index cf507d03..36ef918d 100644 --- a/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Script.hs +++ b/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Script.hs @@ -50,6 +50,11 @@ helpEntry what = do pattern HelpEntryBound :: forall {c}. Id -> [Syntax c] pattern HelpEntryBound what <- [ListVal (SymbolVal "builtin:lambda" : SymbolVal what : _ )] +pattern MatchOption:: forall {c} . Id -> Syntax c -> Syntax c +pattern MatchOption n e <- ListVal [SymbolVal n, e] + +pattern MatchFlag :: forall {c} . Id -> Syntax c +pattern MatchFlag n <- ListVal [SymbolVal n] splitOpts :: [(Id,Int)] -> [Syntax C]