done oYxxWDF4nX-seems-like-a-bad-idea

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
 

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
+      trace $ "SEND PING TO" <+> pretty p
-
-      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
-
       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)
-
 

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
 

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)

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