diff --git a/hbs2-core/lib/HBS2/Data/Types/Refs.hs b/hbs2-core/lib/HBS2/Data/Types/Refs.hs index 77b3bd25..bb365b47 100644 --- a/hbs2-core/lib/HBS2/Data/Types/Refs.hs +++ b/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 diff --git a/hbs2-peer/app/CLI/RefChan.hs b/hbs2-peer/app/CLI/RefChan.hs index a92c96a2..5a166b31 100644 --- a/hbs2-peer/app/CLI/RefChan.hs +++ b/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 ()) diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/RefChan/Types.hs b/hbs2-peer/lib/HBS2/Peer/Proto/RefChan/Types.hs index bf18761e..beed6b1e 100644 --- a/hbs2-peer/lib/HBS2/Peer/Proto/RefChan/Types.hs +++ b/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 diff --git a/hbs2/Main.hs b/hbs2/Main.hs index a1656de5..96d52cd3 100644 --- a/hbs2/Main.hs +++ b/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"))