From 172e180d0e65f9acf32bda9e6810a4d29931ce36 Mon Sep 17 00:00:00 2001 From: voidlizard Date: Wed, 9 Oct 2024 06:02:34 +0300 Subject: [PATCH] wip, SendMessage handler --- hbs2-peer/app/MailboxProtoWorker.hs | 6 +- hbs2-peer/app/PeerMain.hs | 2 +- hbs2-peer/hbs2-peer.cabal | 1 + hbs2-peer/lib/HBS2/Peer/Proto/Mailbox.hs | 63 ++++++++++++++++--- .../lib/HBS2/Peer/Proto/Mailbox/Entry.hs | 19 ++++++ 5 files changed, 80 insertions(+), 11 deletions(-) create mode 100644 hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Entry.hs diff --git a/hbs2-peer/app/MailboxProtoWorker.hs b/hbs2-peer/app/MailboxProtoWorker.hs index eb6cc000..7d7b945b 100644 --- a/hbs2-peer/app/MailboxProtoWorker.hs +++ b/hbs2-peer/app/MailboxProtoWorker.hs @@ -34,7 +34,11 @@ data MailboxProtoWorker e = { } -instance IsMailboxProtoAdapter e (MailboxProtoWorker e) +instance IsMailboxProtoAdapter 'HBS2Basic (MailboxProtoWorker e) where + mailboxGetStorage = const $ error "OOPSIE" + + mailboxAcceptMessage _ _ _ = do + error "DOOPSIE" createMailboxProtoWorker :: forall e m . MonadIO m => m (MailboxProtoWorker e) createMailboxProtoWorker = do diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index da09bebb..3c05e13c 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/hbs2-peer/app/PeerMain.hs @@ -1106,7 +1106,7 @@ runPeer opts = Exception.handle (\e -> myException e peerThread "lwwRefWorker" (lwwRefWorker @e conf (SomeBrains brains)) - mbw <- createMailboxProtoWorker @L4Proto + mbw <- createMailboxProtoWorker @e peerThread "mailboxProtoWorker" (mailboxProtoWorker mbw) liftIO $ withPeerM penv do diff --git a/hbs2-peer/hbs2-peer.cabal b/hbs2-peer/hbs2-peer.cabal index 0f9dad92..089b7e1d 100644 --- a/hbs2-peer/hbs2-peer.cabal +++ b/hbs2-peer/hbs2-peer.cabal @@ -165,6 +165,7 @@ library HBS2.Peer.Proto.Mailbox HBS2.Peer.Proto.Mailbox.Types HBS2.Peer.Proto.Mailbox.Message + HBS2.Peer.Proto.Mailbox.Entry HBS2.Peer.Proto.BrowserPlugin HBS2.Peer.RPC.Client diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox.hs b/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox.hs index be4be504..9252e472 100644 --- a/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox.hs +++ b/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox.hs @@ -7,11 +7,18 @@ module HBS2.Peer.Proto.Mailbox import HBS2.Prelude.Plated +import HBS2.Hash +import HBS2.Data.Types.Refs import HBS2.Data.Types.SignedBox +import HBS2.Storage +import HBS2.Actors.Peer.Types import HBS2.Peer.Proto.Mailbox.Types import HBS2.Peer.Proto.Mailbox.Message +import HBS2.Peer.Proto.Mailbox.Entry +import Data.Maybe +import Control.Monad.Trans.Cont import Codec.Serialise data MailBoxStatusPayload s = @@ -65,14 +72,24 @@ instance ForMailbox s => Serialise (DeleteMessagesPayload s) instance ForMailbox s => Serialise (MailBoxProtoMessage s e) instance ForMailbox s => Serialise (MailBoxProto s e) -class IsMailboxProtoAdapter e a where +class IsMailboxProtoAdapter s a where + mailboxGetStorage :: forall m . MonadIO m => a -> m AnyStorage -mailboxProto :: forall e m p a . ( MonadIO m - , Response e p m - , HasDeferred p e m - , IsMailboxProtoAdapter e a - , p ~ MailBoxProto (Encryption e) e - ) + mailboxAcceptMessage :: forall m . (ForMailbox s, MonadIO m) + => a + -> Message s + -> MessageContent s + -> m () + +mailboxProto :: forall e s m p a . ( MonadIO m + , Response e p m + , HasDeferred p e m + , HasGossip e p m + , IsMailboxProtoAdapter s a + , p ~ MailBoxProto s e + , s ~ Encryption e + , ForMailbox s + ) => a -> MailBoxProto (Encryption e) e -> m () @@ -80,8 +97,11 @@ mailboxProto :: forall e m p a . ( MonadIO m mailboxProto adapter mess = do -- common stuff + sto <- mailboxGetStorage @s adapter + now <- liftIO $ getPOSIXTime <&> round + case mailBoxProtoPayload mess of - SendMessage{} -> do + SendMessage msg -> deferred @p do -- TODO: implement-SendMessage -- [ ] check-if-mailbox-exists -- [ ] check-message-signature @@ -89,7 +109,32 @@ mailboxProto adapter mess = do -- [ ] store-message-hash-block-with-ttl -- [ ] if-message-to-this-mailbox-then store-message -- [ ] gossip-message - none + + -- проверяем, что еще не обрабатывали? + -- если обрабатывали -- то дропаем + -- что мы пишем в сторейдж? + -- кто потом это дропает? + + flip runContT pure $ callCC \exit -> do + + -- проверить подпись быстрее, чем читать диск + let unboxed' = unboxSignedBox0 @(MessageContent s) (messageContent msg) + + -- ок, сообщение нормальное, шлём госсип, пишем, что обработали + (_, content) <- ContT $ maybe1 unboxed' none + + let h = hashObject @HbSync (serialise msg) & HashRef + + let routed = serialise (RoutedEntry h) + let routedHash = hashObject routed + + seen <- hasBlock sto routedHash <&> isJust + + unless seen $ lift do + gossip mess + mailboxAcceptMessage adapter msg content + -- TODO: expire-block-and-collect-garbage + void $ putBlock sto routed CheckMailbox{} -> do -- TODO: implement-CheckMailbox diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Entry.hs b/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Entry.hs new file mode 100644 index 00000000..57970e3e --- /dev/null +++ b/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Entry.hs @@ -0,0 +1,19 @@ +module HBS2.Peer.Proto.Mailbox.Entry where + +import HBS2.Prelude +import HBS2.Peer.Proto.Mailbox.Types + +import Data.Word +import Codec.Serialise + +data MailboxEntry = + Existed HashRef | Deleted HashRef + deriving stock (Eq,Ord,Show,Generic) + +data RoutedEntry = RoutedEntry HashRef + deriving stock (Eq,Ord,Show,Generic) + +instance Serialise MailboxEntry +instance Serialise RoutedEntry + +