diff --git a/hbs2-peer/app/PeerInfo.hs b/hbs2-peer/app/PeerInfo.hs index a31cb94e..0434c076 100644 --- a/hbs2-peer/app/PeerInfo.hs +++ b/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 - -- trace $ "SEND PING TO" <+> pretty p - lift $ sendPing @e p - -- trace $ "SENT PING TO" <+> pretty p + polling (Polling 2.5 2) pips $ \p -> do + liftIO $ withPeerM penv do + debug $ "SEND PING TO" <+> pretty p + try @_ @IOError (sendPing @e p) >>= \case + Left e -> err (viaShow e) + Right{} -> none diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index 6bded06a..fc94a230 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/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 diff --git a/hbs2-peer/app/RPC2/Die.hs b/hbs2-peer/app/RPC2/Die.hs index 34f3263e..f091820b 100644 --- a/hbs2-peer/app/RPC2/Die.hs +++ b/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) => HandleMethod m RpcDie where +instance (MonadIO m, HasRpcContext PeerAPI RPC2Context 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