ping rtt measurement

.fixme/log

@@ -1,2 +1,2 @@
 
-(fixme-set "workflow" "wip" "G6tN6bWuhi")
+(fixme-set "workflow" "test" "FkbL6CVp5Q")

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

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

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
 

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)