accept reflogupdate only for subcribed refs or from friendly peers

hbs2-core/lib/HBS2/Net/Proto/RefLog.hs

@@ -86,7 +86,7 @@ instance Typeable (RefLogUpdateEv e) => Hashable (EventKey e (RefLogUpdateEv e))
       p = Proxy @RefLogUpdateEv
 
 newtype instance Event e (RefLogUpdateEv e) =
-  RefLogUpdateEvData (PubKey 'Sign (Encryption e), RefLogUpdate e)
+  RefLogUpdateEvData (PubKey 'Sign (Encryption e), RefLogUpdate e, Maybe (Peer e))
   deriving (Typeable)
 
 instance EventType ( Event e (RefLogUpdateEv e) ) where
@@ -222,7 +222,7 @@ refLogUpdateProto =
 
           -- FIXME: refactor:use-type-application-for-deferred
           deferred proto do
-            emit @e RefLogUpdateEvKey (RefLogUpdateEvData (pubk, e))
+            emit @e RefLogUpdateEvKey (RefLogUpdateEvData (pubk, e, Just p))
             gossip e
 
     where

hbs2-peer/app/CheckBlockAnnounce.hs

@@ -54,9 +54,13 @@ instance HasCfgValue PeerAcceptAnnounceKey AcceptAnnounce where
 
 
 
-acceptAnnouncesFromPeer :: forall e m . ( e ~ L4Proto
-                                        , MonadIO m
-                                        , Sessions L4Proto (KnownPeer L4Proto) m
+acceptAnnouncesFromPeer :: forall e m . ( MonadIO m
+                                        , Sessions e (KnownPeer e) m
+                                        , IsPeerAddr e m
+                                        , Ord (PubKey 'Sign (Encryption e))
+                                        , FromStringMaybe (PubKey 'Sign (Encryption e))
+                                        , Ord (PubKey 'Sign (Encryption e))
+                                        , e ~ L4Proto
                                         )
                       => PeerConfig
                       -> PeerAddr e

hbs2-peer/app/HttpWorker.hs

@@ -74,6 +74,7 @@ httpWorker conf pmeta e = do
             maybe1 va (status status404) $ \val -> do
               text [qc|{pretty val}|]
 
+      -- FIXME: to-replace-to-rpc
       post "/reflog" do
         bs <- LBS.take 4194304 <$> body
         let msg' =
@@ -86,7 +87,7 @@ httpWorker conf pmeta e = do
           Just msg -> do
             let pubk = view refLogId msg
             liftIO $ withPeerM penv $ do
-              emit @e RefLogUpdateEvKey (RefLogUpdateEvData (pubk, msg))
+              emit @e RefLogUpdateEvKey (RefLogUpdateEvData (pubk, msg, Nothing))
               doRefLogBroadCast msg
             status status200
 

hbs2-peer/app/RPC2/RefLog.hs

@@ -64,7 +64,7 @@ instance (RefLogContext m) => HandleMethod m RpcRefLogPost where
     debug $ "rpc.reflogPost:"  <+> pretty (AsBase58 pk)
 
     liftIO $ withPeerM (rpcPeerEnv co) $ do
-      emit @L4Proto RefLogUpdateEvKey (RefLogUpdateEvData (pk, msg))
+      emit @L4Proto RefLogUpdateEvKey (RefLogUpdateEvData (pk, msg, Nothing))
       doRefLogBroadCast msg
 
 

hbs2-peer/app/RefLog.hs

@@ -24,6 +24,7 @@ import HBS2.System.Logger.Simple
 import Brains
 import PeerConfig
 import PeerTypes
+import CheckBlockAnnounce (acceptAnnouncesFromPeer)
 
 import Data.Function(fix)
 import Data.Maybe
@@ -86,17 +87,19 @@ data RefLogWorkerAdapter e =
  , reflogFetch    :: PubKey 'Sign (Encryption e) -> IO ()
  }
 
-reflogWorker :: forall e s m . ( MonadIO m, MyPeer e
+reflogWorker :: forall e s m . ( e ~ L4Proto
+                               , MonadIO m, MyPeer e
                                , EventListener e (RefLogUpdateEv e) m
                                , EventListener e (RefLogRequestAnswer e) m
-                             -- , Request e (RefLogRequest e) (Peerm
                                , HasStorage m
                                , Nonce (RefLogUpdate e) ~ BS.ByteString
                                , Serialise (RefLogUpdate e)
                                , EventEmitter e (RefLogUpdateEv e) m -- (PeerM e m)
+                               , Sessions L4Proto (KnownPeer L4Proto) m
                                , Signatures s
                                , s ~ Encryption e
                                , IsRefPubKey s
+                               , IsPeerAddr e m
                                , Pretty (AsBase58 (PubKey 'Sign s))
                               )
              => PeerConfig
@@ -138,11 +141,17 @@ reflogWorker conf brains adapter = do
             -- TODO: support-other-data-structures
             _ -> pure ()
 
-  subscribe @e RefLogUpdateEvKey $ \(RefLogUpdateEvData (reflog,v)) -> do
+  subscribe @e RefLogUpdateEvKey $ \(RefLogUpdateEvData (reflog,v, mpip)) -> do
     trace $ "reflog worker.got refupdate" <+> pretty (AsBase58 reflog)
-    liftIO $ reflogUpdate reflog Nothing v
-    liftIO $ atomically $ writeTQueue pQ (reflog, [v])
 
+    polled <- isPolledRef @e brains reflog
+    buddy <- maybe1 mpip (pure False) $ \pip -> do
+                pa <- toPeerAddr @e pip
+                acceptAnnouncesFromPeer @e conf pa
+
+    when (buddy || polled) $ liftIO do
+      reflogUpdate reflog Nothing v
+      atomically $ writeTQueue pQ (reflog, [v])
 
   reflogMon <- liftIO $ newTVarIO (mempty :: HashSet (Hash HbSync))