From db9cfc0b2fa244bb0802443e22a6572e37cfd946 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Tue, 30 Jul 2024 08:19:42 +0300 Subject: [PATCH] wip --- hbs2-cli/app/Main.hs | 2 + hbs2-cli/hbs2-cli.cabal | 1 + hbs2-cli/lib/HBS2/CLI/Run/Internal.hs | 27 ++++++++++++- hbs2-cli/lib/HBS2/CLI/Run/Internal/KeyMan.hs | 7 ---- hbs2-cli/lib/HBS2/CLI/Run/RefChan.hs | 39 +++++++++++++++++++ .../lib/HBS2/Peer/Proto/RefChan/Types.hs | 1 - 6 files changed, 67 insertions(+), 10 deletions(-) create mode 100644 hbs2-cli/lib/HBS2/CLI/Run/RefChan.hs diff --git a/hbs2-cli/app/Main.hs b/hbs2-cli/app/Main.hs index ba994d6d..d4dc6061 100644 --- a/hbs2-cli/app/Main.hs +++ b/hbs2-cli/app/Main.hs @@ -11,6 +11,7 @@ import HBS2.CLI.Run.Sigil import HBS2.CLI.Run.MetaData import HBS2.CLI.Run.Peer import HBS2.CLI.Run.RefLog +import HBS2.CLI.Run.RefChan import HBS2.CLI.Run.LWWRef import HBS2.Peer.RPC.Client.Unix @@ -79,6 +80,7 @@ main = do metaDataEntries peerEntries reflogEntries + refchanEntries lwwRefEntries entry $ bindMatch "help" $ nil_ $ \syn -> do diff --git a/hbs2-cli/hbs2-cli.cabal b/hbs2-cli/hbs2-cli.cabal index e7b771f2..50feb3a5 100644 --- a/hbs2-cli/hbs2-cli.cabal +++ b/hbs2-cli/hbs2-cli.cabal @@ -112,6 +112,7 @@ library HBS2.CLI.Run.MetaData HBS2.CLI.Run.Peer HBS2.CLI.Run.RefLog + HBS2.CLI.Run.RefChan HBS2.CLI.Run.LWWRef HBS2.CLI.Run.Sigil diff --git a/hbs2-cli/lib/HBS2/CLI/Run/Internal.hs b/hbs2-cli/lib/HBS2/CLI/Run/Internal.hs index 6c8c012e..f4199a36 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/Internal.hs +++ b/hbs2-cli/lib/HBS2/CLI/Run/Internal.hs @@ -112,8 +112,12 @@ instance IsContext c => MkStr c Text where mkBool :: forall c . IsContext c => Bool -> Syntax c mkBool v = Literal noContext (LitBool v) -mkForm :: forall c . IsContext c => String -> [Syntax c] -> Syntax c -mkForm s sy = List noContext ( mkSym s : sy ) + +class IsContext c => MkForm c a where + mkForm :: a-> [Syntax c] -> Syntax c + +instance (IsContext c, MkSym c s) => MkForm c s where + mkForm s sy = List noContext ( mkSym @c s : sy ) mkList :: forall c. IsContext c => [Syntax c] -> Syntax c mkList = List noContext @@ -455,6 +459,15 @@ nil = List noContext [] nil_ :: (IsContext c, MonadIO m) => (a -> RunM c m b) -> a -> RunM c m (Syntax c) nil_ m w = m w >> pure (List noContext []) +fixContext :: (IsContext c1, IsContext c2) => Syntax c1 -> Syntax c2 +fixContext = go + where + go = \case + List _ xs -> List noContext (fmap go xs) + Symbol _ w -> Symbol noContext w + Literal _ l -> Literal noContext l + + internalEntries :: forall c m . (IsContext c, Exception (BadFormException c), MonadUnliftIO m) => MakeDictM c m () internalEntries = do @@ -584,6 +597,16 @@ internalEntries = do entry $ bindValue "space" $ mkStr " " + entry $ bindMatch "parse-top" $ \case + + [SymbolVal w, LitStrVal s] -> do + pure $ parseTop s & either (const nil) (mkList . fmap (mkForm w . List.singleton) . fmap fixContext) + + [LitStrVal s] -> do + pure $ parseTop s & either (const nil) (mkList . fmap fixContext) + + _ -> throwIO (BadFormException @c nil) + entry $ bindMatch "sym" $ \case [StringLike s] -> pure (mkSym s) e -> pure (mkSym $ show $ pretty e) diff --git a/hbs2-cli/lib/HBS2/CLI/Run/Internal/KeyMan.hs b/hbs2-cli/lib/HBS2/CLI/Run/Internal/KeyMan.hs index 3fd3045b..79395988 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/Internal/KeyMan.hs +++ b/hbs2-cli/lib/HBS2/CLI/Run/Internal/KeyMan.hs @@ -19,13 +19,6 @@ import Data.Text.IO qualified as TIO import System.Process.Typed import Text.InterpolatedString.Perl6 (qc) -fixContext :: (IsContext c1, IsContext c2) => Syntax c1 -> Syntax c2 -fixContext = go - where - go = \case - List _ xs -> List noContext (fmap go xs) - Symbol _ w -> Symbol noContext w - Literal _ l -> Literal noContext l keymanGetConfig :: (IsContext c, MonadUnliftIO m) => m [Syntax c] diff --git a/hbs2-cli/lib/HBS2/CLI/Run/RefChan.hs b/hbs2-cli/lib/HBS2/CLI/Run/RefChan.hs new file mode 100644 index 00000000..887748cc --- /dev/null +++ b/hbs2-cli/lib/HBS2/CLI/Run/RefChan.hs @@ -0,0 +1,39 @@ +module HBS2.CLI.Run.RefChan where + +import HBS2.CLI.Prelude +import HBS2.CLI.Run.Internal +import HBS2.CLI.Run.Internal.KeyMan + +import HBS2.Data.Types.Refs +import HBS2.Storage +import HBS2.Peer.CLI.Detect +import HBS2.Peer.RPC.Client.Unix +import HBS2.Peer.RPC.API.Peer +import HBS2.Peer.RPC.API.RefChan + +import HBS2.Peer.Proto.LWWRef +import HBS2.Base58 +import HBS2.Net.Auth.Credentials +import HBS2.Net.Auth.Schema() +import HBS2.Data.Types.SignedBox + +import HBS2.KeyMan.Keys.Direct +import HBS2.KeyMan.App.Types + +import Control.Monad.Trans.Cont + + +refchanEntries :: forall c m . (c ~ C, IsContext c, MonadUnliftIO m) => MakeDictM c m () +refchanEntries = do + entry $ bindMatch "hbs2:refchan:list" $ \case + [] -> do + flip runContT pure do + so <- detectRPC `orDie` "rpc not found" + api <- ContT $ withRPC2 @PeerAPI @UNIX so + r <- callService @RpcPollList2 api (Just "refchan", Nothing) + >>= orThrowUser "can't get refchan list" + pure $ mkList $ fmap (mkStr . show . pretty . AsBase58 . view _1) r + + _ -> throwIO (BadFormException @C nil) + + diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/RefChan/Types.hs b/hbs2-peer/lib/HBS2/Peer/Proto/RefChan/Types.hs index a57ce736..d994f5ba 100644 --- a/hbs2-peer/lib/HBS2/Peer/Proto/RefChan/Types.hs +++ b/hbs2-peer/lib/HBS2/Peer/Proto/RefChan/Types.hs @@ -309,7 +309,6 @@ instance ForRefChans e => FromStringMaybe (RefChanHeadBlock e) where | (ListVal [SymbolVal "notifier", LitStrVal s] ) <- parsed ] - disclosed = catMaybes [ fromStringMay @HashRef (Text.unpack s) | (ListVal [SymbolVal "disclosed", LitStrVal s] ) <- parsed ]