wip

hbs2-core/lib/HBS2/Net/Messaging/Encrypted/ByPass.hs

@@ -7,6 +7,7 @@ module HBS2.Net.Messaging.Encrypted.ByPass
   , ByPassStat(..)
   , byPassDef
   , newByPassMessaging
+  , byPassMessagingSetProbe
   , cleanupByPassMessaging
   , getStat
   ) where
@@ -120,6 +121,7 @@ data ByPass e them =
   , recvNum      :: TVar Int
   , authFail     :: TVar Int
   , maxPkt       :: TVar Int
+  , probe        :: TVar AnyProbe
   }
 
 type ForByPass e   = ( Hashable (Peer e)
@@ -207,6 +209,13 @@ byPassDef =
   , byPassTimeRange  = Nothing
   }
 
+byPassMessagingSetProbe :: forall e w m . ( ForByPass e, MonadIO m, Messaging w e ByteString)
+                        => ByPass e w
+                        -> AnyProbe
+                        -> m ()
+
+byPassMessagingSetProbe ByPass{..} p = atomically $ writeTVar probe p
+
 newByPassMessaging :: forall e w m . ( ForByPass e
                                      , MonadIO m
                                      , Messaging w e ByteString
@@ -233,6 +242,7 @@ newByPassMessaging o w self ps sk  = do
                                  <*> newTVarIO 0
                                  <*> newTVarIO 0
                                  <*> newTVarIO 0
+                                 <*> newTVarIO (AnyProbe ())
 
 instance (ForByPass e, Messaging w e ByteString)
   => Messaging (ByPass e w) e ByteString where

hbs2-peer/app/MailboxProtoWorker.hs

@@ -5,6 +5,7 @@
 {-# Language PatternSynonyms #-}
 module MailboxProtoWorker ( mailboxProtoWorker
                           , createMailboxProtoWorker
+                          , mailboxProtoWorkerSetProbe
                           , MailboxProtoWorker
                           , IsMailboxProtoAdapter
                           , MailboxProtoException(..)
@@ -137,6 +138,7 @@ data MailboxProtoWorker (s :: CryptoScheme) e =
   , inMessageQueueDropped :: TVar Int
   , inMessageDeclined     :: TVar Int
   , mailboxDB             :: TVar (Maybe DBPipeEnv)
+  , probe                 :: TVar AnyProbe
   }
 
 okay :: Monad m => good -> m (Either bad good)
@@ -533,6 +535,17 @@ getMailboxType_ d r = do
      <&> fmap (fromStringMay @MailboxType  . fromOnly)
      <&> headMay . catMaybes
 
+mailboxProtoWorkerSetProbe :: forall s e m . ( MonadIO m
+                                           , s ~ Encryption e
+                                           , ForMailbox s
+                                           )
+                           => MailboxProtoWorker s e
+                           -> AnyProbe
+                           -> m ()
+mailboxProtoWorkerSetProbe MailboxProtoWorker{..} p
+  = atomically  $ writeTVar probe p
+
+
 createMailboxProtoWorker :: forall s e m . ( MonadIO m
                                            , s ~ Encryption e
                                            , ForMailbox s
@@ -556,6 +569,7 @@ createMailboxProtoWorker pc pe de sto = do
     <*> newTVarIO 0
     <*> newTVarIO 0
     <*> newTVarIO Nothing
+    <*> newTVarIO (AnyProbe ())
 
 mailboxProtoWorker :: forall e s m . ( MonadIO m
                                      , MonadUnliftIO m
@@ -600,6 +614,20 @@ mailboxProtoWorker readConf me@MailboxProtoWorker{..} = do
 
       forever do
         pause @'Seconds 10
+
+        pro <- readTVarIO probe
+
+        values <- atomically do
+          mpwFetchQSize <- readTVar mpwFetchQ <&> HS.size
+          inMessageMergeQueueSize <- readTVar inMessageMergeQueue <&> HM.size
+          inPolicyDownloadQSize <- readTVar inPolicyDownloadQ <&> HM.size
+          inMailboxDownloadQSize <- readTVar inMailboxDownloadQ <&> HM.size
+          pure $ [ ("mpwFetchQ", fromIntegral mpwFetchQSize)
+                 , ("inMessageMergeQueue", fromIntegral inMessageMergeQueueSize)
+                 , ("inPolicyDownloadQ", fromIntegral inPolicyDownloadQSize)
+                 , ("inMailboxDownloadQ", fromIntegral inMailboxDownloadQSize)
+                 ]
+        acceptReport pro values
         debug $ "I'm" <+> yellow "mailboxProtoWorker"
 
     void $ waitAnyCancel [bs,dpipe,inq,mergeQ,pDownQ,sDownQ,mCheckQ,mFetchQ]

hbs2-peer/app/PeerMain.hs

@@ -932,6 +932,10 @@ runPeer opts = Exception.handle (\e -> myException e
 
   mailboxWorker <- createMailboxProtoWorker pc  penv denv (AnyStorage s)
 
+  p <- newSimpleProbe "MailboxProtoWorker"
+  mailboxProtoWorkerSetProbe mailboxWorker p
+  addProbe p
+
   let onNoBlock (p, h) = do
         already <- liftIO $ Cache.lookup nbcache (p,h) <&> isJust
         unless already do

hbs2-peer/hbs2-peer.cabal

@@ -92,8 +92,8 @@ common shared-properties
         -- -fno-warn-unused-binds
         -threaded
         -rtsopts
-        "-with-rtsopts=-N -A64m -AL256m -I0 -T"
-
+        -- "-with-rtsopts=-N -A64m -AL256m -I0 -T"
+        "-with-rtsopts=-N -A4m -AL16m -I0 -T"
 
   default-language:    Haskell2010