From ed47e18d24d419dddabc4ce584e23142e0a11619 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Fri, 14 Apr 2023 09:07:19 +0300 Subject: [PATCH] done oYxxWDF4nX-seems-like-a-bad-idea --- hbs2-core/lib/HBS2/Clock.hs | 6 +-- hbs2-peer/app/PeerInfo.hs | 103 +++++++++--------------------------- hbs2-peer/app/PeerMain.hs | 16 +++--- hbs2-peer/app/PeerTypes.hs | 58 +++++++++++++++++++- hbs2-peer/app/RefLog.hs | 8 +-- 5 files changed, 99 insertions(+), 92 deletions(-) diff --git a/hbs2-core/lib/HBS2/Clock.hs b/hbs2-core/lib/HBS2/Clock.hs index 39b04940..3c124ff5 100644 --- a/hbs2-core/lib/HBS2/Clock.hs +++ b/hbs2-core/lib/HBS2/Clock.hs @@ -75,10 +75,10 @@ class Expires a where -- | Use coarse clock timer. This timer has 1ms resolution but is much -- faster comparing to the ordinary one. Is used on Linux, on MacOS -- provides ordinary one. -getTimeCoarse :: IO TimeSpec +getTimeCoarse :: MonadIO m => m TimeSpec #ifdef linux_HOST_OS -getTimeCoarse = getTime MonotonicCoarse +getTimeCoarse = liftIO $ getTime MonotonicCoarse #else -getTimeCoarse = getTime Monotonic +getTimeCoarse = liftIO $ getTime Monotonic #endif diff --git a/hbs2-peer/app/PeerInfo.hs b/hbs2-peer/app/PeerInfo.hs index 3f40df96..12c1a0b4 100644 --- a/hbs2-peer/app/PeerInfo.hs +++ b/hbs2-peer/app/PeerInfo.hs @@ -4,9 +4,7 @@ module PeerInfo where import HBS2.Actors.Peer import HBS2.Clock -import HBS2.Defaults import HBS2.Events -import HBS2.Net.Messaging.UDP import HBS2.Net.PeerLocator import HBS2.Net.Proto.Peer import HBS2.Net.Proto.PeerExchange @@ -16,13 +14,13 @@ import HBS2.Prelude.Plated import HBS2.System.Logger.Simple import PeerConfig +import PeerTypes import Control.Concurrent.Async import Control.Concurrent.STM import Control.Monad import Control.Monad.Reader import Data.Foldable hiding (find) -import Data.IntSet (IntSet) import Data.List qualified as List import Data.Maybe import Lens.Micro.Platform @@ -36,29 +34,6 @@ data PeerPingIntervalKey instance HasCfgKey PeerPingIntervalKey (Maybe Integer) where key = "ping-interval" -data PeerInfo e = - PeerInfo - { _peerBurst :: TVar Int - , _peerBurstMax :: TVar (Maybe Int) - , _peerBurstSet :: TVar IntSet - , _peerErrors :: TVar Int - , _peerErrorsLast :: TVar Int - , _peerErrorsPerSec :: TVar Int - , _peerLastWatched :: TVar TimeSpec - , _peerDownloaded :: TVar Int - , _peerDownloadedLast :: TVar Int - , _peerPingFailed :: TVar Int - , _peerDownloadedBlk :: TVar Int - , _peerDownloadFail :: TVar Int - , _peerDownloadMiss :: TVar Int - , _peerUsefulness :: TVar Double - , _peerRTTBuffer :: TVar [Integer] -- ^ Contains a list of the last few round-trip time (RTT) values, measured in nanoseconds. - -- Acts like a circular buffer. - , _peerHttpApiAddress :: TVar (Either Int (Maybe String)) - } - deriving stock (Generic,Typeable) - -makeLenses 'PeerInfo -- | Compute the median of a list median :: (Ord a, Integral a) => [a] -> Maybe a @@ -91,37 +66,6 @@ insertRTT x rttList = do else x:init xs ) -newPeerInfo :: MonadIO m => m (PeerInfo e) -newPeerInfo = liftIO do - PeerInfo <$> newTVarIO defBurst - <*> newTVarIO Nothing - <*> newTVarIO mempty - <*> newTVarIO 0 - <*> newTVarIO 0 - <*> newTVarIO 0 - <*> newTVarIO 0 - <*> newTVarIO 0 - <*> newTVarIO 0 - <*> newTVarIO 0 - <*> newTVarIO 0 - <*> newTVarIO 0 - <*> newTVarIO 0 - <*> newTVarIO 0 - <*> newTVarIO [] - <*> newTVarIO (Left 0) - -type instance SessionData e (PeerInfo e) = PeerInfo e - -newtype instance SessionKey e (PeerInfo e) = - PeerInfoKey (Peer e) - -deriving newtype instance Hashable (SessionKey L4Proto (PeerInfo L4Proto)) -deriving stock instance Eq (SessionKey L4Proto (PeerInfo L4Proto)) - --- FIXME: this? -instance Expires (SessionKey L4Proto (PeerInfo L4Proto)) where - expiresIn = const (Just defCookieTimeoutSec) - pexLoop :: forall e m . ( HasPeerLocator e m , HasPeer e , Sessions e (KnownPeer e) m @@ -195,6 +139,8 @@ peerPingLoop cfg = do npi <- newPeerInfo + now <- getTimeCoarse + debug $ "known peers" <+> pretty pee for_ pee $ \p -> do @@ -206,8 +152,11 @@ peerPingLoop cfg = do downMiss <- liftIO $ readTVarIO (view peerDownloadMiss pinfo) down <- liftIO $ readTVarIO (view peerDownloadedBlk pinfo) rtt <- liftIO $ medianPeerRTT pinfo <&> fmap realToFrac + seen <- liftIO $ readTVarIO (view peerLastWatched pinfo) + let l = realToFrac (toNanoSecs $ now - seen) / 1e9 let rttMs = (/1e6) <$> rtt <&> (\x -> showGFloat (Just 2) x "") <&> (<> "ms") + let ls = showGFloat (Just 2) l "" <> "s" notice $ "peer" <+> pretty p <+> "burst:" <+> pretty burst <+> "burst-max:" <+> pretty buM @@ -215,9 +164,27 @@ peerPingLoop cfg = do <+> "down:" <+> pretty down <+> "miss:" <+> pretty downMiss <+> "rtt:" <+> pretty rttMs + <+> "seen" <+> pretty ls pure () + watch <- liftIO $ async $ forever $ withPeerM e $ do + pause @'Seconds 120 + pips <- getKnownPeers @e + now <- getTimeCoarse + for_ pips $ \p -> do + pinfo' <- find (PeerInfoKey p) id + maybe1 pinfo' none $ \pinfo -> do + seen <- liftIO $ readTVarIO (view peerLastWatched pinfo) + -- FIXME: do-something-with-this-nanosec-boilerplate-everywhere + let l = realToFrac (toNanoSecs $ now - seen) / 1e9 + -- FIXME: time-hardcode + when ( l > 300 ) do + delPeers pl [p] + expire (PeerInfoKey p) + expire (KnownPeerKey p) + + liftIO $ link watch forever do @@ -236,27 +203,7 @@ peerPingLoop cfg = do pips <- knownPeers @e pl <&> (<> sas) <&> List.nub for_ pips $ \p -> do - npi <- newPeerInfo - - here <- find @e (KnownPeerKey p) id - - pinfo <- fetch True npi (PeerInfoKey p) id - let pfails = view peerPingFailed pinfo - let pdownfails = view peerDownloadFail pinfo - - -- FIXME: seems-like-a-bad-idea - -- Кажется, вызывает гонки - liftIO $ atomically $ modifyTVar pfails succ - + trace $ "SEND PING TO" <+> pretty p sendPing @e p - fnum <- liftIO $ readTVarIO pfails - fdown <- liftIO $ readTVarIO pdownfails - - when (fnum > 4) do -- FIXME: hardcode! - warn $ "removing peer" <+> pretty p <+> "for not responding to our pings" - delPeers pl [p] - expire (PeerInfoKey p) - expire (KnownPeerKey p) - diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index 276dde41..fcbaa8a9 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/hbs2-peer/app/PeerMain.hs @@ -623,6 +623,12 @@ runPeer opts = Exception.handle myException $ do let thatNonce = view peerOwnNonce d + now <- liftIO getTimeCoarse + pinfo' <- find (PeerInfoKey p) id -- (view peerPingFailed) + maybe1 pinfo' none $ \pinfo -> do + liftIO $ atomically $ writeTVar (view peerPingFailed pinfo) 0 + liftIO $ atomically $ writeTVar (view peerLastWatched pinfo) now + banned <- peerBanned p d let doAddPeer p = do @@ -633,13 +639,7 @@ runPeer opts = Exception.handle myException $ do here <- find @e (KnownPeerKey p) id <&> isJust - pfails <- fetch True npi (PeerInfoKey p) (view peerPingFailed) - liftIO $ atomically $ writeTVar pfails 0 - -- pdownfails <- fetch True npi (PeerInfoKey p) (view peerDownloadFail) - unless here do - -- liftIO $ atomically $ writeTVar pdownfails 0 - debug $ "Got authorized peer!" <+> pretty p <+> pretty (AsBase58 (view peerSignKey d)) @@ -743,9 +743,11 @@ runPeer opts = Exception.handle myException $ do peerThread (blockDownloadLoop denv) + -- FIXME: clumsy-code if useHttpDownload then do - peerThread (updatePeerHttpAddrs) + -- FIXME: discarded-async-value-for-updatePeerHttpAddrs + peerThread updatePeerHttpAddrs peerThread (blockHttpDownloadLoop denv) else pure mempty diff --git a/hbs2-peer/app/PeerTypes.hs b/hbs2-peer/app/PeerTypes.hs index 569ca248..4117f3d3 100644 --- a/hbs2-peer/app/PeerTypes.hs +++ b/hbs2-peer/app/PeerTypes.hs @@ -19,7 +19,7 @@ import HBS2.Storage import HBS2.Net.PeerLocator import HBS2.System.Logger.Simple -import PeerInfo +-- import PeerInfo import Brains import Data.Foldable (for_) @@ -37,6 +37,62 @@ import Lens.Micro.Platform import Data.Hashable import Type.Reflection import Data.IntMap (IntMap) +import Data.IntSet (IntSet) + + +data PeerInfo e = + PeerInfo + { _peerBurst :: TVar Int + , _peerBurstMax :: TVar (Maybe Int) + , _peerBurstSet :: TVar IntSet + , _peerErrors :: TVar Int + , _peerErrorsLast :: TVar Int + , _peerErrorsPerSec :: TVar Int + , _peerLastWatched :: TVar TimeSpec + , _peerDownloaded :: TVar Int + , _peerDownloadedLast :: TVar Int + , _peerPingFailed :: TVar Int + , _peerDownloadedBlk :: TVar Int + , _peerDownloadFail :: TVar Int + , _peerDownloadMiss :: TVar Int + , _peerRTTBuffer :: TVar [Integer] -- ^ Contains a list of the last few round-trip time (RTT) values, measured in nanoseconds. + -- Acts like a circular buffer. + , _peerHttpApiAddress :: TVar (Either Int (Maybe String)) + } + deriving stock (Generic,Typeable) + +makeLenses 'PeerInfo + +newPeerInfo :: MonadIO m => m (PeerInfo e) +newPeerInfo = liftIO do + PeerInfo <$> newTVarIO defBurst + <*> newTVarIO Nothing + <*> newTVarIO mempty + <*> newTVarIO 0 + <*> newTVarIO 0 + <*> newTVarIO 0 + <*> newTVarIO 0 + <*> newTVarIO 0 + <*> newTVarIO 0 + <*> newTVarIO 0 + <*> newTVarIO 0 + <*> newTVarIO 0 + <*> newTVarIO 0 + <*> newTVarIO [] + <*> newTVarIO (Left 0) + +type instance SessionData e (PeerInfo e) = PeerInfo e + +newtype instance SessionKey e (PeerInfo e) = + PeerInfoKey (Peer e) + +deriving newtype instance Hashable (SessionKey L4Proto (PeerInfo L4Proto)) +deriving stock instance Eq (SessionKey L4Proto (PeerInfo L4Proto)) + +-- FIXME: this? +instance Expires (SessionKey L4Proto (PeerInfo L4Proto)) where + expiresIn = const (Just defCookieTimeoutSec) + type MyPeer e = ( Eq (Peer e) diff --git a/hbs2-peer/app/RefLog.hs b/hbs2-peer/app/RefLog.hs index 74e845d6..e9e6d013 100644 --- a/hbs2-peer/app/RefLog.hs +++ b/hbs2-peer/app/RefLog.hs @@ -172,7 +172,8 @@ reflogWorker conf adapter = do reflogDownload adapter h fix \next -> do missed <- missedEntries sto h - if missed /= 0 then do + if not (null missed) then do + for_ missed $ reflogDownload adapter pause @'Seconds 1 trace $ "reflogWorker: missed refs for" <+> pretty h <+> pretty missed next @@ -284,10 +285,11 @@ reflogWorker conf adapter = do pure $ mconcat re missedEntries sto h = do - missed <- liftIO $ newTVarIO 0 + missed <- liftIO $ newTVarIO mempty walkMerkle h (getBlock sto) $ \hr -> do case hr of - Left{} -> atomically $ modifyTVar missed succ + Left ha -> do + atomically $ modifyTVar missed (ha:) Right (_ :: [HashRef]) -> pure () liftIO $ readTVarIO missed