wip

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

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
 

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)

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]

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

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
                             ]