From 98c1be5999a3f1e90dba8ae9e869ed1aacaa9f4d Mon Sep 17 00:00:00 2001
From: voidlizard <dzuikov@gmail.com>
Date: Sun, 9 Feb 2025 05:52:44 +0300
Subject: [PATCH] hbs2-peer, simple rpc watchdog

---
 hbs2-peer/app/Watchdogs.hs | 43 ++++++++++++++++++++++++++++++++++++++
 1 file changed, 43 insertions(+)
 create mode 100644 hbs2-peer/app/Watchdogs.hs

diff --git a/hbs2-peer/app/Watchdogs.hs b/hbs2-peer/app/Watchdogs.hs
new file mode 100644
index 00000000..7dbcf3c0
--- /dev/null
+++ b/hbs2-peer/app/Watchdogs.hs
@@ -0,0 +1,43 @@
+module Watchdogs (runRpcWatchDog) where
+
+import HBS2.Prelude
+import HBS2.Misc.PrettyStuff
+import HBS2.Peer.RPC.API.Peer
+import HBS2.Peer.RPC.Client.Unix
+
+import PeerTypes
+
+import Control.Concurrent (ThreadId)
+import Control.Monad.Trans.Cont
+
+import UnliftIO
+
+
+data WState =
+  WIdle | WCall Int
+
+runRpcWatchDog :: MonadIO m => ThreadId -> FilePath -> m ()
+runRpcWatchDog peer soname = do
+    liftIO $ flip runContT pure do
+
+      api <- ContT $ withRPC2 @PeerAPI soname
+
+      flip fix WIdle $ \next -> \case
+
+        WIdle -> do
+          pause @'Seconds 10
+          next (WCall 0)
+
+        WCall n | n > 2 -> do
+          err $ red "RpcWatchDog fired"
+          throwTo peer GoAgainException
+
+        WCall n -> do
+          debug $ "RpcWatchDog" <+> pretty n
+          liftIO (callRpcWaitMay @RpcPoke (TimeoutSec 2) api ()) >>= \case
+            Just _ -> next WIdle
+            Nothing -> next (WCall (succ n))
+
+    throwTo peer GoAgainException
+
+