basic reflog and refchan dump commands

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
@@ -46,12 +47,13 @@ import UnliftIO
 
 
 pRefChan :: Parser (IO ())
-pRefChan = hsubparser (   command "head" (info pRefChanHead (progDesc "head commands" ))
+pRefChan = hsubparser (   command "head" (info pRefChanHead       (progDesc "head commands" ))
                        <> command "propose" (info pRefChanPropose (progDesc "post propose transaction"))
-                       <> command "notify"  (info pRefChanNotify (progDesc "post notify message"))
+                       <> command "notify"  (info pRefChanNotify  (progDesc "post notify message"))
-                       <> command "fetch"   (info pRefChanFetch (progDesc "fetch and sync refchan value"))
+                       <> command "fetch"   (info pRefChanFetch   (progDesc "fetch and sync refchan value"))
-                       <> command "get"     (info pRefChanGet (progDesc "get refchan value"))
+                       <> command "get"     (info pRefChanGet     (progDesc "get refchan value"))
-                       <> command "gk"      (info pRefChanGK  (progDesc "generate a group key"))
+                       <> command "gk"      (info pRefChanGK      (progDesc "generate a group key"))
+                       <> command "dump"    (info pRefChanDump    (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)
 
+
+pRefChanDump :: Parser (IO ())
+pRefChanDump = 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/app/PeerMain.hs

@@ -9,6 +9,7 @@ import HBS2.Prelude.Plated
 
 import HBS2.Actors.Peer
 import HBS2.Base58
+import HBS2.Merkle
 import HBS2.Defaults
 import HBS2.Events
 import HBS2.Hash
@@ -417,6 +418,7 @@ runCLI = do
                          <> command "send-raw" (info pRefLogSendRaw (progDesc "send reflog raw transaction" ))
                          <> command "fetch" (info pRefLogFetch (progDesc "fetch reflog from all" ))
                          <> command "get"   (info pRefLogGet (progDesc "get own reflog from all" ))
+                         <> command "cat"   (info pRefLogCat (progDesc "dump decoded reflog transcations"))
                          )
 
     pRefLogSend = do
@@ -458,6 +460,46 @@ runCLI = do
           Right Nothing -> exitFailure
           Right (Just h) -> print (pretty h) >> exitSuccess
 
+    pRefLogCat = do
+      rpc <- pRpcCommon
+      ref <- strArgument ( metavar "REFLOG-KEY" )
+
+      pure $ flip runContT pure do
+
+        client <- ContT $ withRPCMessaging rpc
+
+        self         <- runReaderT (ownPeer @UNIX) client
+        refLogAPI    <- makeServiceCaller @RefLogAPI self
+        peerAPI      <- makeServiceCaller @PeerAPI self
+        storageAPI   <- makeServiceCaller @StorageAPI self
+        let sto = AnyStorage (StorageClient storageAPI)
+
+        let endpoints = [ Endpoint @UNIX peerAPI
+                        , Endpoint @UNIX refLogAPI
+                        , Endpoint @UNIX storageAPI
+                        ]
+
+        void $ ContT $ bracket (async $ runReaderT (runServiceClientMulti endpoints) client) cancel
+
+
+        href <- pure (fromStringMay ref) `orDie` "invalid REFLOG-KEY"
+
+        rv' <- lift $ callRpcWaitMay @RpcRefLogGet (TimeoutSec 1) refLogAPI href
+                >>= orThrowUser "rpc calling error"
+
+        rv <- ContT $ maybe1 rv' none
+
+        walkMerkle @[HashRef] (fromHashRef rv) (getBlock sto) $ \case
+          Left h -> liftIO $ throwIO (userError $ show $ "missed block:" <+> pretty h)
+          Right hrs -> do
+            for_ hrs $ \h -> void $ runMaybeT do
+              s <- getBlock sto (fromHashRef h)
+                     >>= toMPlus
+                     <&> deserialiseOrFail @(RefLogUpdate L4Proto)
+                     >>= toMPlus
+
+              guard =<< verifyRefLogUpdate s
+              liftIO $ BS.putStr (view refLogUpdData s)
 
     pPoll = hsubparser (  command "list" (info pPollList (progDesc "list current pollers" ))
                        <> command "add" (info  pPollAdd (progDesc "add poller" ))

hbs2/Main.hs

@@ -260,7 +260,7 @@ runCat opts ss = do
             Right lbs -> LBS.putStr lbs
             Left e    -> die (show e)
 
-        MerkleAnn ann -> die "asymmetric gropup encryption is deprecated"
+        MerkleAnn ann -> die "asymmetric group encryption is deprecated"
 
         -- FIXME: what-if-multiple-seq-ref-?
         SeqRef (SequentialRef _ (AnnotatedHashRef _ h)) -> do