voidlizard
/
hbs2
mirror of https://github.com/voidlizard/hbs2
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

wip

This commit is contained in:
voidlizard 2024-10-10 13:20:15 +03:00
parent cc0ad4e24a
commit 549a64a6c0
1 changed files with 9 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
hbs2-peer/app/MailboxProtoWorker.hs
View File

@ -32,6 +32,7 @@ import PeerTypes
import DBPipe.SQLite import DBPipe.SQLite
import Control.Monad.Trans.Cont import Control.Monad.Trans.Cont
import Control.Monad.Trans.Maybe
import Data.Maybe import Data.Maybe
import UnliftIO import UnliftIO
import Control.Concurrent.STM qualified as STM import Control.Concurrent.STM qualified as STM
@ -160,15 +161,13 @@ mailboxProtoWorker readConf me@MailboxProtoWorker{..} = do
inq <- ContT $ withAsync (mailboxInQ dbe) inq <- ContT $ withAsync (mailboxInQ dbe)
sendq <- ContT $ withAsync $ mailboxSendQ
bs <- ContT $ withAsync do bs <- ContT $ withAsync do
forever do forever do
pause @'Seconds 10 pause @'Seconds 10
debug $ "I'm" <+> yellow "mailboxProtoWorker" debug $ "I'm" <+> yellow "mailboxProtoWorker"
void $ waitAnyCancel [bs,pipe,inq,sendq] void $ waitAnyCancel [bs,pipe,inq]
`catch` \( e :: MailboxProtoException ) -> do `catch` \( e :: MailboxProtoException ) -> do
err $ red "mailbox protocol worker terminated" <+> viaShow e err $ red "mailbox protocol worker terminated" <+> viaShow e
@ -178,11 +177,6 @@ mailboxProtoWorker readConf me@MailboxProtoWorker{..} = do
where where
mailboxSendQ = do
forever do
pause @'Seconds 10
debug $ yellow "send mail loop"
mailboxInQ dbe = do mailboxInQ dbe = do
forever do forever do
pause @'Seconds 10 pause @'Seconds 10
@ -198,8 +192,14 @@ mailboxProtoWorker readConf me@MailboxProtoWorker{..} = do
-- TODO: process-with-policy -- TODO: process-with-policy
for_ (messageRecipients s) $ \rcpt -> do for_ (messageRecipients s) $ \rcpt -> void $ runMaybeT do
mbox <- getMailboxType_ @s dbe rcpt mbox <- getMailboxType_ @s dbe rcpt
>>= toMPlus
case mbox of
MailboxHub -> debug $ blue "HUB" <+> pretty (AsBase58 rcpt) <+> "WRITE MESSAGE"
MailboxRelay -> debug $ blue "RELAY"<+> pretty (AsBase58 rcpt) <+> "WRITE MESSAGE"
pure () pure ()
mailboxStateEvolve :: forall e s m . ( MonadIO m mailboxStateEvolve :: forall e s m . ( MonadIO m