mirror of https://github.com/voidlizard/hbs2
406 lines
15 KiB
Haskell
406 lines
15 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.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)
|
|
|
|
|