From 7c042ab33222ce4412577a2d1a9af629626b3311 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Thu, 1 Aug 2024 12:47:52 +0300 Subject: [PATCH] wip --- hbs2-cli/lib/HBS2/CLI/Prelude.hs | 2 + hbs2-cli/lib/HBS2/CLI/Run/Internal.hs | 43 +++++++- hbs2-cli/lib/HBS2/CLI/Run/LWWRef.hs | 141 +++++++++++++++----------- 3 files changed, 123 insertions(+), 63 deletions(-) diff --git a/hbs2-cli/lib/HBS2/CLI/Prelude.hs b/hbs2-cli/lib/HBS2/CLI/Prelude.hs index 0f1fd694..52ea1a4d 100644 --- a/hbs2-cli/lib/HBS2/CLI/Prelude.hs +++ b/hbs2-cli/lib/HBS2/CLI/Prelude.hs @@ -7,6 +7,7 @@ module HBS2.CLI.Prelude , module Control.Monad.Reader , module HBS2.System.Logger.Simple.ANSI , module HBS2.Misc.PrettyStuff + , qc,qq,q , Generic ) where @@ -21,4 +22,5 @@ import Data.Config.Suckless import Control.Monad.Reader import UnliftIO +import Text.InterpolatedString.Perl6 (qc,q,qq) diff --git a/hbs2-cli/lib/HBS2/CLI/Run/Internal.hs b/hbs2-cli/lib/HBS2/CLI/Run/Internal.hs index bdc32cb8..c614ec1a 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/Internal.hs +++ b/hbs2-cli/lib/HBS2/CLI/Run/Internal.hs @@ -103,6 +103,9 @@ instance Pretty ManDesc where pretty = \case ManDescRaw t -> pretty t +instance IsString ManDesc where + fromString s = ManDescRaw (Text.pack s) + instance Pretty (Man a) where pretty e = "NAME" <> line @@ -122,8 +125,7 @@ instance Pretty (Man a) where Just (ManReturns t s) -> line <> "RETURN VALUE" <> line <> indent 8 ( - pretty t <> line - <> pretty s) <> line + pretty t <> hsep ["","-",""] <> pretty s) <> line fmtDescription = line <> "DESCRIPTION" <> line @@ -155,6 +157,9 @@ instance Pretty (Man a) where indent 8 do parens (pretty (manName e) <+> hsep [ pretty n | ManApplyArg t n <- xs ] ) + <> line + <> line + <> vcat [ pretty n <+> ":" <+> pretty t | ManApplyArg t n <- xs ] pattern StringLike :: forall {c} . String -> Syntax c pattern StringLike e <- (stringLike -> Just e) @@ -398,6 +403,11 @@ makeDict w = execWriter ( fromMakeDict w ) entry :: Dict c m -> MakeDictM c m () entry = tell +desc :: Doc ann -> MakeDictM c m () -> MakeDictM c m () +desc txt = censor (HM.map setDesc) + where + w0 = mempty { manDesc = Just (ManDescRaw $ Text.pack $ show txt) } + setDesc (Bind w x) = Bind (Just (maybe w0 (<> w0) w)) x brief :: ManBrief -> MakeDictM c m () -> MakeDictM c m () brief txt = censor (HM.map setBrief) @@ -680,9 +690,32 @@ internalEntries = do pure $ mkForm "dict" [ mkList [a, b] ] _ -> throwIO (BadFormException @C nil) - entry $ bindMatch "kw" $ \syn -> do - let wat = [ mkList @c [mkSym i, e] | (i,e) <- optlist syn ] - pure $ mkForm "dict" wat + brief "creates a dict from a linear list of string-like items" + $ args [arg "list-of-terms" "..."] + $ desc ( "macro; syntax sugar" <> line + <> "useful for creating function args" <> line + <> "leftover records are skipped" + ) + $ returns "dict" "" + $ examples [qc| +[kw a 1 b 2 c 3] +(dict (a 1) (b 2) (c 3)) + +[kw a] +(dict (a ())) + +[kw a b] +(dict (a b)) + +[kw 1 2 3] +(dict) + +[kw a b c] +(dict (a b) (c ())) + |] + $ entry $ bindMatch "kw" $ \syn -> do + let wat = [ mkList @c [mkSym i, e] | (i,e) <- optlist syn ] + pure $ mkForm "dict" wat entry $ bindMatch "iterate" $ nil_ $ \syn -> do case syn of diff --git a/hbs2-cli/lib/HBS2/CLI/Run/LWWRef.hs b/hbs2-cli/lib/HBS2/CLI/Run/LWWRef.hs index 4240ba29..b68cceb1 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/LWWRef.hs +++ b/hbs2-cli/lib/HBS2/CLI/Run/LWWRef.hs @@ -26,84 +26,109 @@ import Control.Monad.Trans.Cont lwwRefEntries :: forall c m . (c ~ C, IsContext c, MonadUnliftIO m) => MakeDictM c m () lwwRefEntries = do - entry $ bindMatch "hbs2:lwwref:create" $ \case - [] -> do - reflog <- keymanNewCredentials (Just "lwwref") 0 + brief "creates a new lwwref" + $ desc "Creates a new keyring; adds it to keyman and subsribes hbs2-peer to listen this lwwref" + $ returns "string" "lwwref public key" + $ entry $ bindMatch "hbs2:lwwref:create" $ \case + [] -> do + reflog <- keymanNewCredentials (Just "lwwref") 0 - flip runContT pure do - so <- detectRPC `orDie` "rpc not found" - api <- ContT $ withRPC2 @PeerAPI @UNIX so - void $ callService @RpcPollAdd api (reflog, "lwwref", 31) - pure $ mkStr (show $ pretty (AsBase58 reflog)) + flip runContT pure do + so <- detectRPC `orDie` "rpc not found" + api <- ContT $ withRPC2 @PeerAPI @UNIX so + void $ callService @RpcPollAdd api (reflog, "lwwref", 31) + pure $ mkStr (show $ pretty (AsBase58 reflog)) - _ -> throwIO (BadFormException @C nil) + _ -> throwIO (BadFormException @C nil) - entry $ bindMatch "hbs2:lwwref:list" $ \case - [] -> do - flip runContT pure do - so <- detectRPC `orDie` "rpc not found" - api <- ContT $ withRPC2 @PeerAPI @UNIX so - r <- callService @RpcPollList2 api (Just "lwwref", Nothing) - >>= orThrowUser "can't get lwwref list" - pure $ mkList $ fmap (mkStr . show . pretty . AsBase58 . view _1) r + brief "lists all lwwref that hbs2-peer is subscribed to" + $ noArgs + $ returns "list of string" "lwwref list" + $ entry $ bindMatch "hbs2:lwwref:list" $ \case + [] -> do + flip runContT pure do + so <- detectRPC `orDie` "rpc not found" + api <- ContT $ withRPC2 @PeerAPI @UNIX so + r <- callService @RpcPollList2 api (Just "lwwref", Nothing) + >>= orThrowUser "can't get lwwref list" + pure $ mkList $ fmap (mkStr . show . pretty . AsBase58 . view _1) r - _ -> throwIO (BadFormException @C nil) + _ -> throwIO (BadFormException @C nil) - entry $ bindMatch "hbs2:lwwref:fetch" $ \case - [StringLike puk] -> do - flip runContT pure do - lww <- orThrowUser "bad lwwref key" (fromStringMay puk) - so <- detectRPC `orDie` "rpc not found" - api <- ContT $ withRPC2 @LWWRefAPI @UNIX so - void $ callService @RpcLWWRefFetch api lww - pure $ mkStr "okay" + brief "fetches lwwref value" + $ desc "makes peer to request lwwref from neighbors" + $ args [arg "string" "lwwref"] + $ returns "atom" "okay" + $ entry $ bindMatch "hbs2:lwwref:fetch" $ \case + [StringLike puk] -> do + flip runContT pure do + lww <- orThrowUser "bad lwwref key" (fromStringMay puk) + so <- detectRPC `orDie` "rpc not found" + api <- ContT $ withRPC2 @LWWRefAPI @UNIX so + void $ callService @RpcLWWRefFetch api lww + pure $ mkStr "okay" - _ -> throwIO (BadFormException @C nil) + _ -> throwIO (BadFormException @C nil) - entry $ bindMatch "hbs2:lwwref:get" $ \case - [StringLike puk] -> do + brief "get lwwref value" + $ args [arg "string" "lwwref"] + $ returns "string" "hashref" + $ examples [qc| - flip runContT pure do - ref <- orThrowUser "bad lwwref key" (fromStringMay puk) - so <- detectRPC `orDie` "rpc not found" - api <- ContT $ withRPC2 @LWWRefAPI @UNIX so - what <- callService @RpcLWWRefGet api ref - >>= orThrowUser "can't get lwwref value" - pure $ mkStr (show $ pretty what) +(hbs2:lwwref:get BTThPdHKF8XnEq4m6wzbKHKA6geLFK4ydYhBXAqBdHSP) +(lwwref + (seq 4) + (value "74vDGwBYebH3oM6xPXC7kqpgu6deqi7E549QpvHvvQKf") + ) + |] + $ entry $ bindMatch "hbs2:lwwref:get" $ \case + [StringLike puk] -> do - _ -> throwIO (BadFormException @C nil) + flip runContT pure do + ref <- orThrowUser "bad lwwref key" (fromStringMay puk) + so <- detectRPC `orDie` "rpc not found" + api <- ContT $ withRPC2 @LWWRefAPI @UNIX so + what <- callService @RpcLWWRefGet api ref + >>= orThrowUser "can't get lwwref value" + pure $ mkStr (show $ pretty what) + + _ -> throwIO (BadFormException @C nil) - entry $ bindMatch "hbs2:lwwref:update" $ \case - [StringLike puks, HashLike new] -> do + brief "updates lwwref" + $ desc "updates lwwref value and increments it's counter" + $ args [arg "string" "lwwref", arg "string" "hash"] + $ returns "nil" "" + $ entry $ bindMatch "hbs2:lwwref:update" $ \case + [StringLike puks, HashLike new] -> do - flip runContT pure do - puk <- orThrowUser "bad lwwref key" (fromStringMay puks) - so <- detectRPC `orDie` "rpc not found" - api <- ContT $ withRPC2 @LWWRefAPI @UNIX so + flip runContT pure do + puk <- orThrowUser "bad lwwref key" (fromStringMay puks) + so <- detectRPC `orDie` "rpc not found" + api <- ContT $ withRPC2 @LWWRefAPI @UNIX so - (sk,pk) <- liftIO $ runKeymanClient do - creds <- loadCredentials puk - >>= orThrowUser "can't load credentials" - pure ( view peerSignSk creds, view peerSignPk creds ) + (sk,pk) <- liftIO $ runKeymanClient do + creds <- loadCredentials puk + >>= orThrowUser "can't load credentials" + pure ( view peerSignSk creds, view peerSignPk creds ) - what <- callService @RpcLWWRefGet api puk - >>= orThrowUser "can't get lwwref value" + what <- callService @RpcLWWRefGet api puk + >>= orThrowUser "can't get lwwref value" - sno' <- case what of - Nothing -> pure 0 - Just lwwv -> pure (lwwSeq lwwv) + sno' <- case what of + Nothing -> pure 0 + Just lwwv -> pure (lwwSeq lwwv) - let sno = succ sno' + let sno = succ sno' - let box = makeSignedBox pk sk (LWWRef sno new Nothing) + let box = makeSignedBox pk sk (LWWRef sno new Nothing) - callService @RpcLWWRefUpdate api box - >>= orThrowUser "lww ref update error" + callService @RpcLWWRefUpdate api box + >>= orThrowUser "lww ref update error" - pure nil + pure nil - _ -> throwIO (BadFormException @C nil) + _ -> throwIO (BadFormException @C nil)