Mailbox protocol worker boilerplate

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
-
-

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)))
+
+
+
+

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)
                     ]
 
 

hbs2-peer/hbs2-peer.cabal

@@ -279,6 +279,7 @@ executable hbs2-peer
                     , RefChan
                     , RefChanNotifyLog
                     , LWWRef
+                    , MailboxProtoWorker
                     , CheckMetrics
                     , HttpWorker
                     , Brains

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
+class IsMailboxProtoAdapter e a where
-                               , Response e p m
+
-                               , HasDeferred p e m
+mailboxProto :: forall e m p a . ( MonadIO m
-                               , p ~ MailBoxProto (Encryption e) e
+                                 , Response e p m
-                               )
+                                 , HasDeferred p e m
-             => MailBoxProto (Encryption e) e
+                                 , 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
+    SendMessage{} -> do
-    _ -> none
+      -- 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 ()