hbs2-peer refchan cat && hbs2-peer reflog cat

hbs2-core/hbs2-core.cabal

@@ -1,6 +1,6 @@
 cabal-version:      3.0
 name:               hbs2-core
-version:            0.24.1.1
+version:            0.24.1.2
 -- synopsis:
 -- description:
 license:            BSD-3-Clause

hbs2-core/lib/HBS2/Net/Proto/Service.hs

@@ -261,6 +261,26 @@ callService caller input = do
       _ -> pure (Left ErrorInvalidResponse)
 
 
+callRpcWaitMay :: forall method (api :: [Type]) m e proto t . ( MonadUnliftIO m
+                                                              , KnownNat (FromJust (FindMethodIndex 0 method api))
+                                                              , HasProtocol e (ServiceProto api e)
+                                                              , Serialise (Input method)
+                                                              , Serialise (Output method)
+                                                              , IsTimeout t
+                                                              , proto ~ ServiceProto api e
+                                                              )
+           => Timeout t
+           -> ServiceCaller api e
+           -> Input method
+           -> m (Maybe (Output method))
+
+callRpcWaitMay t caller args = do
+  race (pause t) (callService @method @api @e @m caller args)
+    >>= \case
+      Right (Right x) -> pure (Just x)
+      _               -> pure Nothing
+
+
 makeClient :: forall api e m  . ( MonadIO m
                                 , HasProtocol e (ServiceProto api e)
                                 , Pretty (Peer e)

hbs2-fixer/hbs2-fixer.cabal

@@ -1,6 +1,6 @@
 cabal-version:      3.0
 name:               hbs2-fixer
-version:            0.24.1.1
+version:            0.24.1.2
 -- synopsis:
 -- description:
 license:            BSD-3-Clause

hbs2-git/hbs2-git.cabal

@@ -1,6 +1,6 @@
 cabal-version:      3.0
 name:               hbs2-git
-version:            0.24.1.1
+version:            0.24.1.2
 -- synopsis:
 -- description:
 license:            BSD-3-Clause

hbs2-keyman/hbs2-keyman.cabal

@@ -1,6 +1,6 @@
 cabal-version:      3.0
 name:               hbs2-keyman
-version:            0.24.1.1
+version:            0.24.1.2
 -- synopsis:
 -- description:
 license:            BSD-3-Clause

hbs2-peer/app/CLI/RefChan.hs

@@ -5,6 +5,7 @@ import HBS2.Prelude.Plated
 import HBS2.Hash
 import HBS2.Net.Auth.Credentials
 import HBS2.Net.Auth.Credentials.Sigil
+import HBS2.Merkle
 import HBS2.Peer.Proto.RefChan
 import HBS2.Net.Proto.Types
 import HBS2.Data.Types.Refs
@@ -52,6 +53,7 @@ pRefChan = hsubparser (   command "head" (info pRefChanHead (progDesc "head comm
                        <> command "fetch"   (info pRefChanFetch   (progDesc "fetch and sync refchan value"))
                        <> command "get"     (info pRefChanGet     (progDesc "get refchan value"))
                        <> command "gk"      (info pRefChanGK      (progDesc "generate a group key"))
+                       <> command "cat"     (info pRefChanCat    (progDesc "dump refchan content"))
                       )
 
 
@@ -65,11 +67,13 @@ pRefChanHead = hsubparser (   command "gen"  (info pRefChanHeadGen (progDesc "ge
 
 pRefChanHeadGen :: Parser (IO ())
 pRefChanHeadGen = do
-  kr <- strOption (long "keyring" <> short 'k' <> help "owner credentials")
   fn <- optional $ strArgument (metavar "head dsl file")
+  rchan <- argument pRefChanId (metavar "REFCHAN-KEY")
   pure $ do
-    sc <- BS.readFile kr
+
-    creds <- pure (parseCredentials @(Encryption L4Proto) (AsCredFile sc)) `orDie` "bad keyring file"
+    creds <- runKeymanClient $ loadCredentials rchan
+               >>= orThrowUser "can't load credentials"
+
     s <- maybe1 fn getContents readFile
     hd <- pure (fromStringMay @(RefChanHeadBlock L4Proto) s) `orDie` "can't generate head block"
     let qq = makeSignedBox @L4Proto @(RefChanHeadBlock L4Proto) (view peerSignPk creds) (view peerSignSk creds) hd
@@ -84,8 +88,6 @@ pRefChanHeadDump= do
     print $ pretty hdblk
 
 
-
-
 pRefChanHeadPost :: Parser (IO ())
 pRefChanHeadPost = do
   opts <- pRpcCommon
@@ -117,13 +119,14 @@ pRefChanHeadGet = do
 pRefChanPropose :: Parser (IO ())
 pRefChanPropose = do
   opts <- pRpcCommon
-  kra <- strOption (long "author" <> short 'a' <> help "author credentials")
+  kra <- option pRefChanId (long "author" <> short 'a' <> help "author key")
   fn  <- optional $ strOption (long "file" <> short 'f' <> help "file")
   dry <- optional (flag' True (long "dry" <> short 'n' <> help "only dump transaction")) <&> fromMaybe False
   puk <- argument pRefChanId (metavar "REFCHAH-KEY")
+
   pure $ withMyRPC @RefChanAPI opts $ \caller -> do
-    sc <- BS.readFile kra
+    creds <- runKeymanClient $ loadCredentials kra
-    creds <- pure (parseCredentials @(Encryption L4Proto) (AsCredFile sc)) `orDie` "bad keyring file"
+               >>= orThrowUser "can't load credentials"
 
     lbs <- maybe1 fn LBS.getContents LBS.readFile
 
@@ -369,3 +372,46 @@ pRefChanGK = do
 
     liftIO $ print $ pretty (AsGroupKeyFile gk)
 
+
+pRefChanCat :: Parser (IO ())
+pRefChanCat = do
+  opts <- pRpcCommon
+  puk <- argument pRefChanId (metavar "REFCHAH-REF")
+  pure $ flip runContT pure do
+
+    client <- ContT $ withRPCMessaging opts
+
+    self <- runReaderT (ownPeer @UNIX) client
+    refChanAPI  <- makeServiceCaller @RefChanAPI self
+    storageAPI  <- makeServiceCaller @StorageAPI self
+
+    let endpoints = [ Endpoint @UNIX refChanAPI
+                    , Endpoint @UNIX storageAPI
+                    ]
+
+    void $ ContT $ bracket (async $ runReaderT (runServiceClientMulti endpoints) client) cancel
+
+    let sto = AnyStorage (StorageClient storageAPI)
+
+    rv' <- lift (callRpcWaitMay @RpcRefChanGet (TimeoutSec 1) refChanAPI puk)
+             >>= orThrowUser "rpc call error/timeout"
+
+    rv <- ContT $ maybe1 rv' none
+
+    walkMerkle (fromHashRef rv) (getBlock sto) $ \case
+      Left{} -> pure ()
+      Right (hrs :: [HashRef]) -> do
+        for_ hrs $ \h -> void $ runMaybeT do
+
+          s <- getBlock sto (fromHashRef h)
+                 >>= toMPlus
+                 <&> deserialiseOrFail @(RefChanUpdate L4Proto)
+                 >>= toMPlus
+
+          case s of
+            Accept{} -> pure ()
+            Propose _ box -> do
+              (_, ProposeTran _ pbox :: ProposeTran L4Proto) <- toMPlus $ unboxSignedBox0 box
+              (_, bs2) <- toMPlus $ unboxSignedBox0 pbox
+              liftIO $ BS.putStr bs2
+

hbs2-peer/hbs2-peer.cabal

@@ -1,6 +1,6 @@
 cabal-version:      3.0
 name:               hbs2-peer
-version:            0.24.1.1
+version:            0.24.1.2
 -- synopsis:
 -- description:
 license:            BSD-3-Clause

hbs2-share/hbs2-share.cabal

@@ -1,6 +1,6 @@
 cabal-version:      3.0
 name:               hbs2-share
-version:            0.24.1.1
+version:            0.24.1.2
 -- synopsis:
 -- description:
 license:            BSD-3-Clause

hbs2-storage-simple/hbs2-storage-simple.cabal

@@ -1,6 +1,6 @@
 cabal-version:      3.0
 name:               hbs2-storage-simple
-version:            0.24.1.1
+version:            0.24.1.2
 -- synopsis:
 -- description:
 license:            BSD-3-Clause

hbs2/hbs2.cabal

@@ -1,6 +1,6 @@
 cabal-version:      3.0
 name:               hbs2
-version:            0.24.1.1
+version:            0.24.1.2
 -- synopsis:
 -- description:
 license:            BSD-3-Clause