wip

hbs2-peer/app/PeerInfo.hs

@@ -234,22 +234,17 @@ peerPingLoop (PeerConfig syn) penv = do
 
     forever do
 
-      -- FIXME: defaults
-      r <- liftIO $ race (pause @'Seconds pingTime)
-                         (atomically $ readTQueue wake)
-
-      sas' <- liftIO $ atomically $ STM.flushTQueue wake <&> mconcat
-
-      let sas = case r of
-            Left{}   -> sas'
-            Right sa -> sa <> sas'
-
       debug "peerPingLoop"
 
-      pips <- knownPeers @e pl <&> (<> sas) <&> List.nub
+      let pips = do
+            sas <- liftIO (atomically $ STM.flushTQueue wake <&> mconcat)
+            rest <- knownPeers @e pl
+            pure (fmap (,realToFrac pingTime) (List.nub $ sas <> rest))
 
-      for_ pips $ \p -> do
+      polling (Polling 2.5 2) pips $ \p -> do
-        -- trace $ "SEND PING TO" <+> pretty p
+        liftIO $ withPeerM penv do
-        lift $ sendPing @e p
+          debug $ "SEND PING TO" <+> pretty p
-        -- trace $ "SENT PING TO" <+> pretty p
+          try @_ @IOError (sendPing @e p) >>= \case
+            Left e -> err (viaShow e)
+            Right{} -> none
 

hbs2-peer/app/PeerMain.hs

@@ -252,6 +252,7 @@ runCLI = do
           <*> hsubparser (
                    command "init"      (info pInit (progDesc "creates default config"))
                 <> command "run"       (info pRun  (progDesc "run peer"))
+                <> command "start"     (info pRunStart  (progDesc "run peer"))
                 <> command "poke"      (info pPoke (progDesc "poke peer by rpc"))
                 <> command "die"       (info pDie (progDesc "die cmd"))
                 <> command "announce"  (info pAnnounce (progDesc "announce block"))
@@ -306,7 +307,26 @@ runCLI = do
 
     pPubKeySign = maybeReader (fromStringMay @(PubKey 'Sign 'HBS2Basic))
 
-    pRun = do
+    pRun = pure do
+      self <- getExecutablePath
+      args' <- getArgs
+
+      print (self, args')
+
+      let args = "start" : L.dropWhile (=="run") args'
+
+      flip runContT pure $ fix \next -> do
+
+        pid <- ContT $ withAsync do
+          liftIO (executeFile self False args Nothing)
+
+        void $ waitCatch pid
+
+        liftIO $ putStrLn "hbs2-peer run stopped/terminated; respawning"
+        pause @'Seconds 3
+        next
+
+    pRunStart = do
       runPeer <$> common
 
     pDie = do

hbs2-peer/app/RPC2/Die.hs

@@ -1,6 +1,8 @@
+{-# Language UndecidableInstances #-}
 module RPC2.Die where
 
 import HBS2.Prelude.Plated
+import HBS2.Peer.RPC.Internal.Types
 import HBS2.Clock
 import HBS2.Net.Proto.Service
 
@@ -8,16 +10,16 @@ import HBS2.System.Logger.Simple
 
 import HBS2.Peer.RPC.API.Peer
 
+import Control.Concurrent
 import System.Exit qualified as Exit
-import Control.Concurrent.Async
 
-
+instance (MonadIO m, HasRpcContext PeerAPI RPC2Context m) => HandleMethod m RpcDie where
-instance (MonadIO m) => HandleMethod m RpcDie where
 
   handleMethod _ = do
+    RPC2Context{..} <- getRpcContext @PeerAPI
     debug $ "rpc.die: exiting"
     void $ liftIO $ do
-      pause @'Seconds 0.5 >> Exit.exitSuccess
+      killThread rpcSelf