mirror of https://github.com/voidlizard/hbs2
95 lines
2.6 KiB
Haskell
95 lines
2.6 KiB
Haskell
{-# Language TemplateHaskell #-}
|
|
{-# Language AllowAmbiguousTypes #-}
|
|
module PeerInfo where
|
|
|
|
import HBS2.Actors.Peer
|
|
import HBS2.Clock
|
|
import HBS2.Defaults
|
|
import HBS2.Net.Messaging.UDP
|
|
import HBS2.Net.PeerLocator
|
|
import HBS2.Net.Proto.Peer
|
|
import HBS2.Net.Proto.Sessions
|
|
import HBS2.Net.Proto.Types
|
|
import HBS2.Prelude.Plated
|
|
import HBS2.System.Logger.Simple
|
|
|
|
import Data.Foldable
|
|
import Lens.Micro.Platform
|
|
import Control.Concurrent.STM.TVar
|
|
import Control.Concurrent.STM
|
|
import Control.Monad
|
|
import Prettyprinter
|
|
|
|
data PeerInfo e =
|
|
PeerInfo
|
|
{ _peerBurst :: TVar Int
|
|
, _peerErrors :: TVar Int
|
|
, _peerErrorsLast :: TVar Int
|
|
, _peerErrorsPerSec :: TVar Int
|
|
, _peerLastWatched :: TVar TimeSpec
|
|
, _peerDownloaded :: TVar Int
|
|
, _peerDownloadedLast :: TVar Int
|
|
, _peerPingFailed :: TVar Int
|
|
}
|
|
deriving stock (Generic,Typeable)
|
|
|
|
makeLenses 'PeerInfo
|
|
|
|
|
|
newPeerInfo :: MonadIO m => m (PeerInfo e)
|
|
newPeerInfo = liftIO do
|
|
PeerInfo <$> newTVarIO defBurst
|
|
<*> newTVarIO 0
|
|
<*> newTVarIO 0
|
|
<*> newTVarIO 0
|
|
<*> newTVarIO 0
|
|
<*> newTVarIO 0
|
|
<*> newTVarIO 0
|
|
<*> newTVarIO 0
|
|
|
|
type instance SessionData e (PeerInfo e) = PeerInfo e
|
|
|
|
newtype instance SessionKey e (PeerInfo e) =
|
|
PeerInfoKey (Peer e)
|
|
|
|
deriving newtype instance Hashable (SessionKey UDP (PeerInfo UDP))
|
|
deriving stock instance Eq (SessionKey UDP (PeerInfo UDP))
|
|
|
|
instance Expires (SessionKey UDP (PeerInfo UDP)) where
|
|
expiresIn = const (Just 600)
|
|
|
|
|
|
peerPingLoop :: forall e m . ( HasPeerLocator e m
|
|
, HasPeer e
|
|
, HasNonces (PeerHandshake e) m
|
|
, Nonce (PeerHandshake e) ~ PingNonce
|
|
, Request e (PeerHandshake e) m
|
|
, Sessions e (PeerHandshake e) m
|
|
, Sessions e (PeerInfo e) m
|
|
, Pretty (Peer e)
|
|
, MonadIO m
|
|
)
|
|
=> m ()
|
|
peerPingLoop = forever do
|
|
pause @'Minutes 2 -- FIXME: defaults
|
|
debug "peerPingLoop"
|
|
|
|
pl <- getPeerLocator @e
|
|
pips <- knownPeers @e pl
|
|
|
|
for_ pips $ \p -> do
|
|
npi <- newPeerInfo
|
|
pfails <- fetch True npi (PeerInfoKey p) (view peerPingFailed)
|
|
liftIO $ atomically $ modifyTVar pfails succ
|
|
sendPing @e p
|
|
pause @'Seconds 2 -- NOTE: it's okay?
|
|
|
|
fnum <- liftIO $ readTVarIO pfails
|
|
|
|
when (fnum > 3) do -- FIXME: hardcode!
|
|
warn $ "removing peer" <+> pretty p <+> "for not responding to our pings"
|
|
delPeers pl [p]
|
|
expire (PeerInfoKey p)
|
|
|
|
|