mirror of https://github.com/voidlizard/hbs2
329 lines
12 KiB
Haskell
329 lines
12 KiB
Haskell
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.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.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.Except
|
|
import Data.ByteString.Lazy qualified as LBS
|
|
import Data.ByteString.Lazy.Char8 qualified as LBS8
|
|
import Data.Text qualified as Text
|
|
import Codec.Serialise
|
|
|
|
import Text.InterpolatedString.Perl6 (qc)
|
|
|
|
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" $ \case
|
|
[SignPubKeyLike rchan, StringLike headFile] -> do
|
|
|
|
sto <- getStorage
|
|
|
|
rchanApi <- getClientAPI @RefChanAPI @UNIX
|
|
|
|
rch <- liftIO (readFile headFile)
|
|
<&> fromStringMay @(RefChanHeadBlock L4Proto)
|
|
>>= orThrowUser "can't parse RefChanHeadBlock"
|
|
|
|
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
|
|
|
|
_ -> throwIO (BadFormException @c 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
|
|
rchanApi <- getClientAPI @RefChanAPI @UNIX
|
|
sto <- getStorage
|
|
|
|
rch <- case syn of
|
|
[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 <- keymanNewCredentials (Just "refchan") 0
|
|
|
|
creds <- runKeymanClient $ loadCredentials refchan
|
|
>>= orThrowUser "can't load credentials"
|
|
|
|
let box = makeSignedBox @'HBS2Basic (view peerSignPk creds) (view peerSignSk creds) rch
|
|
|
|
href <- writeAsMerkle sto (serialise box)
|
|
|
|
callService @RpcPollAdd peerApi (refchan, "refchan", 17)
|
|
>>= orThrowUser "can't subscribe to refchan"
|
|
|
|
callService @RpcRefChanHeadPost rchanApi (HashRef href)
|
|
>>= orThrowUser "can't post refchan head"
|
|
|
|
let r = mkStr @c $ show $ "; refchan " <+> pretty (AsBase58 refchan) <> line
|
|
<> pretty rch
|
|
|
|
pure r
|
|
|
|
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 <- runKeymanClient $ 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 "posts Propose transaction to the refchan" $
|
|
args [arg "string" "refchan", arg "blob" "signed-box"] $
|
|
entry $ bindMatch "hbs2:refchan:tx:propose" $ nil_ $ \case
|
|
[SignPubKeyLike rchan, ListVal [SymbolVal "blob", LitStrVal box]] -> do
|
|
api <- getClientAPI @RefChanAPI @UNIX
|
|
bbox <- Text.unpack box & LBS8.pack & deserialiseOrFail & orThrowUser "bad transaction"
|
|
void $ callService @RpcRefChanPropose api (rchan, bbox)
|
|
|
|
_ -> throwIO (BadFormException @c nil)
|
|
|