mirror of https://github.com/voidlizard/hbs2
138 lines
4.0 KiB
Haskell
138 lines
4.0 KiB
Haskell
{-# Language UndecidableInstances #-}
|
|
module HBS2.Net.Proto.PeerExchange where
|
|
|
|
import HBS2.Prelude.Plated
|
|
import HBS2.Net.Proto
|
|
import HBS2.Net.Proto.Peer
|
|
import HBS2.Net.PeerLocator
|
|
import HBS2.Net.Proto.Sessions
|
|
import HBS2.Events
|
|
import HBS2.Clock
|
|
import HBS2.Defaults
|
|
|
|
import Data.ByteString qualified as BS
|
|
import Data.Traversable
|
|
import Data.Functor
|
|
import Data.Maybe
|
|
import Codec.Serialise
|
|
import Data.Hashable
|
|
import Type.Reflection
|
|
|
|
import HBS2.System.Logger.Simple
|
|
import Prettyprinter
|
|
|
|
data PeerExchange e =
|
|
PeerExchangeGet (Nonce (PeerExchange e))
|
|
| PeerExchangePeers (Nonce (PeerExchange e)) [PeerAddr e]
|
|
deriving stock (Generic, Typeable)
|
|
|
|
data PeerExchangePeersEv e
|
|
|
|
|
|
|
|
sendPeerExchangeGet :: forall e m . ( MonadIO m
|
|
, HasNonces (PeerExchange e) m
|
|
, Request e (PeerExchange e) m
|
|
, Sessions e (PeerExchange e) m
|
|
)
|
|
=> Peer e -> m ()
|
|
|
|
sendPeerExchangeGet pip = do
|
|
nonce <- newNonce @(PeerExchange e)
|
|
update nonce (PeerExchangeKey @e nonce) id
|
|
request pip (PeerExchangeGet @e nonce)
|
|
|
|
peerExchangeProto :: forall e m . ( MonadIO m
|
|
, Response e (PeerExchange e) m
|
|
, HasPeerLocator e m
|
|
, HasDeferred e (PeerExchange e) m
|
|
, HasNonces (PeerExchange e) m
|
|
, IsPeerAddr e m
|
|
, Sessions e (KnownPeer e) m
|
|
, Sessions e (PeerExchange e) m
|
|
, EventEmitter e (PeerExchangePeersEv e) m
|
|
, Eq (Nonce (PeerExchange e))
|
|
, Pretty (Peer e)
|
|
)
|
|
=> PeerExchange e -> m ()
|
|
|
|
peerExchangeProto =
|
|
\case
|
|
PeerExchangeGet n -> deferred proto do
|
|
-- TODO: sort peers by their usefulness
|
|
|
|
that <- thatPeer proto
|
|
|
|
debug $ "PeerExchangeGet" <+> "from" <+> pretty that
|
|
|
|
pl <- getPeerLocator @e
|
|
pips <- knownPeers @e pl
|
|
|
|
pa' <- forM pips $ \p -> do
|
|
auth <- find (KnownPeerKey p) id <&> isJust
|
|
if auth then do
|
|
a <- toPeerAddr p
|
|
pure [a]
|
|
else
|
|
pure mempty
|
|
|
|
let pa = take defPexMaxPeers $ mconcat pa'
|
|
|
|
response (PeerExchangePeers @e n pa)
|
|
|
|
PeerExchangePeers nonce pips -> do
|
|
|
|
pip <- thatPeer proto
|
|
|
|
ok <- find (PeerExchangeKey @e nonce) id <&> isJust
|
|
|
|
when ok do
|
|
sa <- mapM (fromPeerAddr @e) pips
|
|
debug $ "got pex" <+> "from" <+> pretty pip <+> pretty sa
|
|
expire @e (PeerExchangeKey nonce)
|
|
emit @e PeerExchangePeersKey (PeerExchangePeersData sa)
|
|
|
|
where
|
|
proto = Proxy @(PeerExchange e)
|
|
|
|
|
|
newtype instance SessionKey e (PeerExchange e) =
|
|
PeerExchangeKey (Nonce (PeerExchange e))
|
|
deriving stock (Generic, Typeable)
|
|
|
|
type instance SessionData e (PeerExchange e) = Nonce (PeerExchange e)
|
|
|
|
data instance EventKey e (PeerExchangePeersEv e) =
|
|
PeerExchangePeersKey
|
|
deriving stock (Typeable, Eq,Generic)
|
|
|
|
deriving instance Eq (Nonce (PeerExchange e)) => Eq (SessionKey e (PeerExchange e))
|
|
instance Hashable (Nonce (PeerExchange e)) => Hashable (SessionKey e (PeerExchange e))
|
|
|
|
instance Expires (SessionKey e (PeerExchange e)) where
|
|
expiresIn _ = Just 10
|
|
|
|
|
|
instance Typeable (PeerExchangePeersEv e)
|
|
=> Hashable (EventKey e (PeerExchangePeersEv e)) where
|
|
hashWithSalt salt _ = hashWithSalt salt (someTypeRep p)
|
|
where
|
|
p = Proxy @(PeerExchangePeersEv e)
|
|
|
|
instance EventType ( Event e ( PeerExchangePeersEv e) ) where
|
|
isPersistent = True
|
|
|
|
instance Expires (EventKey e (PeerExchangePeersEv e)) where
|
|
expiresIn _ = Nothing
|
|
|
|
newtype instance Event e (PeerExchangePeersEv e) =
|
|
PeerExchangePeersData [Peer e]
|
|
deriving stock (Typeable)
|
|
|
|
instance ( Serialise (PeerAddr e)
|
|
, Serialise (Nonce (PeerExchange e)))
|
|
|
|
=> Serialise (PeerExchange e)
|
|
|
|
|