diff --git a/hbs2-core/lib/HBS2/Net/Proto/Service.hs b/hbs2-core/lib/HBS2/Net/Proto/Service.hs index 0e4a7f34..756dc93e 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/Service.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/Service.hs @@ -293,6 +293,31 @@ callRpcWaitMay t caller args = do -- _ | i < 1 -> next (succ i) _ -> pure Nothing + + +callRpcWaitRetry :: forall method (api :: [Type]) m e proto t . ( MonadUnliftIO m + , KnownNat (FromJust (FindMethodIndex 0 method api)) + , HasProtocol e (ServiceProto api e) + , Serialise (Input method) + , Serialise (Output method) + , IsTimeout t + , proto ~ ServiceProto api e + ) + => Timeout t + -> Int + -> ServiceCaller api e + -> Input method + -> m (Maybe (Output method)) + +callRpcWaitRetry t attempts caller args = do + flip fix 0 $ \next i -> do + race (pause t) (callService @method @api @e @m caller args) + >>= \case + Right (Right x) -> pure (Just x) + _ | i < attempts -> next (succ i) + _ -> pure Nothing + + makeClient :: forall api e m . ( MonadIO m , HasProtocol e (ServiceProto api e) , Pretty (Peer e) diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index 6e7d6ad3..5e7839ed 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/hbs2-peer/app/PeerMain.hs @@ -606,7 +606,7 @@ runCLI = do withMyRPC @PeerAPI rpc $ \caller -> do void $ runMaybeT do - p <- callService @RpcGetProbes caller () + p <- lift (callRpcWaitRetry @RpcGetProbes (TimeoutSec 1) 3 caller ()) >>= toMPlus liftIO $ print $ vcat (fmap pretty p)