From cfd5a5bdbd7305c1815445e89273b29a05287ee6 Mon Sep 17 00:00:00 2001
From: Dmitry Zuikov <dzuikov@gmail.com>
Date: Tue, 4 Apr 2023 06:43:22 +0300
Subject: [PATCH] merged PR 5dkZ3UqkiT hbs2-peer-median-rtt

---
 docs/devlog.md                 |  9 +++++++++
 hbs2-peer/app/BlockDownload.hs |  2 +-
 hbs2-peer/app/PeerInfo.hs      | 35 ++++++++++++++++++++++++++++++++--
 hbs2-peer/app/PeerMain.hs      | 18 ++++++++---------
 4 files changed, 52 insertions(+), 12 deletions(-)

diff --git a/docs/devlog.md b/docs/devlog.md
index a9bb12a6..d92b99f8 100644
--- a/docs/devlog.md
+++ b/docs/devlog.md
@@ -1,3 +1,12 @@
+## 2023-04-03
+
+TODO: hbs2-peer-meidan-rtt
+  вычислять и выводить медианный rtt вместо последнего
+
+PR: hbs2-peer-meidan-rtt
+  branch: calculate-median-rtt
+  commit: a9874a5727c3c16eb37e01b39832a4dfd3418c9c
+  Вычисление и отображение медианного RTT вместо последнего.
 
 ## 2023-04-01
 
diff --git a/hbs2-peer/app/BlockDownload.hs b/hbs2-peer/app/BlockDownload.hs
index 186aa646..08d9e266 100644
--- a/hbs2-peer/app/BlockDownload.hs
+++ b/hbs2-peer/app/BlockDownload.hs
@@ -491,7 +491,7 @@ blockDownloadLoop env0 = do
       errors <- liftIO $ readTVarIO (view peerErrorsPerSec pinfo)
       downFails <- liftIO $ readTVarIO (view peerDownloadFail pinfo)
       down      <- liftIO $ readTVarIO (view peerDownloadedBlk pinfo)
-      rtt       <- liftIO $ readTVarIO (view peerRTT pinfo) <&> fmap realToFrac
+      rtt       <- liftIO $ medianPeerRTT pinfo <&> fmap realToFrac
 
       let rttMs = (/1e6) <$> rtt <&> (\x -> showGFloat (Just 2) x "") <&> (<> "ms")
 
diff --git a/hbs2-peer/app/PeerInfo.hs b/hbs2-peer/app/PeerInfo.hs
index c1c53f74..caeff75a 100644
--- a/hbs2-peer/app/PeerInfo.hs
+++ b/hbs2-peer/app/PeerInfo.hs
@@ -52,12 +52,43 @@ data PeerInfo e =
   , _peerDownloadedBlk  :: TVar Int
   , _peerDownloadFail   :: TVar Int
   , _peerUsefulness     :: TVar Double
-  , _peerRTT            :: TVar (Maybe Integer) -- ^ nanosec
+  , _peerRTTBuffer      :: TVar [Integer] -- ^ Contains a list of the last few round-trip time (RTT) values, measured in nanoseconds.
+                                          -- Acts like a circular buffer.
   }
   deriving stock (Generic,Typeable)
 
 makeLenses 'PeerInfo
 
+-- | Compute the median of a list
+median :: (Ord a, Integral a) => [a] -> Maybe a
+median [] = Nothing
+median xs = Just
+  if odd n
+    then sorted !! half
+    else ((sorted !! (half - 1)) + (sorted !! half)) `div` 2
+  where n = length xs
+        sorted = List.sort xs
+        half = n `div` 2
+
+-- | Get the median RTT for a given peer.
+medianPeerRTT :: MonadIO m => PeerInfo e -> m (Maybe Integer)
+medianPeerRTT pinfo = do
+  rttBuffer <- liftIO $ readTVarIO (view peerRTTBuffer pinfo)
+  pure $ median rttBuffer
+
+rttBufferCapacity :: Int
+rttBufferCapacity = 10
+
+-- | New values are added to the head of the list, old values are discarded when the list is full.
+insertRTT :: MonadIO m => Integer -> TVar [Integer] -> m ()
+insertRTT x rttList = do
+  liftIO $ atomically $ modifyTVar rttList (\xs ->
+    if rttBufferCapacity < 1
+      then xs
+      else if length xs < rttBufferCapacity
+        then x:xs
+        else x:init xs
+    )
 
 newPeerInfo :: MonadIO m => m (PeerInfo e)
 newPeerInfo = liftIO do
@@ -74,7 +105,7 @@ newPeerInfo = liftIO do
            <*> newTVarIO 0
            <*> newTVarIO 0
            <*> newTVarIO 0
-           <*> newTVarIO Nothing
+           <*> newTVarIO []
 
 type instance SessionData e (PeerInfo e) = PeerInfo e
 
diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs
index c2d8e1e9..632c31e2 100644
--- a/hbs2-peer/app/PeerMain.hs
+++ b/hbs2-peer/app/PeerMain.hs
@@ -558,12 +558,11 @@ runPeer opts = Exception.handle myException $ do
                    , RefLog.reflogFetch = doFetchRef
                    }
 
-              let doUpdateRtt (p,rttNew) = withPeerM penv $ void $ runMaybeT do
+              let addNewRtt (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
+                    tv <- lift $ fetch True def (PeerInfoKey p) (view peerRTTBuffer)
+                    insertRTT rttNew tv 
+              let hshakeAdapter = PeerHandshakeAdapter addNewRtt
 
               env <- ask
 
@@ -639,11 +638,12 @@ runPeer opts = Exception.handle myException $ do
                         debug "Same peer, different address"
 
                         void $ runMaybeT do
-                          tv0 <- MaybeT $ find (PeerInfoKey p0) (view peerRTT)
-                          tv1 <- MaybeT $ find (PeerInfoKey p) (view peerRTT)
+                          
+                          pinfo0 <- MaybeT $ find (PeerInfoKey p0) id
+                          pinfo1 <- MaybeT $ find (PeerInfoKey p) id
 
-                          rtt0 <- MaybeT $ liftIO $ readTVarIO tv0
-                          rtt1 <- MaybeT $ liftIO $ readTVarIO tv1
+                          rtt0 <- MaybeT $ medianPeerRTT pinfo0
+                          rtt1 <- MaybeT $ medianPeerRTT pinfo1
 
                           when ( rtt1 < rtt0 ) do
                             debug $ "Better rtt!" <+> pretty p0