From fd7b0e31d5264468e1b88066a6148d82377b4225 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Sun, 2 Apr 2023 12:57:52 +0300 Subject: [PATCH] ping rtt measurement --- .fixme/log | 2 +- hbs2-core/lib/HBS2/Net/Proto/Peer.hs | 33 +++++++++++++++++++++++----- hbs2-peer/app/BlockDownload.hs | 7 ++++-- hbs2-peer/app/PeerInfo.hs | 2 ++ hbs2-peer/app/PeerMain.hs | 10 ++++++++- 5 files changed, 45 insertions(+), 9 deletions(-) diff --git a/.fixme/log b/.fixme/log index 3cd008b4..ff423723 100644 --- a/.fixme/log +++ b/.fixme/log @@ -1,2 +1,2 @@ -(fixme-set "workflow" "wip" "G6tN6bWuhi") \ No newline at end of file +(fixme-set "workflow" "test" "FkbL6CVp5Q") \ No newline at end of file diff --git a/hbs2-core/lib/HBS2/Net/Proto/Peer.hs b/hbs2-core/lib/HBS2/Net/Proto/Peer.hs index df825f65..424fa973 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/Peer.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/Peer.hs @@ -44,13 +44,22 @@ newtype instance SessionKey e (KnownPeer e) = KnownPeerKey (Peer e) deriving stock (Generic,Typeable) +data PeerPingData e = + PeerPingData + { _peerPingNonce :: PingNonce + , _peerPingSent :: TimeSpec + } + deriving stock (Generic,Typeable) + +makeLenses 'PeerPingData + type instance SessionData e (KnownPeer e) = PeerData e newtype instance SessionKey e (PeerHandshake e) = PeerHandshakeKey (PingNonce, Peer e) deriving stock (Generic, Typeable) -type instance SessionData e (PeerHandshake e) = PingNonce +type instance SessionData e (PeerHandshake e) = PeerPingData e -- FIXME: enormous-request-amount-during-handshake-2 @@ -71,9 +80,17 @@ sendPing :: forall e m . ( MonadIO m sendPing pip = do nonce <- newNonce @(PeerHandshake e) - update nonce (PeerHandshakeKey (nonce,pip)) id + tt <- liftIO $ getTimeCoarse + let pdd = PeerPingData nonce tt + update pdd (PeerHandshakeKey (nonce,pip)) id request pip (PeerPing @e nonce) +newtype PeerHandshakeAdapter e m = + PeerHandshakeAdapter + { onPeerRTT :: (Peer e, Integer) -> m () + } + + peerHandShakeProto :: forall e m . ( MonadIO m , Response e (PeerHandshake e) m , Request e (PeerHandshake e) m @@ -88,9 +105,10 @@ peerHandShakeProto :: forall e m . ( MonadIO m , EventEmitter e (PeerHandshake e) m , EventEmitter e (ConcretePeer e) m ) - => PeerHandshake e -> m () + => PeerHandshakeAdapter e m + -> PeerHandshake e -> m () -peerHandShakeProto = +peerHandShakeProto adapter = \case PeerPing nonce -> do pip <- thatPeer proto @@ -117,7 +135,7 @@ peerHandShakeProto = se' <- find @e (PeerHandshakeKey (nonce0,pip)) id - maybe1 se' (pure ()) $ \nonce -> do + maybe1 se' (pure ()) $ \(PeerPingData nonce t0) -> do let pk = view peerSignKey d @@ -125,6 +143,11 @@ peerHandShakeProto = when signed $ do + now <- liftIO getTimeCoarse + let rtt = toNanoSecs $ now - t0 + + onPeerRTT adapter (pip,rtt) + expire (PeerHandshakeKey (nonce0,pip)) -- FIXME: check if peer is blacklisted diff --git a/hbs2-peer/app/BlockDownload.hs b/hbs2-peer/app/BlockDownload.hs index d0923d71..2e3a0ff3 100644 --- a/hbs2-peer/app/BlockDownload.hs +++ b/hbs2-peer/app/BlockDownload.hs @@ -490,12 +490,15 @@ blockDownloadLoop env0 = do errors <- liftIO $ readTVarIO (view peerErrorsPerSec pinfo) downFails <- liftIO $ readTVarIO (view peerDownloadFail pinfo) down <- liftIO $ readTVarIO (view peerDownloadedBlk pinfo) - useful <- liftIO $ readTVarIO (view peerUsefulness pinfo) + rtt <- liftIO $ readTVarIO (view peerRTT pinfo) <&> fmap realToFrac + + let rttMs = (/1e6) <$> rtt <&> floor + notice $ "peer" <+> pretty p <+> "burst:" <+> pretty burst <+> "burst-max:" <+> pretty buM <+> "errors:" <+> pretty (downFails + errors) <+> "down:" <+> pretty down - <+> "useful:" <+> pretty useful + <+> "rtt:" <+> pretty rttMs <> "ms" pure () void $ liftIO $ async $ forever $ withPeerM e $ withDownload env0 do diff --git a/hbs2-peer/app/PeerInfo.hs b/hbs2-peer/app/PeerInfo.hs index ce05f2ba..c1c53f74 100644 --- a/hbs2-peer/app/PeerInfo.hs +++ b/hbs2-peer/app/PeerInfo.hs @@ -52,6 +52,7 @@ data PeerInfo e = , _peerDownloadedBlk :: TVar Int , _peerDownloadFail :: TVar Int , _peerUsefulness :: TVar Double + , _peerRTT :: TVar (Maybe Integer) -- ^ nanosec } deriving stock (Generic,Typeable) @@ -73,6 +74,7 @@ newPeerInfo = liftIO do <*> newTVarIO 0 <*> newTVarIO 0 <*> newTVarIO 0 + <*> newTVarIO Nothing type instance SessionData e (PeerInfo e) = PeerInfo e diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index 6c576d6f..fa9c187a 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/hbs2-peer/app/PeerMain.hs @@ -544,6 +544,7 @@ runPeer opts = Exception.handle myException $ do reflogAdapter <- RefLog.mkAdapter reflogReqAdapter <- RefLog.mkRefLogRequestAdapter @e + let doDownload h = do withPeerM penv $ withDownload denv (addDownload mzero h) @@ -557,6 +558,13 @@ runPeer opts = Exception.handle myException $ do , RefLog.reflogFetch = doFetchRef } + let doUpdateRtt (p,rttNew) = withPeerM penv $ void $ runMaybeT do + def <- newPeerInfo + tv <- lift $ fetch True def (PeerInfoKey p) (view peerRTT) + void $ liftIO $ atomically $ writeTVar tv (Just rttNew) + + let hshakeAdapter = PeerHandshakeAdapter doUpdateRtt + env <- ask pnonce <- peerNonce @e @@ -758,7 +766,7 @@ runPeer opts = Exception.handle myException $ do [ makeResponse (blockSizeProto blk dontHandle onNoBlock) , makeResponse (blockChunksProto adapter) , makeResponse blockAnnounceProto - , makeResponse (withCredentials pc . peerHandShakeProto) + , makeResponse (withCredentials pc . peerHandShakeProto hshakeAdapter) , makeResponse peerExchangeProto , makeResponse (refLogUpdateProto reflogAdapter) , makeResponse (refLogRequestProto reflogReqAdapter)