From 4125b231234aa122ad07a1c1b84115ede437dea0 Mon Sep 17 00:00:00 2001 From: voidlizard Date: Fri, 11 Oct 2024 08:10:59 +0300 Subject: [PATCH] wip --- hbs2-peer/app/CLI/Mailbox.hs | 147 +++++++++++------- hbs2-peer/app/MailboxProtoWorker.hs | 26 +++- hbs2-peer/app/RPC2/Mailbox.hs | 19 +++ hbs2-peer/lib/HBS2/Peer/Proto/Mailbox.hs | 7 +- hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Ref.hs | 5 + .../lib/HBS2/Peer/Proto/Mailbox/Types.hs | 4 +- hbs2-peer/lib/HBS2/Peer/RPC/API/Mailbox.hs | 9 ++ 7 files changed, 158 insertions(+), 59 deletions(-) diff --git a/hbs2-peer/app/CLI/Mailbox.hs b/hbs2-peer/app/CLI/Mailbox.hs index f0b8a8be..211055ae 100644 --- a/hbs2-peer/app/CLI/Mailbox.hs +++ b/hbs2-peer/app/CLI/Mailbox.hs @@ -51,6 +51,8 @@ pMailBox = do what <- many (strArgument (metavar "ARGS" <> help "hbs2-cli mailbox command-line")) pure (runMailboxCLI rpc what) + + runMailboxCLI :: RPCOpt -> [String] -> IO () runMailboxCLI rpc s = do @@ -70,39 +72,8 @@ runMailboxCLI rpc s = do liftIO $ print $ pretty "okay, rpc is here" brief "creates mailbox of given type" $ - desc [qc| -; creates a mailbox using recipient SIGN public key - -create --key KEY TYPE - -; creates a mailbox using key from a SIGIL with HASH (should stored first) - -create --sigil HASH TYPE - -; creates a mailbox using key from a SIGIL from FILE - -create --sigil-file FILE TYPE - -TYPE ::= hub | relay - -|] $ - examples [qc| - -; create using recipient public key - -create --key 3fKeGjaDGBKtNqeNBPsThh8vSj4TPiqaaK7uHbB8MQUV relay - -; create using sigil hash - -create --sigil ghna99Xtm33ncfdUBT3htBUoEyT16wTZGMdm24BQ1kh relay - -; create using sigil file - -create --sigil-file ./my.sigil hub - -see hbs2-cli for sigil commands (create, store, load, etc) - -|] + desc createMailBoxDesc $ + examples createMailBoxExamples $ entry $ bindMatch "create" $ nil_ $ \syn -> do case syn of @@ -126,29 +97,7 @@ see hbs2-cli for sigil commands (create, store, load, etc) _ -> throwIO $ BadFormException @C nil brief "send message via gossip" $ - desc [qc| -; reads message blob from stdin - -send --stdin - -; read message blob from file - -send --file FILE - -; reads message blob from storage - -send HASH - -you may create a message from plain text using - -hbs2-cli hbs2:mailbox:message:create - -command - -SEE ALSO - hbs2:mailbox:message:create - - |] + desc sendMessageDesc $ entry $ bindMatch "send" $ nil_ $ \syn -> do blob <- case syn of @@ -172,6 +121,27 @@ SEE ALSO pure () + brief "get mailbox value" + $ entry $ bindMatch "get" $ nil_ $ \case + [ SignPubKeyLike m ] -> do + + v <- callRpcWaitMay @RpcMailboxGet t api m + >>= orThrowUser "rpc call timeout" + + liftIO $ print $ pretty v + + _ -> throwIO $ BadFormException @C nil + + brief "list mailboxes" + $ entry $ bindMatch "list" $ nil_ $ const do + + let fmtMbox (m,t) = pretty m <+> pretty t + + v <- callRpcWaitMay @RpcMailboxList t api () + >>= orThrowUser "rpc call timeout" + + liftIO $ print $ vcat (fmap fmtMbox v) + entry $ bindMatch "help" $ nil_ \case HelpEntryBound what -> helpEntry what [StringLike s] -> helpList False (Just s) @@ -184,3 +154,68 @@ SEE ALSO let sto = AnyStorage (StorageClient stoAPI) lift $ run (dict sto caller) cli >>= eatNil display + +-- man entries + +createMailBoxDesc :: Doc a +createMailBoxDesc = [qc| +; creates a mailbox using recipient SIGN public key + +create --key KEY TYPE + +; creates a mailbox using key from a SIGIL with HASH (should stored first) + +create --sigil HASH TYPE + +; creates a mailbox using key from a SIGIL from FILE + +create --sigil-file FILE TYPE + +TYPE ::= hub | relay + +|] + +createMailBoxExamples :: ManExamples +createMailBoxExamples = [qc| +; create using recipient public key + +create --key 3fKeGjaDGBKtNqeNBPsThh8vSj4TPiqaaK7uHbB8MQUV relay + +; create using sigil hash + +create --sigil ghna99Xtm33ncfdUBT3htBUoEyT16wTZGMdm24BQ1kh relay + +; create using sigil file + +create --sigil-file ./my.sigil hub + +see hbs2-cli for sigil commands (create, store, load, etc) + +|] + + +sendMessageDesc :: Doc a +sendMessageDesc = [qc| +; reads message blob from stdin + +send --stdin + +; read message blob from file + +send --file FILE + +; reads message blob from storage + +send HASH + +you may create a message from plain text using + +hbs2-cli hbs2:mailbox:message:create + +command + +SEE ALSO + hbs2:mailbox:message:create + +|] + diff --git a/hbs2-peer/app/MailboxProtoWorker.hs b/hbs2-peer/app/MailboxProtoWorker.hs index 5c0cd4c4..5914d6dc 100644 --- a/hbs2-peer/app/MailboxProtoWorker.hs +++ b/hbs2-peer/app/MailboxProtoWorker.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} {-# Language AllowAmbiguousTypes #-} {-# Language UndecidableInstances #-} module MailboxProtoWorker ( mailboxProtoWorker @@ -120,6 +121,21 @@ instance ( s ~ Encryption e, e ~ L4Proto pure $ Right () + mailboxListBasic MailboxProtoWorker{..} = do + + flip runContT pure do + + mdbe <- readTVarIO mailboxDB + + dbe <- ContT $ maybe1 mdbe (pure $ Left (MailboxCreateFailed "database not ready")) + + debug $ red "mailboxListBasic" + + r <- withDB dbe do + select_ @_ @(MailboxRefKey s, MailboxType) [qc|select recipient,type from mailbox|] + + pure $ Right r + getMailboxType_ :: (ForMailbox s, MonadIO m) => DBPipeEnv -> Recipient s -> m (Maybe MailboxType) getMailboxType_ d r = do let sql = [qc|select type from mailbox where recipient = ? limit 1|] @@ -264,7 +280,7 @@ mailboxProtoWorker readConf me@MailboxProtoWorker{..} = do let mergedTx = HS.fromList txs <> newTx & HS.toList -- FIXME: size-hardcode-again - let pt = toPTree (MaxSize 6000) (MaxNum 256) mergedTx + let pt = toPTree (MaxSize 6000) (MaxNum 1024) mergedTx nref <- makeMerkle 0 pt $ \(_,_,bss) -> void $ liftIO $ putBlock sto bss updateRef sto r nref @@ -308,3 +324,11 @@ mailboxStateEvolve readConf MailboxProtoWorker{..} = do pure dbe + +instance ForMailbox s => FromField (MailboxRefKey s) where + fromField w = fromField @String w <&> fromString @(MailboxRefKey s) + +instance FromField MailboxType where + fromField w = fromField @String w <&> fromString @MailboxType + + diff --git a/hbs2-peer/app/RPC2/Mailbox.hs b/hbs2-peer/app/RPC2/Mailbox.hs index 5e746d7c..ef015773 100644 --- a/hbs2-peer/app/RPC2/Mailbox.hs +++ b/hbs2-peer/app/RPC2/Mailbox.hs @@ -4,11 +4,13 @@ module RPC2.Mailbox where import HBS2.Peer.Prelude +import HBS2.Data.Types.Refs import HBS2.Base58 import HBS2.Actors.Peer import HBS2.Data.Types.SignedBox import HBS2.Peer.Proto import HBS2.Peer.Proto.Mailbox +import HBS2.Peer.Proto.Mailbox.Ref import HBS2.Storage import HBS2.Net.Messaging.Unix import HBS2.Misc.PrettyStuff @@ -20,6 +22,7 @@ import PeerTypes import HBS2.Peer.RPC.Internal.Types import HBS2.Peer.RPC.API.Mailbox +import Data.Either import Lens.Micro.Platform import Control.Monad.Reader import Control.Monad.Trans.Maybe @@ -43,6 +46,13 @@ instance (ForMailboxRPC m) => HandleMethod m RpcMailboxCreate where debug $ "rpc.RpcMailboxCreate" <+> pretty (AsBase58 puk) <+> pretty t +instance (ForMailboxRPC m) => HandleMethod m RpcMailboxList where + + handleMethod _ = do + AnyMailboxService mbs <- getRpcContext @MailboxAPI @RPC2Context <&> rpcMailboxService + r <- mailboxListBasic @HBS2Basic mbs + pure $ fromRight mempty r + instance (ForMailboxRPC m) => HandleMethod m RpcMailboxSend where handleMethod mess = do @@ -51,3 +61,12 @@ instance (ForMailboxRPC m) => HandleMethod m RpcMailboxSend where debug $ "rpc.RpcMailboxSend" void $ mailboxSendMessage w mess +instance (ForMailboxRPC m) => HandleMethod m RpcMailboxGet where + + handleMethod mbox = do + RPC2Context{..} <- getRpcContext @MailboxAPI @RPC2Context + debug $ "rpc.RpcMailboxGet" + getRef rpcStorage (MailboxRefKey @HBS2Basic mbox) + <&> fmap HashRef + + diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox.hs b/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox.hs index fb11c0de..33c965fe 100644 --- a/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox.hs +++ b/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox.hs @@ -103,15 +103,20 @@ class ForMailbox s => IsMailboxService s a where -> Message s -> m (Either MailboxServiceError ()) + mailboxListBasic :: forall m . MonadIO m + => a + -> m (Either MailboxServiceError [(MailboxRefKey s, MailboxType)]) + data AnyMailboxService s = forall a . (IsMailboxService s a) => AnyMailboxService { mailboxService :: a } data AnyMailboxAdapter s = - forall a . (IsMailboxProtoAdapter s a) => AnyMailboxAdapter { mailboxAdapter :: a} + forall a . (IsMailboxProtoAdapter s a) => AnyMailboxAdapter { mailboxAdapter :: a } instance ForMailbox s => IsMailboxService s (AnyMailboxService s) where mailboxCreate (AnyMailboxService a) = mailboxCreate @s a mailboxSendMessage (AnyMailboxService a) = mailboxSendMessage @s a + mailboxListBasic (AnyMailboxService a) = mailboxListBasic @s a instance IsMailboxProtoAdapter s (AnyMailboxAdapter s) where mailboxGetStorage (AnyMailboxAdapter a) = mailboxGetStorage @s a diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Ref.hs b/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Ref.hs index ceb450bf..5c636c16 100644 --- a/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Ref.hs +++ b/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Ref.hs @@ -3,6 +3,9 @@ module HBS2.Peer.Proto.Mailbox.Ref where import HBS2.Prelude + +import HBS2.Peer.Proto.Mailbox.Types + import HBS2.Hash import HBS2.Base58 import HBS2.Net.Proto.Types @@ -12,6 +15,7 @@ import Data.Maybe (fromMaybe) import Data.Hashable hiding (Hashed) newtype MailboxRefKey s = MailboxRefKey (PubKey 'Sign s) + deriving stock Generic instance RefMetaData (MailboxRefKey s) @@ -35,4 +39,5 @@ instance Pretty (AsBase58 (PubKey 'Sign s)) => Pretty (AsBase58 (MailboxRefKey s instance Pretty (AsBase58 (PubKey 'Sign s)) => Pretty (MailboxRefKey s) where pretty (MailboxRefKey k) = pretty (AsBase58 k) +instance ForMailbox s => Serialise (MailboxRefKey s) diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Types.hs b/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Types.hs index 0ed9ab14..a7d5ffd7 100644 --- a/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Types.hs +++ b/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Types.hs @@ -25,6 +25,7 @@ import HBS2.Net.Auth.GroupKeySymm import Data.Word (Word32) import Codec.Serialise +import Data.Maybe data MailboxType = MailboxHub | MailboxRelay @@ -77,5 +78,6 @@ instance FromStringMaybe MailboxType where "relay" -> Just MailboxRelay _ -> Nothing - +instance IsString MailboxType where + fromString s = fromMaybe (error "invalid MailboxType value") (fromStringMay s) diff --git a/hbs2-peer/lib/HBS2/Peer/RPC/API/Mailbox.hs b/hbs2-peer/lib/HBS2/Peer/RPC/API/Mailbox.hs index 8bab1687..e7efd74b 100644 --- a/hbs2-peer/lib/HBS2/Peer/RPC/API/Mailbox.hs +++ b/hbs2-peer/lib/HBS2/Peer/RPC/API/Mailbox.hs @@ -16,11 +16,15 @@ import Codec.Serialise data RpcMailboxPoke data RpcMailboxCreate +data RpcMailboxList data RpcMailboxSend +data RpcMailboxGet type MailboxAPI = '[ RpcMailboxPoke , RpcMailboxCreate + , RpcMailboxList , RpcMailboxSend + , RpcMailboxGet ] type MailboxAPIProto = 0x056091510d3b2ec9 @@ -38,7 +42,12 @@ type instance Output RpcMailboxPoke = () type instance Input RpcMailboxCreate = (PubKey 'Sign HBS2Basic, MailboxType) type instance Output RpcMailboxCreate = () +type instance Input RpcMailboxList = () +type instance Output RpcMailboxList = [(MailboxRefKey 'HBS2Basic, MailboxType)] + type instance Input RpcMailboxSend = (Message HBS2Basic) type instance Output RpcMailboxSend = () +type instance Input RpcMailboxGet = (PubKey 'Sign HBS2Basic) +type instance Output RpcMailboxGet = (Maybe HashRef)