wip, refchan head dump convenience opts

hbs2-core/lib/HBS2/Data/Types/Refs.hs

@@ -41,6 +41,9 @@ newtype TheHashRef t = TheHashRef { fromTheHashRef :: Hash HbSync }
 instance Pretty (AsBase58 (TheHashRef t)) where
   pretty (AsBase58 x) = pretty x
 
+instance Pretty (AsBase58 (TaggedHashRef t)) where
+  pretty (AsBase58 x) = pretty x
+
 instance FromStringMaybe (TheHashRef t) where
   fromStringMay = fmap TheHashRef . fromStringMay
 

hbs2-peer/app/CLI/RefChan.hs

@@ -38,6 +38,7 @@ import Data.ByteString.Lazy qualified as LBS
 import Data.ByteString qualified as BS
 import Data.HashSet qualified as HashSet
 import Data.Maybe
+import Data.Coerce
 import Lens.Micro.Platform
 import Options.Applicative
 import System.Exit
@@ -79,13 +80,50 @@ pRefChanHeadGen = do
     let qq = makeSignedBox @'HBS2Basic (view peerSignPk creds) (view peerSignSk creds) hd
     LBS.putStr (serialise qq)
 
+data HeadDumpOpts = HeadDumpRef (RefChanId L4Proto)
+                  | HeadDumpFile FilePath
+
 pRefChanHeadDump :: Parser (IO ())
 pRefChanHeadDump= do
-  fn <- optional $ strArgument (metavar "refchan head blob")
-  pure $ do
-    lbs <- maybe1 fn LBS.getContents LBS.readFile
+  opts <- pRpcCommon
+
+  what <- optional $ HeadDumpRef <$> argument pRefChanId  (metavar "REFCHAN-KEY")
+            <|> HeadDumpFile <$> strOption (short 'f' <> long "file"
+                                                      <> metavar "FILE"
+                                                      <> help "read from file")
+
+  pure $ flip runContT pure do
+
+    lbs <- case what of
+              Nothing -> lift $ LBS.getContents
+              Just (HeadDumpFile f) -> lift $ LBS.readFile f
+              Just (HeadDumpRef r) -> 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
+
+                rv <- lift (callRpcWaitMay @RpcRefChanHeadGet (TimeoutSec 1) refChanAPI r)
+                        >>= orThrowUser "rpc error"
+                        >>= orThrowUser "refchan head value not found"
+
+                liftIO $ print (pretty rv)
+
+                let sto = AnyStorage (StorageClient storageAPI)
+                runExceptT (readFromMerkle sto (SimpleKey (coerce rv)))
+                          >>= orThrowUser "can't decode refchan head "
+
+
     (_, hdblk) <- pure (unboxSignedBox @(RefChanHeadBlock L4Proto) @'HBS2Basic lbs) `orDie` "can't unbox signed box"
-    print $ pretty hdblk
+    liftIO $ print $ pretty hdblk
 
 
 pRefChanHeadPost :: Parser (IO ())

hbs2-peer/lib/HBS2/Peer/Proto/RefChan/Types.hs

@@ -27,16 +27,20 @@ import HBS2.System.Logger.Simple
 
 import Control.Monad.Trans.Maybe
 import Data.ByteString (ByteString)
+import Data.ByteString.Lazy qualified as LBS
 import Data.Either
 import Data.HashMap.Strict (HashMap)
 import Data.HashMap.Strict qualified as HashMap
 import Data.HashSet (HashSet)
 import Data.HashSet qualified as HashSet
 import Data.Maybe
+import Data.Either
 import Data.Text qualified as Text
 import Lens.Micro.Platform
 import Data.Hashable hiding (Hashed)
-
+import Data.Coerce
+import Data.List qualified as List
+import Codec.Serialise
 
 {- HLINT ignore "Use newtype instead of data" -}
 
@@ -89,11 +93,24 @@ instance Serialise RefChanActionRequest
 
 type DisclosedCredentials e = PeerCredentials (Encryption e)
 
-data RefChanHeadExt e =
-  RefChanDisclosedCredentials (TaggedHashRef (DisclosedCredentials e))
-  deriving stock (Generic)
+newtype RefChanHeadExt e =
+  RefChanHeadExt [LBS.ByteString]
+  deriving stock Generic
+  deriving newtype (Semigroup, Monoid)
 
-instance SerialisedCredentials (Encryption e) => Serialise (RefChanHeadExt e)
+data  RefChanDisclosedCredentials e =
+  RefChanDisclosedCredentials (TaggedHashRef (DisclosedCredentials e))
+  deriving stock (Eq,Generic)
+
+instance Pretty (AsBase58 (RefChanDisclosedCredentials e)) where
+  pretty (AsBase58 (RefChanDisclosedCredentials x)) = pretty x
+
+instance Pretty (RefChanDisclosedCredentials e) where
+  pretty (RefChanDisclosedCredentials x) = pretty x
+
+instance Serialise (RefChanHeadExt e)
+
+instance SerialisedCredentials (Encryption e) => Serialise (RefChanDisclosedCredentials e)
 
 data RefChanNotify e =
     Notify (RefChanId e) (SignedBox ByteString (Encryption e)) -- подписано ключом автора
@@ -246,7 +263,7 @@ instance ForRefChans e => FromStringMaybe (RefChanHeadBlock e) where
                       <*> pure (HashSet.fromList authors)
                       <*> pure (HashSet.fromList readers)
                       <*> pure (HashSet.fromList notifiers)
-                      <*> pure mempty
+                      <*> pure (LBS.toStrict $ serialise ext)
 
     where
       parsed = parseTop str & fromRight mempty
@@ -272,6 +289,13 @@ instance ForRefChans e => FromStringMaybe (RefChanHeadBlock e) where
                             ]
 
 
+      disclosed = catMaybes [ fromStringMay @HashRef (Text.unpack s)
+                            | (ListVal [SymbolVal "disclosed", LitStrVal s] ) <- parsed
+                            ]
+
+      ext1 = fmap serialise [ RefChanDisclosedCredentials @L4Proto (coerce c) | c <- disclosed ]
+      ext  = RefChanHeadExt ext1 & serialise
+
 instance (ForRefChans e
          , Pretty (AsBase58 (PubKey 'Sign (Encryption e)))
          , Pretty (AsBase58 (PubKey 'Encrypt (Encryption e)))
@@ -289,12 +313,24 @@ instance (ForRefChans e
                lstOf reader (HashSet.toList $ view refChanHeadReaders blk)
                <>
                lstOf notifier (HashSet.toList $ view refChanHeadNotifiers blk)
+               <>
+               lstOf disclosed_ disclosed
 
     where
+
+      RefChanHeadExt exs = deserialiseOrFail @(RefChanHeadExt L4Proto) (LBS.fromStrict $ view refChanHeadExt blk)
+                                & fromRight mempty
+
+      disclosed = [ deserialiseOrFail @(RefChanDisclosedCredentials L4Proto) s
+                  | s <- exs
+                  ] & rights
+
       peer (p,w) = parens ("peer" <+> dquotes (pretty (AsBase58 p)) <+> pretty w)
       author p   = parens ("author" <+> dquotes (pretty (AsBase58 p)))
       reader p   = parens ("reader" <+> dquotes (pretty (AsBase58 p)))
       notifier p = parens ("notifier" <+> dquotes (pretty (AsBase58 p)))
+      disclosed_ p = parens ("disclosed" <+> dquotes (pretty (AsBase58 p)))
+
       -- disclosed p =
 
       lstOf f e | null e = mempty

hbs2/Main.hs

@@ -11,6 +11,7 @@ import HBS2.Peer.Proto
 import HBS2.Peer.CLI.Detect
 import HBS2.Peer.RPC.Client.Unix
 import HBS2.Peer.RPC.API.Storage
+import HBS2.Peer.RPC.Client.StorageClient
 import HBS2.Net.Auth.GroupKeyAsymm as Asymm
 import HBS2.Net.Auth.GroupKeySymm qualified as Symm
 import HBS2.Net.Auth.GroupKeySymm
@@ -787,6 +788,7 @@ main = join . customExecParser (prefs showHelpOnError) $
                       <> yellow "Note:" <+> "the key will be safe until you publish its hash"
                       <+> "somewhere" <> line
                       <> "so if you have changed your mind --- you may delete it with hbs2 del"
+                      <> line <> line
 
           runKeymanClient $ loadCredentials pks
 
@@ -797,11 +799,11 @@ main = join . customExecParser (prefs showHelpOnError) $
 
         rpc <- ContT $ withRPC2 @StorageAPI soname
 
-        -- locate storage
-        -- put key block
-        -- done
+        let sto = AnyStorage (StorageClient rpc)
 
-        pure ()
+        h <- putBlock sto (serialise creds1)
+
+        liftIO $ print $ pretty h
 
     -- TODO: all-keyring-management-to-keyman
     pKeyRing = hsubparser (    command "find" (info pKeyRingFind (progDesc "find keyring"))