diff --git a/hbs2-core/lib/HBS2/Actors/Peer.hs b/hbs2-core/lib/HBS2/Actors/Peer.hs index 67ebc2fb..594ca754 100644 --- a/hbs2-core/lib/HBS2/Actors/Peer.hs +++ b/hbs2-core/lib/HBS2/Actors/Peer.hs @@ -335,6 +335,11 @@ sweep = do liftIO $ atomically $ modifyTVar' sw (<> HashMap.fromList (mconcat alive)) +addJobIO :: IO () -> PeerM e IO () +addJobIO m = do + PeerEnv{..} <- ask + addJob _envDeferred m + instance ( Typeable (EventKey e p) , Typeable (Event e p) , Hashable (EventKey e p) @@ -507,6 +512,7 @@ runProto hh = do }) -> maybe (pure ()) (runResponseM pip . h) (decoder msg) + instance (Monad m, HasProtocol e p) => HasThatPeer p e (ResponseM e m) where thatPeer = asks (view answTo) diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index 1674e934..f2411624 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/hbs2-peer/app/PeerMain.hs @@ -1338,7 +1338,7 @@ runPeer opts = respawnOnError opts $ do , rpcMailboxAdapter = AnyMailboxAdapter @s mailboxWorker } - m1 <- async $ runMessagingUnix rpcmsg + m1 <- asyncLinked $ runMessagingUnix rpcmsg rpcProto <- async $ flip runReaderT rpcctx do env <- newNotifyEnvServer @(RefChanEvents L4Proto) refChanNotifySource diff --git a/hbs2-peer/app/RPC2.hs b/hbs2-peer/app/RPC2.hs index ff904cc6..faa42b07 100644 --- a/hbs2-peer/app/RPC2.hs +++ b/hbs2-peer/app/RPC2.hs @@ -219,6 +219,14 @@ instance (e ~ L4Proto, MonadUnliftIO m, HasRpcContext PeerAPI RPC2Context m) => pure nil + entry $ bindMatch "test:explode" $ const do + + liftIO $ withPeerM rpcPeerEnv do + forever do + addJobIO $ forever none + + pure $ mkSym "text:explode" + entry $ bindMatch "reset" $ const do throwTo rpcSelf GoAgainException pure $ mkSym "reset" diff --git a/hbs2-peer/app/Watchdogs.hs b/hbs2-peer/app/Watchdogs.hs index 7dbcf3c0..1b8bf36e 100644 --- a/hbs2-peer/app/Watchdogs.hs +++ b/hbs2-peer/app/Watchdogs.hs @@ -20,6 +20,9 @@ runRpcWatchDog :: MonadIO m => ThreadId -> FilePath -> m () runRpcWatchDog peer soname = do liftIO $ flip runContT pure do + ContT $ bracket none $ const $ do + err "bracket in runRpcWatchDog" + api <- ContT $ withRPC2 @PeerAPI soname flip fix WIdle $ \next -> \case @@ -30,7 +33,6 @@ runRpcWatchDog peer soname = do WCall n | n > 2 -> do err $ red "RpcWatchDog fired" - throwTo peer GoAgainException WCall n -> do debug $ "RpcWatchDog" <+> pretty n @@ -38,6 +40,5 @@ runRpcWatchDog peer soname = do Just _ -> next WIdle Nothing -> next (WCall (succ n)) - throwTo peer GoAgainException diff --git a/hbs2-peer/hbs2-peer.cabal b/hbs2-peer/hbs2-peer.cabal index 04b6948e..0798ec8e 100644 --- a/hbs2-peer/hbs2-peer.cabal +++ b/hbs2-peer/hbs2-peer.cabal @@ -85,6 +85,7 @@ common shared-properties -Wall -O2 -fno-warn-type-defaults + -fno-omit-yields -- -fno-warn-unused-matches -- -fno-warn-unused-do-bind -- -Werror=missing-methods