From 80f92bf0955179cc0db1119ca06d01b4ff8814b8 Mon Sep 17 00:00:00 2001 From: voidlizard Date: Tue, 8 Oct 2024 06:45:07 +0300 Subject: [PATCH] Mailbox protocol worker boilerplate --- hbs2-peer/app/CLI/Mailbox.hs | 6 -- hbs2-peer/app/MailboxProtoWorker.hs | 71 ++++++++++++++++++++++++ hbs2-peer/app/PeerMain.hs | 6 +- hbs2-peer/hbs2-peer.cabal | 1 + hbs2-peer/lib/HBS2/Peer/Proto/Mailbox.hs | 65 ++++++++++++++++++---- 5 files changed, 132 insertions(+), 17 deletions(-) create mode 100644 hbs2-peer/app/MailboxProtoWorker.hs diff --git a/hbs2-peer/app/CLI/Mailbox.hs b/hbs2-peer/app/CLI/Mailbox.hs index c7398419..c3c01171 100644 --- a/hbs2-peer/app/CLI/Mailbox.hs +++ b/hbs2-peer/app/CLI/Mailbox.hs @@ -69,9 +69,3 @@ runMailboxCLI rpc s = do caller <- ContT $ withMyRPC @MailboxAPI rpc lift $ run (dict caller) cli >>= eatNil display - -- withMyRPC @LWWRefAPI rpc $ \caller -> do - -- callService @RpcLWWRefGet caller ref >>= \case - -- Left e -> err (viaShow e) >> exitFailure - -- Right r -> print $ pretty r - - diff --git a/hbs2-peer/app/MailboxProtoWorker.hs b/hbs2-peer/app/MailboxProtoWorker.hs new file mode 100644 index 00000000..eb6cc000 --- /dev/null +++ b/hbs2-peer/app/MailboxProtoWorker.hs @@ -0,0 +1,71 @@ +{-# Language AllowAmbiguousTypes #-} +module MailboxProtoWorker ( mailboxProtoWorker + , createMailboxProtoWorker + , MailboxProtoWorker + , IsMailboxProtoAdapter + ) where + +import HBS2.Prelude.Plated +import HBS2.Actors.Peer +import HBS2.Data.Types.Refs +import HBS2.Net.Proto +import HBS2.Base58 +import HBS2.Storage +import HBS2.Storage.Operations.Missed +import HBS2.Hash +import HBS2.Peer.Proto +import HBS2.Peer.Proto.Mailbox +import HBS2.Net.Auth.Credentials + +import HBS2.Misc.PrettyStuff + +import Brains +import PeerConfig +import PeerTypes + +import Control.Monad +import UnliftIO +import Lens.Micro.Platform + +{- HLINT ignore "Functor law" -} + +data MailboxProtoWorker e = + MailboxProtoWorker + { + } + +instance IsMailboxProtoAdapter e (MailboxProtoWorker e) + +createMailboxProtoWorker :: forall e m . MonadIO m => m (MailboxProtoWorker e) +createMailboxProtoWorker = do + pure MailboxProtoWorker + +mailboxProtoWorker :: forall e s m . ( MonadIO m + , MonadUnliftIO m + , MyPeer e + , HasStorage m + , Sessions e (KnownPeer e) m + , HasGossip e (MailBoxProto s e) m + , Signatures s + , s ~ Encryption e + , IsRefPubKey s + ) + => MailboxProtoWorker e + -> m () + +mailboxProtoWorker me = do + forever do + pause @'Seconds 10 + debug $ "I'm" <+> yellow "mailboxProtoWorker" + +-- let listRefs = listPolledRefs @e brains (Just "lwwref") +-- <&> fmap (\(a,_,b) -> (a,b)) +-- <&> fmap (over _2 ( (*60) . fromIntegral) ) + +-- polling (Polling 5 5) listRefs $ \ref -> do +-- debug $ yellow "POLLING LWWREF" <+> pretty (AsBase58 ref) +-- gossip (LWWRefProto1 @e (LWWProtoGet (LWWRefKey ref))) + + + + diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index 9498165f..da09bebb 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/hbs2-peer/app/PeerMain.hs @@ -54,6 +54,7 @@ import CheckMetrics import RefLog qualified import RefLog (reflogWorker) import LWWRef (lwwRefWorker) +import MailboxProtoWorker import HttpWorker import DispatchProxy import PeerMeta @@ -1105,6 +1106,9 @@ runPeer opts = Exception.handle (\e -> myException e peerThread "lwwRefWorker" (lwwRefWorker @e conf (SomeBrains brains)) + mbw <- createMailboxProtoWorker @L4Proto + peerThread "mailboxProtoWorker" (mailboxProtoWorker mbw) + liftIO $ withPeerM penv do runProto @e [ makeResponse (blockSizeProto blk (downloadOnBlockSize denv) onNoBlock) @@ -1121,7 +1125,7 @@ runPeer opts = Exception.handle (\e -> myException e , makeResponse (refChanNotifyProto False refChanAdapter) -- TODO: change-all-to-authorized , makeResponse ((authorized . subscribed (SomeBrains brains)) lwwRefProtoA) - , makeResponse (authorized mailboxProto) + , makeResponse ((authorized . mailboxProto) mbw) ] diff --git a/hbs2-peer/hbs2-peer.cabal b/hbs2-peer/hbs2-peer.cabal index 4f8e2451..0f9dad92 100644 --- a/hbs2-peer/hbs2-peer.cabal +++ b/hbs2-peer/hbs2-peer.cabal @@ -279,6 +279,7 @@ executable hbs2-peer , RefChan , RefChanNotifyLog , LWWRef + , MailboxProtoWorker , CheckMetrics , HttpWorker , Brains diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox.hs b/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox.hs index 8ec413fc..be4be504 100644 --- a/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox.hs +++ b/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox.hs @@ -49,6 +49,7 @@ data MailBoxProtoMessage s e = | CheckMailbox (SignedBox (MailboxKey s) s) | MailboxStatus (SignedBox (MailBoxStatusPayload s) s) | SetPolicy (SignedBox (SetPolicyPayload s) s) + | GetPolicy (SignedBox (GetPolicyPayload s) s) | CurrentPolicy (GetPolicyPayload s) | DeleteMessages (SignedBox (DeleteMessagesPayload s) s) deriving stock (Generic) @@ -64,21 +65,65 @@ instance ForMailbox s => Serialise (DeleteMessagesPayload s) instance ForMailbox s => Serialise (MailBoxProtoMessage s e) instance ForMailbox s => Serialise (MailBoxProto s e) -mailboxProto :: forall e m p . ( MonadIO m - , Response e p m - , HasDeferred p e m - , p ~ MailBoxProto (Encryption e) e - ) - => MailBoxProto (Encryption e) e +class IsMailboxProtoAdapter e a where + +mailboxProto :: forall e m p a . ( MonadIO m + , Response e p m + , HasDeferred p e m + , IsMailboxProtoAdapter e a + , p ~ MailBoxProto (Encryption e) e + ) + => a + -> MailBoxProto (Encryption e) e -> m () -mailboxProto mess = do +mailboxProto adapter mess = do -- common stuff case mailBoxProtoPayload mess of - SendMessage{} -> none - _ -> none + SendMessage{} -> do + -- TODO: implement-SendMessage + -- [ ] check-if-mailbox-exists + -- [ ] check-message-signature + -- [ ] if-already-processed-then-skip + -- [ ] store-message-hash-block-with-ttl + -- [ ] if-message-to-this-mailbox-then store-message + -- [ ] gossip-message + none + + CheckMailbox{} -> do + -- TODO: implement-CheckMailbox + -- [ ] check-signed-box-or-drop + -- [ ] if-client-has-mailbox-then + -- [ ] get-mailbox-status + -- [ ] answer-MailboxStatus + -- [ ] gossip-message? + none + + MailboxStatus{} -> do + -- TODO: implement-MailboxStatus + -- + -- [ ] if-do-gossip-setting-then + -- [ ] gossip-MailboxStatus + -- + -- [ ] check-signed-box-or-drop + -- [ ] if-client-has-mailbox-then + -- [ ] get-mailbox-status + -- [ ] answer-MailboxStatus + -- + none + + SetPolicy{} -> do + none + + GetPolicy{} -> do + none + + CurrentPolicy{} -> do + none + + DeleteMessages{} -> do + none - pure ()