From 3bccfa2e98f7054bc612eee5db3504ae3d7756a4 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Sun, 15 Oct 2023 09:01:42 +0300 Subject: [PATCH] minor refactoring --- hbs2-core/lib/HBS2/Net/Proto/RefLog.hs | 14 ++--- hbs2-peer/app/CheckBlockAnnounce.hs | 77 +++++++++++++------------- hbs2-peer/app/PeerMain.hs | 5 +- hbs2-peer/app/RefLog.hs | 15 ----- 4 files changed, 44 insertions(+), 67 deletions(-) diff --git a/hbs2-core/lib/HBS2/Net/Proto/RefLog.hs b/hbs2-core/lib/HBS2/Net/Proto/RefLog.hs index cc15346d..43301e75 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/RefLog.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/RefLog.hs @@ -10,6 +10,7 @@ import HBS2.Net.Proto import HBS2.Net.Auth.Credentials import HBS2.Base58 import HBS2.Events +import HBS2.Actors.Peer.Types import HBS2.Net.Proto.Peer import HBS2.Net.Proto.Sessions import HBS2.Data.Types.Refs @@ -72,11 +73,6 @@ deriving instance makeLenses 'RefLogUpdate -newtype RefLogUpdateI e m = - RefLogUpdateI - { refLogBroadcast :: RefLogUpdate e -> m () - } - data RefLogUpdateEv e data RefLogRequestAnswer e @@ -197,6 +193,7 @@ refLogUpdateProto :: forall e s m . ( MonadIO m , Request e (RefLogUpdate e) m , Response e (RefLogUpdate e) m , HasDeferred e (RefLogUpdate e) m + , HasGossip e (RefLogUpdate e) m , IsPeerAddr e m , Pretty (Peer e) , Nonce (RefLogUpdate e) ~ ByteString @@ -206,9 +203,9 @@ refLogUpdateProto :: forall e s m . ( MonadIO m , EventEmitter e (RefLogUpdateEv e) m , s ~ Encryption e ) - => RefLogUpdateI e m -> RefLogUpdate e -> m () + => RefLogUpdate e -> m () -refLogUpdateProto adapter = +refLogUpdateProto = \case e@RefLogUpdate{} -> do p <- thatPeer proto @@ -226,8 +223,7 @@ refLogUpdateProto adapter = -- FIXME: refactor:use-type-application-for-deferred deferred proto do emit @e RefLogUpdateEvKey (RefLogUpdateEvData (pubk, e)) - refLogBroadcast adapter e - pure () + gossip e where proto = Proxy @(RefLogUpdate e) diff --git a/hbs2-peer/app/CheckBlockAnnounce.hs b/hbs2-peer/app/CheckBlockAnnounce.hs index c2d45d6d..cc01b745 100644 --- a/hbs2-peer/app/CheckBlockAnnounce.hs +++ b/hbs2-peer/app/CheckBlockAnnounce.hs @@ -18,6 +18,7 @@ import DownloadQ import HBS2.System.Logger.Simple +import Control.Monad.Trans.Maybe import Data.Set qualified as Set import Data.Set (Set) import Lens.Micro.Platform @@ -52,6 +53,33 @@ instance HasCfgValue PeerAcceptAnnounceKey AcceptAnnounce where kk = key @PeerAcceptAnnounceKey @AcceptAnnounce + +acceptAnnouncesFromPeer :: forall e m . ( e ~ L4Proto + , MonadIO m + , Sessions L4Proto (KnownPeer L4Proto) m + ) + => PeerConfig + -> PeerAddr e + -> m Bool +acceptAnnouncesFromPeer conf pa = runPlus do + + pip <- lift (fromPeerAddr @e pa) + + pd <- toMPlus =<< lift (find @e (KnownPeerKey pip) id) + + let accptAnn = cfgValue @PeerAcceptAnnounceKey conf :: AcceptAnnounce + + guard =<< peerBanned conf pd + + case accptAnn of + AcceptAnnounceAll -> pure () + AcceptAnnounceFrom s -> do + guard (view peerSignKey pd `Set.member` s) + + where + runPlus m = runMaybeT m <&> isJust + + checkBlockAnnounce :: forall e m . ( e ~ L4Proto , m ~ PeerM e IO ) @@ -62,49 +90,20 @@ checkBlockAnnounce :: forall e m . ( e ~ L4Proto -> Hash HbSync -> m () -checkBlockAnnounce conf denv nonce pa h = do +checkBlockAnnounce conf denv nonce pa h = void $ runMaybeT do - let accptAnn = cfgValue @PeerAcceptAnnounceKey conf :: AcceptAnnounce + accept <- lift $ acceptAnnouncesFromPeer conf pa - let acceptAnnounce p pd = do - case accptAnn of - AcceptAnnounceAll -> pure True - AcceptAnnounceFrom s -> pure $ view peerSignKey pd `Set.member` s + myNonce <- lift $ peerNonce @e - pip <- fromPeerAddr @e pa + guard (nonce /= myNonce) - n1 <- peerNonce @e + debug $ "Accept announce from" <+> pretty pa <+> pretty accept - unless (nonce == n1) do + guard accept - mpde <- find @e (KnownPeerKey pip) id - - debug $ "received announce from" - <+> pretty pip - <+> pretty h - - case mpde of - Nothing -> do - sendPing @e pip - -- TODO: enqueue-announce-from-unknown-peer? - - Just pd -> do - - banned <- peerBanned conf pd - - notAccepted <- acceptAnnounce pip pd <&> not - - if | banned -> do - - notice $ pretty pip <+> "banned" - - | notAccepted -> do - - debug $ pretty pip <+> "announce-not-accepted" - - | otherwise -> do - - downloadLogAppend @e h - withDownload denv $ do - processBlock h + lift do + downloadLogAppend @e h + withDownload denv $ do + processBlock h diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index 828accb3..73daa2bc 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/hbs2-peer/app/PeerMain.hs @@ -700,11 +700,8 @@ runPeer opts = U.handle (\e -> myException e runPeerM penv $ do adapter <- mkAdapter - - reflogAdapter <- RefLog.mkAdapter reflogReqAdapter <- RefLog.mkRefLogRequestAdapter @e - let doDownload h = do pro <- isReflogProcessed @e brains h if pro then do @@ -956,7 +953,7 @@ runPeer opts = U.handle (\e -> myException e , makeResponse (withCredentials @e pc . peerHandShakeProto hshakeAdapter penv) , makeResponse (withCredentials @e pc . encryptionHandshakeProto encryptionHshakeAdapter) , makeResponse (peerExchangeProto pexFilt) - , makeResponse (refLogUpdateProto reflogAdapter) + , makeResponse refLogUpdateProto , makeResponse (refLogRequestProto reflogReqAdapter) , makeResponse (peerMetaProto peerMeta) , makeResponse (refChanHeadProto False refChanAdapter) diff --git a/hbs2-peer/app/RefLog.hs b/hbs2-peer/app/RefLog.hs index 94174f09..1c3c7c0b 100644 --- a/hbs2-peer/app/RefLog.hs +++ b/hbs2-peer/app/RefLog.hs @@ -28,7 +28,6 @@ import PeerTypes import Data.Function(fix) import Data.Maybe import Data.Foldable(for_) -import Data.Text qualified as Text import Control.Concurrent.STM import Control.Monad import Data.ByteString.Lazy qualified as LBS @@ -80,20 +79,6 @@ doOnRefLogRequest :: forall e s m . ( MonadIO m doOnRefLogRequest sto (_,pk) = liftIO $ getRef sto (RefLogKey @s pk) -mkAdapter :: forall e s m . ( MonadIO m - , HasPeerLocator e m - , Sessions e (KnownPeer e) m - , Request e (RefLogUpdate e) m - , MyPeer e - -- , Pretty (AsBase58 (PubKey 'Sign s)) - , s ~ Encryption e - ) - => m (RefLogUpdateI e (ResponseM e m )) - -mkAdapter = do - let bcast = lift . doRefLogBroadCast @e - pure $ RefLogUpdateI bcast - data RefLogWorkerAdapter e = RefLogWorkerAdapter