module HBS2.CLI.Run.RefChan ( module HBS2.CLI.Run.RefChan , keymanNewCredentials ) where import HBS2.CLI.Prelude import HBS2.CLI.Run.Internal import HBS2.CLI.Run.Internal.KeyMan import HBS2.CLI.Run.Internal.RefChan import HBS2.Data.Types.Refs 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.RPC.Client.RefChan as Client import HBS2.Storage.Operations.ByteString -- import HBS2.Net.Proto -- import HBS2.Net.Auth.Credentials -- import HBS2.Base58 -- import HBS2.Defaults -- import HBS2.Events -- import HBS2.Peer.Proto.Peer -- import HBS2.Net.Proto.Sessions import HBS2.Data.Types.Refs import HBS2.Data.Detect -- import HBS2.Data.Types.SignedBox -- import HBS2.Storage import HBS2.Peer.Proto.RefChan import Data.Either import HBS2.Base58 import HBS2.Net.Auth.Credentials import HBS2.Net.Auth.Schema() import HBS2.Data.Types.SignedBox import HBS2.Peer.RPC.Client import HBS2.Peer.RPC.API.Storage import HBS2.Storage import HBS2.KeyMan.Keys.Direct import HBS2.KeyMan.App.Types import Data.HashMap.Strict qualified as HM import Data.HashSet qualified as HS import Data.Coerce import Control.Monad.Trans.Cont import Control.Monad.Trans.Maybe import Control.Monad.Except import Data.ByteString.Lazy qualified as LBS import Data.ByteString.Lazy.Char8 qualified as LBS8 import Data.ByteString.Char8 qualified as BS8 import Data.Text qualified as Text import Codec.Serialise import Control.Concurrent.STM qualified as STM import Text.InterpolatedString.Perl6 (qc) import Streaming.Prelude qualified as S refchanEntries :: forall c m . ( IsContext c , MonadUnliftIO m , Exception (BadFormException c) , HasClientAPI RefChanAPI UNIX m , HasClientAPI StorageAPI UNIX m , HasClientAPI PeerAPI UNIX m , HasStorage m ) => MakeDictM c m () refchanEntries = do brief "requests all rechans that peer is subcribed to" $ args [] $ returns "list" "list of all refchans" $ examples [qc| (hbs2:refchan:list) ("Atg67E6CPMJWKvR9BvwZTTEjg3Hjz4CYCaEARGANepGP" "A5W6jPBjzvdpxaQ2e8xBLYaRZjPXzi4yX7xjC52gTiKk" "EjjK7rpgRRJ4yzAhTcwis4XawwagCbmkns8n73ogY3uS") |] $ entry $ bindMatch "hbs2:refchan:list" $ \case [] -> do flip runContT pure do api <- getClientAPI @PeerAPI @UNIX 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) brief "reads refchan head block" $ args [arg "symbol" "parsed|_", arg "string" "PUBKEY"] $ returns "" "string" $ examples [qc| (hbs2:refchan:head:get :parsed ExTZuEy2qVBRshWdSwfxeKcMmQLbK2f5NxRwhvXda9qd) (version 2) (quorum 1) (wait 10) (peer "5tZfGUoQ79EzFUvyyY5Wh1LzN2oaqhrn9kPnfk6ByHpf" 1) (peer "35gKUG1mwBTr3tQpjWwR2kBYEnDmHxesoJL5Lj7tMjq3" 1) (peer "5GnroAC8FXNRL8rcgJj6RTu9mt1AbuNd5MZVnDBcCKzb" 1) (author "Gu5FxngYYwpRfCUS9DJBGyH3tvtjXFbcZ7CbxmJPWEGH") (author "ExTZuEy2qVBRshWdSwfxeKcMmQLbK2f5NxRwhvXda9qd") (reader "5UXrEhYECJ2kEQZZPEf4TisfWsLNdh2nGYQQz8X9ioMv") (reader "CcRDzezX1XQdPxRMuMKzJkfHFB4yG7vGJeTYvScKkbP8") ; (head-extensions: (count: 0) (size 0)) (hbs2:refchan:head:get :whatever ExTZuEy2qVBRshWdSwfxeKcMmQLbK2f5NxRwhvXda9qd) HucjFUznHJeA2UYZCdUFHtnE3pTwhCW5Dp7LV3ArZBcr |] $ entry $ bindMatch "hbs2:refchan:head:get" $ \case [StringLike what, SignPubKeyLike puk] -> do flip runContT pure do callCC $ \exit -> do w <- lift (getRefChanHeadHash @UNIX puk) hx <- ContT $ maybe1 w (pure nil) case what of "parsed" -> do hdblk <- lift (Client.getRefChanHead @UNIX puk) exit $ mkStr (show $ pretty hdblk) _ -> exit $ mkStr (show $ pretty $ AsBase58 hx) pure nil _ -> throwIO (BadFormException @c nil) entry $ bindMatch "hbs2:refchan:head:update" $ \syn -> do (rchan, rch) <- case syn of [SignPubKeyLike rchan, StringLike headFile] -> do rch <- liftIO (readFile headFile) <&> fromStringMay @(RefChanHeadBlock L4Proto) >>= orThrowUser "can't parse RefChanHeadBlock" pure (rchan, rch) [SignPubKeyLike rchan, ListVal syn] -> do rch <- fromStringMay @(RefChanHeadBlock L4Proto) (show $ vcat (fmap pretty syn)) & orThrowUser "can't parse RefChanHeadBlock" pure (rchan, rch) _ -> throwIO (BadFormException @c nil) sto <- getStorage rchanApi <- getClientAPI @RefChanAPI @UNIX creds <- runKeymanClient $ loadCredentials rchan >>= orThrowUser "can't load credentials" let box = makeSignedBox @'HBS2Basic (view peerSignPk creds) (view peerSignSk creds) rch href <- writeAsMerkle sto (serialise box) callService @RpcRefChanHeadPost rchanApi (HashRef href) >>= orThrowUser "can't post refchan head" pure nil entry $ bindMatch "hbs2:refchan:get" $ \case [SignPubKeyLike rchan] -> do api <- getClientAPI @RefChanAPI @UNIX h <- callService @RpcRefChanGet api rchan >>= orThrowUser "can't request refchan head" pure $ maybe nil (mkStr . show . pretty . AsBase58) h _ -> throwIO (BadFormException @c nil) entry $ bindMatch "hbs2:refchan:create" $ \syn -> do peerApi <- getClientAPI @PeerAPI @UNIX rch <- case syn of [ListVal es] -> do fromStringMay @(RefChanHeadBlock L4Proto) (show $ vcat (fmap pretty es)) & orThrowUser "Invalid refchan head syntax" [StringLike headFile] -> do liftIO (readFile headFile) <&> fromStringMay @(RefChanHeadBlock L4Proto) >>= orThrowUser "can't parse RefChanHeadBlock" [] -> do poked <- callService @RpcPoke peerApi () >>= orThrowUser "can't poke hbs2-peer" <&> parseTop >>= orThrowUser "invalid hbs2-peer attributes" ke <- [ x | ListVal [SymbolVal "peer-key:", SignPubKeyLike x] <- poked ] & headMay & orThrowUser "hbs2-peer key not found" let rch0 = refChanHeadDefault @L4Proto & set refChanHeadPeers (HM.singleton ke 1) & set refChanHeadAuthors (HS.singleton ke) pure rch0 _ -> throwIO (BadFormException @c nil) refchan <- createNewRefChan @c Nothing rch pure $ mkSym (show $ pretty (AsBase58 refchan)) brief "prints refchan head example" $ returns "nil" mempty $ entry $ bindMatch "hbs2:refchan:head:example" $ nil_ $ \case [] -> flip runContT pure do let rch0 = refChanHeadDefault @L4Proto api <- getClientAPI @PeerAPI @UNIX pips <- callService @RpcPeers api () <&> either (const mempty) (HM.fromList . fmap ((,1) . fst) . take 3) creds <- replicateM 3 (newCredentialsEnc @HBS2Basic 1) let authors = fmap (view peerSignPk) creds & HS.fromList let readers = foldMap (view peerKeyring) creds & fmap (view krPk) & take 3 & HS.fromList let rch = ( set refChanHeadPeers pips . set refChanHeadAuthors authors . set refChanHeadReaders readers . set refChanHeadNotifiers authors ) rch0 liftIO $ print $ ";" <+> "this is an example of refchan head block config" <> line <> ";" <+> "edit it before applying" <> line <> ";" <+> "set up the actual keys / credentials you need" <> line <> line <> line <> ";" <+> "(version INT) is the head block version" <> line <> ";" <+> "the refchan head block will be set only" <>line <> ";" <+> "if it's version if greater than the already existed one" <> line <> line <> ";" <+> "(quorum INT) is a number of accept messages issued by peers" <> line <> ";" <+> "to include propose message to the refchan" <> line <> line <> ";" <+> "(wait INT) is an quorum wait time in seconds" <> line <> line <> ";" <+> "(peer PUBKEY WEIGHT) sets the peer allowed for posting propose/accept messages" <> line <> ";" <+> "PUBKEY is a SIGNATURE public key as base58 string" <> line <> ";" <+> "only messages from that peers will be accepted" <> line <> ";" <+> "WEIGHT is not used yet but reserved for the future" <> line <> ";" <+> "this parameter is optional but there is should be some peers or" <> line <> ";" <+> "all messages will be sent to nowhere" <> line <> line <> ";" <+> "(author PUBKEY) adds 'author' i.e. key that is allowed to sign the propose message" <> line <> ";" <+> "PUBKEY is a SIGNATURE public key as base58 string" <> line <> ";" <+> "only the propose messages signed by one of thise keys will be accepted" <> line <> line <> ";" <+> "(notifier PUBKEY) adds 'notifier' i.e. key that is allowed to sign the notify message" <> line <> ";" <+> "PUBKEY is a SIGNATURE public key as base58 string" <> line <> ";" <+> "only the propose messages signed by one of thise keys will be accepted" <> line <> ";" <+> "notify messages are not written to the refchan merkle tree" <> line <> ";" <+> "and they useful for implementing any sort of ephemeral messaging" <> line <> ";" <+> "those clauses are OPTIONAL and may be omitted" <> line <> line <> ";" <+> "(reader PUBKEY) adds 'author' i.e. key that is allowed to decrypt messages" <> line <> ";" <+> "PUBKEY is a ENCRYPTION public key as base58 string" <> line <> ";" <+> "NOTE: messages in a refchan are not encrypted by default" <> line <> ";" <+> " it's totally up to an application for this refchan" <> line <> ";" <+> " therefore this clause is just used for setting reader keys to" <> line <> ";" <+> " implement any ACL/encrypting mechanism" <> line <> ";" <+> " i.e. groupkey may be inherited from the RefChanHead block" <> line <> ";" <+> " to encrypt data posted to a refchan" <> line <> ";" <+> "those clauses are OPTIONAL and may be omitted" <> line <> line <> pretty rch _ -> throwIO (BadFormException @c nil) brief "creates RefChanUpdate/AnnotatedHashRef transaction for refchan" $ args [arg "string" "sign-key", arg "string" "payload-tree-hash"] $ entry $ bindMatch "hbs2:refchan:tx:annref:create" $ \case [SignPubKeyLike signpk, HashLike hash] -> do sto <- getStorage void $ hasBlock sto (fromHashRef hash) `orDie` "no block found" let lbs = AnnotatedHashRef Nothing hash & serialise creds <- runKeymanClientRO $ loadCredentials signpk >>= orThrowUser "can't find credentials" let box = makeSignedBox @HBS2Basic (view peerSignPk creds) (view peerSignSk creds) (LBS.toStrict lbs) & serialise pure $ mkForm @c "blob" [mkStr (LBS8.unpack box)] _ -> throwIO (BadFormException @c nil) brief "creates RefChanUpdate/SeqRef transaction for refchan" $ args [arg "string" "sign-key", arg "string" "payload-tree-hash", arg "(-t int)?" "seqno"] $ entry $ bindMatch "hbs2:refchan:tx:seqref:create" $ \syn -> do now <- liftIO $ getPOSIXTime <&> round let (opts, argz) = splitOpts [("-s",1)] syn let s = headDef now [ x | MatchOption "-n" (LitIntVal x) <- opts] case opts of [SignPubKeyLike signpk, HashLike hash] -> do sto <- getStorage void $ hasBlock sto (fromHashRef hash) `orDie` "no block found" let lbs = SequentialRef s (AnnotatedHashRef Nothing hash) & serialise creds <- runKeymanClientRO $ loadCredentials signpk >>= orThrowUser "can't find credentials" let box = makeSignedBox @HBS2Basic (view peerSignPk creds) (view peerSignSk creds) (LBS.toStrict lbs) & serialise pure $ mkForm @c "blob" [mkStr (LBS8.unpack box)] _ -> throwIO (BadFormException @c nil) brief "creates RefChanUpdate/Raw transaction for refchan" $ args [arg "string" "sign-key", arg "string" "data"] $ entry $ bindMatch "hbs2:refchan:tx:raw:create" $ \syn -> do case syn of [SignPubKeyLike signpk, StringLike x] -> do let lbs = LBS8.pack x & serialise creds <- runKeymanClientRO $ loadCredentials signpk >>= orThrowUser "can't find credentials" let box = makeSignedBox @HBS2Basic (view peerSignPk creds) (view peerSignSk creds) (LBS.toStrict lbs) & serialise mkOpaque @c box _ -> throwIO (BadFormException @c nil) entry $ bindMatch "hbs2:refchan:tx:raw:list" $ \case [SignPubKeyLike rchan] -> lift do q <- newTQueueIO walkRefChanTx @UNIX (const $ pure True) rchan $ \txh u -> do case u of A (AcceptTran (Just ts) self what) -> do let tx = fromIntegral ts :: Integer let hs = show $ pretty self let they = show $ pretty what let x = mkForm @c "accept" [ mkSym hs, mkInt tx, mkSym they ] atomically $ writeTQueue q x A _ -> none P1 ppk h (ProposeTran _ box) -> void $ runMaybeT do (pk, bs) <- unboxSignedBox0 box & toMPlus bss <- deserialiseOrFail @LBS.ByteString (LBS.fromStrict bs) & toMPlus e <- mkOpaque bss let hs = show $ pretty h let ppks = show (pretty (AsBase58 ppk)) let pks = show (pretty (AsBase58 pk)) let x = mkForm @c "propose" [ mkSym hs, mkSym ppks, mkSym pks, e ] atomically $ writeTQueue q x P0{} -> none mkList <$> atomically (STM.flushTQueue q) e -> throwIO (BadFormException @c (mkList e)) brief "posts Propose transaction to the refchan" $ args [arg "string" "refchan", arg "blob" "signed-box"] $ entry $ bindMatch "hbs2:refchan:tx:propose" $ nil_ $ \syn -> do (chan,lbs) <- case syn of [SignPubKeyLike rchan, ListVal [SymbolVal "blob", LitStrVal box]] -> do bbox <- Text.unpack box & LBS8.pack & deserialiseOrFail & orThrowUser "bad transaction" pure (rchan, bbox) [SignPubKeyLike rchan, MatchOpaqueVal @_ @LBS.ByteString lbs] -> do pure (rchan, lbs) _ -> throwIO (BadFormException @c (mkList syn)) api <- getClientAPI @RefChanAPI @UNIX box <- deserialiseOrFail lbs & orThrowUser "invalid box" void $ callService @RpcRefChanPropose api (chan, box)