minor refactoring

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
+            gossip e
-            pure ()
 
     where
       proto = Proxy @(RefLogUpdate e)

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
+  myNonce  <- lift $ peerNonce @e
-        case accptAnn of
-          AcceptAnnounceAll    -> pure True
-          AcceptAnnounceFrom s -> pure $ view peerSignKey pd `Set.member` s
 
-  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
+  lift do
-
+    downloadLogAppend @e h
-    debug $ "received announce from"
+    withDownload denv $ do
-                  <+> pretty pip
+      processBlock h
-                  <+> 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
 

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)

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