From 6962b7412e19e87480b24662c33cc63f850cb236 Mon Sep 17 00:00:00 2001 From: voidlizard Date: Fri, 11 Oct 2024 12:31:04 +0300 Subject: [PATCH] wip --- hbs2-peer/app/CLI/Mailbox.hs | 13 +++++ hbs2-peer/app/MailboxProtoWorker.hs | 48 +++++++++++++----- hbs2-peer/app/PeerMain.hs | 2 +- hbs2-peer/app/RPC2/Mailbox.hs | 10 ++++ hbs2-peer/lib/HBS2/Peer/Proto/Mailbox.hs | 50 +++++++++++++++---- .../lib/HBS2/Peer/Proto/Mailbox/Types.hs | 9 ++++ hbs2-peer/lib/HBS2/Peer/RPC/API/Mailbox.hs | 6 +++ 7 files changed, 114 insertions(+), 24 deletions(-) diff --git a/hbs2-peer/app/CLI/Mailbox.hs b/hbs2-peer/app/CLI/Mailbox.hs index 7095a632..8db84b5a 100644 --- a/hbs2-peer/app/CLI/Mailbox.hs +++ b/hbs2-peer/app/CLI/Mailbox.hs @@ -137,6 +137,19 @@ runMailboxCLI rpc s = do _ -> throwIO $ BadFormException @C nil + brief "get mailbox status" + $ entry $ bindMatch "status" $ nil_ $ \case + [ SignPubKeyLike m ] -> do + + v <- callRpcWaitMay @RpcMailboxGetStatus t api m + >>= orThrowUser "rpc call timeout" + >>= orThrowPassIO + + liftIO $ print $ pretty v + + _ -> throwIO $ BadFormException @C nil + + brief "list mailboxes" $ entry $ bindMatch "list" $ nil_ $ const do diff --git a/hbs2-peer/app/MailboxProtoWorker.hs b/hbs2-peer/app/MailboxProtoWorker.hs index 1667aed3..71425ae6 100644 --- a/hbs2-peer/app/MailboxProtoWorker.hs +++ b/hbs2-peer/app/MailboxProtoWorker.hs @@ -37,18 +37,19 @@ import BlockDownload() import DBPipe.SQLite -import Control.Monad.Trans.Cont -import Control.Monad.Trans.Maybe -import Data.Maybe -import UnliftIO import Control.Concurrent.STM qualified as STM -- import Control.Concurrent.STM.TBQueue -import Data.HashMap.Strict qualified as HM +import Control.Monad.Trans.Cont +import Control.Monad.Trans.Maybe +import Data.Coerce import Data.HashMap.Strict (HashMap) -import Data.HashSet qualified as HS +import Data.HashMap.Strict qualified as HM import Data.HashSet (HashSet) +import Data.HashSet qualified as HS +import Data.Maybe import Lens.Micro.Platform import Text.InterpolatedString.Perl6 (qc) +import UnliftIO data MailboxProtoException = MailboxProtoWorkerTerminatedException @@ -68,6 +69,7 @@ data MailboxProtoWorker (s :: CryptoScheme) e = { mpwPeerEnv :: PeerEnv e , mpwDownloadEnv :: DownloadEnv e , mpwStorage :: AnyStorage + , mpwCredentials :: PeerCredentials s , inMessageQueue :: TBQueue (Message s, MessageContent s) , inMessageMergeQueue :: TVar (HashMap (MailboxRefKey s) (HashSet HashRef)) , inMessageQueueInNum :: TVar Int @@ -78,6 +80,9 @@ data MailboxProtoWorker (s :: CryptoScheme) e = } instance (s ~ HBS2Basic, e ~ L4Proto, s ~ Encryption e) => IsMailboxProtoAdapter s (MailboxProtoWorker s e) where + + mailboxGetCredentials = pure . mpwCredentials + mailboxGetStorage = pure . mpwStorage mailboxAcceptMessage MailboxProtoWorker{..} m c = do @@ -159,22 +164,39 @@ instance ( s ~ Encryption e, e ~ L4Proto pure $ Right r mailboxGetStatus MailboxProtoWorker{..} ref = do - undefined + -- TODO: support-policy-ASAP -getMailboxType_ :: (ForMailbox s, MonadIO m) => DBPipeEnv -> Recipient s -> m (Maybe MailboxType) + now <- liftIO $ getPOSIXTime <&> round + + flip runContT pure do + + mdbe <- readTVarIO mailboxDB + + dbe <- ContT $ maybe1 mdbe (pure $ Left (MailboxCreateFailed "database not ready")) + + t' <- getMailboxType_ dbe ref + + t <- ContT $ maybe1 t' (pure $ Right Nothing) + + v <- getRef mpwStorage ref <&> fmap HashRef + + pure $ Right $ Just $ MailBoxStatusPayload @s now (coerce ref) t v mzero mzero + +getMailboxType_ :: (ForMailbox s, MonadIO m) => DBPipeEnv -> MailboxRefKey s -> m (Maybe MailboxType) getMailboxType_ d r = do let sql = [qc|select type from mailbox where recipient = ? limit 1|] withDB d do - select @(Only String) sql (Only (show $ pretty (AsBase58 r))) + select @(Only String) sql (Only r) <&> fmap (fromStringMay @MailboxType . fromOnly) <&> headMay . catMaybes createMailboxProtoWorker :: forall s e m . (MonadIO m, s ~ Encryption e, ForMailbox s) - => PeerEnv e + => PeerCredentials s + -> PeerEnv e -> DownloadEnv e -> AnyStorage -> m (MailboxProtoWorker s e) -createMailboxProtoWorker pe de sto = do +createMailboxProtoWorker pc pe de sto = do -- FIXME: queue-size-hardcode -- $class: hardcode inQ <- newTBQueueIO 1000 @@ -184,7 +206,7 @@ createMailboxProtoWorker pe de sto = do outNum <- newTVarIO 0 decl <- newTVarIO 0 dbe <- newTVarIO Nothing - pure $ MailboxProtoWorker pe de sto inQ mergeQ inNum outNum inDroppped decl dbe + pure $ MailboxProtoWorker pe de sto pc inQ mergeQ inNum outNum inDroppped decl dbe mailboxProtoWorker :: forall e s m . ( MonadIO m , MonadUnliftIO m @@ -243,7 +265,7 @@ mailboxProtoWorker readConf me@MailboxProtoWorker{..} = do -- TODO: process-with-policy for_ (messageRecipients s) $ \rcpt -> void $ runMaybeT do - mbox <- getMailboxType_ @s dbe rcpt + mbox <- getMailboxType_ @s dbe (MailboxRefKey rcpt) >>= toMPlus -- TODO: ASAP-block-accounting diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index d84873e8..970e951a 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/hbs2-peer/app/PeerMain.hs @@ -902,7 +902,7 @@ runPeer opts = Exception.handle (\e -> myException e rcw <- async $ liftIO $ runRefChanRelyWorker rce refChanAdapter - mailboxWorker <- createMailboxProtoWorker penv denv (AnyStorage s) + mailboxWorker <- createMailboxProtoWorker pc penv denv (AnyStorage s) let onNoBlock (p, h) = do already <- liftIO $ Cache.lookup nbcache (p,h) <&> isJust diff --git a/hbs2-peer/app/RPC2/Mailbox.hs b/hbs2-peer/app/RPC2/Mailbox.hs index 76d5ea0a..05dcb5cb 100644 --- a/hbs2-peer/app/RPC2/Mailbox.hs +++ b/hbs2-peer/app/RPC2/Mailbox.hs @@ -11,6 +11,8 @@ import HBS2.Data.Types.SignedBox import HBS2.Peer.Proto import HBS2.Peer.Proto.Mailbox import HBS2.Peer.Proto.Mailbox.Ref +import HBS2.Peer.Proto.Mailbox.Types + import HBS2.Storage import HBS2.Net.Messaging.Unix import HBS2.Misc.PrettyStuff @@ -45,6 +47,14 @@ instance (ForMailboxRPC m) => HandleMethod m RpcMailboxCreate where void $ mailboxCreate @HBS2Basic mbs t puk debug $ "rpc.RpcMailboxCreate" <+> pretty (AsBase58 puk) <+> pretty t + +instance (ForMailboxRPC m) => HandleMethod m RpcMailboxGetStatus where + + handleMethod puk = do + AnyMailboxService mbs <- getRpcContext @MailboxAPI @RPC2Context <&> rpcMailboxService + debug $ "rpc.RpcMailboxGetStatus" <+> pretty (AsBase58 puk) + mailboxGetStatus @HBS2Basic mbs (MailboxRefKey puk) + instance (ForMailboxRPC m) => HandleMethod m RpcMailboxDelete where handleMethod puk = do diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox.hs b/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox.hs index d50ee739..af98506a 100644 --- a/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox.hs +++ b/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox.hs @@ -10,23 +10,29 @@ module HBS2.Peer.Proto.Mailbox import HBS2.Prelude.Plated import HBS2.Hash +import HBS2.Base58 import HBS2.Data.Types.Refs import HBS2.Data.Types.SignedBox import HBS2.Storage import HBS2.Actors.Peer.Types +import HBS2.Net.Auth.Credentials import HBS2.Peer.Proto.Mailbox.Types import HBS2.Peer.Proto.Mailbox.Message import HBS2.Peer.Proto.Mailbox.Entry import HBS2.Peer.Proto.Mailbox.Ref -import Data.Maybe -import Control.Monad.Trans.Cont import Codec.Serialise() +import Control.Monad.Trans.Cont +import Control.Monad.Trans.Maybe +import Data.Maybe +import Data.Word +import Lens.Micro.Platform data MailBoxStatusPayload s = MailBoxStatusPayload - { mbsMailboxKey :: MailboxKey s + { mbsMailboxPayloadNonce :: Word64 + , mbsMailboxKey :: MailboxKey s , mbsMailboxType :: MailboxType , mbsMailboxHash :: Maybe HashRef , mbsMailboxPolicyVersion :: Maybe PolicyVersion @@ -69,6 +75,8 @@ instance ForMailbox s => Serialise (MailBoxProto s e) class IsMailboxProtoAdapter s a where + mailboxGetCredentials :: forall m . MonadIO m => a -> m (PeerCredentials s) + mailboxGetStorage :: forall m . MonadIO m => a -> m AnyStorage mailboxAcceptMessage :: forall m . (ForMailbox s, MonadIO m) @@ -77,10 +85,6 @@ class IsMailboxProtoAdapter s a where -> MessageContent s -> m () -data MailboxServiceError = - MailboxCreateFailed String - deriving stock (Typeable,Show) - class ForMailbox s => IsMailboxService s a where @@ -132,9 +136,26 @@ instance ForMailbox s => IsMailboxService s (AnyMailboxService s) where mailboxGetStatus (AnyMailboxService a) = mailboxGetStatus @s a instance IsMailboxProtoAdapter s (AnyMailboxAdapter s) where + mailboxGetCredentials (AnyMailboxAdapter a) = mailboxGetCredentials @s a mailboxGetStorage (AnyMailboxAdapter a) = mailboxGetStorage @s a mailboxAcceptMessage (AnyMailboxAdapter a) = mailboxAcceptMessage @s a +instance ForMailbox s => Pretty (MailBoxStatusPayload s) where + pretty MailBoxStatusPayload{..} = + parens $ "mailbox-status" <> line <> st + where + st = indent 2 $ + brackets $ + vcat [ parens ("nonce" <+> pretty mbsMailboxPayloadNonce) + , parens ("key" <+> pretty (AsBase58 mbsMailboxKey)) + , parens ("type" <+> pretty mbsMailboxType) + , element "mailbox-tree" mbsMailboxHash + , element "policy-version" mbsMailboxPolicyVersion + , element "policy-tree" mbsMailboxPolicyHash + ] + + element el = maybe mempty ( \v -> parens (el <+> pretty v) ) + mailboxProto :: forall e s m p a . ( MonadIO m , Response e p m , HasDeferred p e m @@ -228,10 +249,20 @@ mailboxProto inner adapter mess = deferred @p do -- и так и известен в протоколе) -- - CheckMailbox k -> do + CheckMailbox k -> deferred @p do + creds <- mailboxGetCredentials @s adapter + + void $ runMaybeT do + -- TODO: check-policy - none + s <- mailboxGetStatus adapter (MailboxRefKey @s k) + >>= toMPlus + >>= toMPlus + + let box = makeSignedBox @s (view peerSignPk creds) (view peerSignSk creds) s + + lift $ response @_ @p (MailBoxProtoV1 (MailboxStatus box)) MailboxStatus{} -> do -- TODO: implement-MailboxStatus @@ -253,4 +284,3 @@ mailboxProto inner adapter mess = deferred @p do none - diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Types.hs b/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Types.hs index a7d5ffd7..aeff2c2b 100644 --- a/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Types.hs +++ b/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Types.hs @@ -4,6 +4,7 @@ module HBS2.Peer.Proto.Mailbox.Types ( ForMailbox , MailboxKey , MailboxType(..) + , MailboxServiceError(..) , Recipient , Sender , PolicyVersion @@ -26,6 +27,14 @@ import HBS2.Net.Auth.GroupKeySymm import Data.Word (Word32) import Codec.Serialise import Data.Maybe +import Control.Exception + +data MailboxServiceError = + MailboxCreateFailed String + deriving stock (Typeable,Show,Generic) + +instance Serialise MailboxServiceError +instance Exception MailboxServiceError data MailboxType = MailboxHub | MailboxRelay diff --git a/hbs2-peer/lib/HBS2/Peer/RPC/API/Mailbox.hs b/hbs2-peer/lib/HBS2/Peer/RPC/API/Mailbox.hs index 653d2f3a..6a7495e7 100644 --- a/hbs2-peer/lib/HBS2/Peer/RPC/API/Mailbox.hs +++ b/hbs2-peer/lib/HBS2/Peer/RPC/API/Mailbox.hs @@ -17,6 +17,7 @@ import Codec.Serialise data RpcMailboxPoke data RpcMailboxCreate data RpcMailboxDelete +data RpcMailboxGetStatus data RpcMailboxList data RpcMailboxSend data RpcMailboxGet @@ -24,6 +25,7 @@ data RpcMailboxGet type MailboxAPI = '[ RpcMailboxPoke , RpcMailboxCreate , RpcMailboxDelete + , RpcMailboxGetStatus , RpcMailboxList , RpcMailboxSend , RpcMailboxGet @@ -47,6 +49,10 @@ type instance Output RpcMailboxCreate = () type instance Input RpcMailboxDelete = (PubKey 'Sign HBS2Basic) type instance Output RpcMailboxDelete = () + +type instance Input RpcMailboxGetStatus = (PubKey 'Sign HBS2Basic) +type instance Output RpcMailboxGetStatus = Either MailboxServiceError (Maybe (MailBoxStatusPayload 'HBS2Basic)) + type instance Input RpcMailboxList = () type instance Output RpcMailboxList = [(MailboxRefKey 'HBS2Basic, MailboxType)]