wip, mailbox SendMessage skeleton

hbs2-peer/app/MailboxProtoWorker.hs

@@ -25,24 +25,36 @@ import PeerTypes
 
 import Control.Monad
 import UnliftIO
+-- import Control.Concurrent.STM.TBQueue
 import Lens.Micro.Platform
 
 {- HLINT ignore "Functor law" -}
 
-data MailboxProtoWorker e =
+data MailboxProtoWorker (s :: CryptoScheme) e =
   MailboxProtoWorker
-  {
+  { mpwStorage            :: AnyStorage
+  , inMessageQueue        :: TBQueue (Message s, MessageContent s)
+  , inMessageQueueDropped :: TVar Int
   }
 
-instance IsMailboxProtoAdapter 'HBS2Basic (MailboxProtoWorker e) where
+instance (s ~ HBS2Basic) => IsMailboxProtoAdapter s (MailboxProtoWorker s e) where
-  mailboxGetStorage = const $ error "OOPSIE"
+  mailboxGetStorage = pure . mpwStorage
 
-  mailboxAcceptMessage _ _ _ = do
+  mailboxAcceptMessage MailboxProtoWorker{..} m c = do
-    error "DOOPSIE"
+    atomically do
+      full <- isFullTBQueue inMessageQueue
+      if full then do
+        modifyTVar inMessageQueueDropped succ
+      else do
+        writeTBQueue inMessageQueue (m,c)
 
-createMailboxProtoWorker :: forall e m . MonadIO m => m (MailboxProtoWorker e)
+createMailboxProtoWorker :: forall e m . MonadIO m => AnyStorage -> m (MailboxProtoWorker (Encryption e) e)
-createMailboxProtoWorker = do
+createMailboxProtoWorker sto = do
-  pure MailboxProtoWorker
+  -- FIXME: queue-size-hardcode
+  --   $class: hardcode
+  inQ        <- newTBQueueIO 1000
+  inDroppped <- newTVarIO 0
+  pure $ MailboxProtoWorker sto inQ inDroppped
 
 mailboxProtoWorker :: forall e s m . ( MonadIO m
                                      , MonadUnliftIO m
@@ -54,7 +66,7 @@ mailboxProtoWorker :: forall e s m . ( MonadIO m
                                      , s ~ Encryption e
                                      , IsRefPubKey s
                                      )
-             => MailboxProtoWorker e
+             => MailboxProtoWorker s e
              -> m ()
 
 mailboxProtoWorker me = do
@@ -71,5 +83,3 @@ mailboxProtoWorker me = do
 --     gossip (LWWRefProto1 @e (LWWProtoGet (LWWRefKey ref)))
 
 
-
-

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 @e
+                mbw <- createMailboxProtoWorker @e (AnyStorage s)
                 peerThread "mailboxProtoWorker" (mailboxProtoWorker mbw)
 
                 liftIO $ withPeerM penv do

hbs2-peer/lib/HBS2/Peer/Proto/Mailbox.hs

@@ -134,6 +134,7 @@ mailboxProto adapter mess = do
           gossip mess
           mailboxAcceptMessage adapter msg content
           -- TODO: expire-block-and-collect-garbage
+          --   $class: leak
           void $ putBlock sto routed
 
     CheckMailbox{} -> do