diff --git a/hbs2-core/lib/HBS2/Net/Proto/RefLog.hs b/hbs2-core/lib/HBS2/Net/Proto/RefLog.hs index 43301e75..299cdf3a 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/RefLog.hs +++ b/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 diff --git a/hbs2-peer/app/CheckBlockAnnounce.hs b/hbs2-peer/app/CheckBlockAnnounce.hs index cc01b745..2f3ec9a3 100644 --- a/hbs2-peer/app/CheckBlockAnnounce.hs +++ b/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 diff --git a/hbs2-peer/app/HttpWorker.hs b/hbs2-peer/app/HttpWorker.hs index d3b0511a..52bc4e66 100644 --- a/hbs2-peer/app/HttpWorker.hs +++ b/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 diff --git a/hbs2-peer/app/RPC2/RefLog.hs b/hbs2-peer/app/RPC2/RefLog.hs index 1cf7bfe2..b5d2b3ed 100644 --- a/hbs2-peer/app/RPC2/RefLog.hs +++ b/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 diff --git a/hbs2-peer/app/RefLog.hs b/hbs2-peer/app/RefLog.hs index 1c3c7c0b..a8c0de69 100644 --- a/hbs2-peer/app/RefLog.hs +++ b/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))