From 697c79133eaf0bd2f817c9257cfa976353b97d85 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Tue, 18 Jul 2023 10:55:46 +0300 Subject: [PATCH] wip, renamed some stuff --- hbs2-core/lib/HBS2/Net/Proto/RefChan.hs | 23 ++++++++++++----------- hbs2-peer/app/PeerMain.hs | 15 ++++++++------- hbs2-peer/app/RefChan.hs | 8 ++++---- 3 files changed, 24 insertions(+), 22 deletions(-) diff --git a/hbs2-core/lib/HBS2/Net/Proto/RefChan.hs b/hbs2-core/lib/HBS2/Net/Proto/RefChan.hs index e26b51e8..62a15fe8 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/RefChan.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/RefChan.hs @@ -178,11 +178,12 @@ deriving stock instance ForRefChans L4Proto instance Expires (SessionKey L4Proto (RefChanHeadBlock L4Proto)) where expiresIn = const (Just defCookieTimeoutSec) - -data RefChanHeadAdapter e m = - RefChanHeadAdapter - { refChanHeadOnHead :: RefChanId e -> RefChanHeadBlockTran e -> m () - , refChanHeadSubscribed :: RefChanId e -> m Bool +-- FIXME: rename +data RefChanAdapter e m = + RefChanAdapter + { refChanOnHead :: RefChanId e -> RefChanHeadBlockTran e -> m () + , refChanSubscribed :: RefChanId e -> m Bool + , refChanWriteTran :: RefChanId e -> RefChanUpdate e -> m () } refChanHeadProto :: forall e s m . ( MonadIO m @@ -202,7 +203,7 @@ refChanHeadProto :: forall e s m . ( MonadIO m , s ~ Encryption e ) => Bool - -> RefChanHeadAdapter e m + -> RefChanAdapter e m -> RefChanHead e -> m () @@ -220,13 +221,13 @@ refChanHeadProto self adapter msg = do case msg of RefChanHead chan pkt -> do - guard =<< lift (refChanHeadSubscribed adapter chan) + guard =<< lift (refChanSubscribed adapter chan) trace $ "RefChanHead" <+> pretty self <+> pretty (AsBase58 chan) -- TODO: notify-others-for-new-head -- нужно ли уведомить остальных, что голова поменялась? -- всех, от кого мы еще не получали данное сообщение -- откуда мы знаем, от кого мы получали данное сообщение? - lift $ refChanHeadOnHead adapter chan pkt + lift $ refChanOnHead adapter chan pkt RefChanGetHead chan -> deferred proto do trace $ "RefChanGetHead" <+> pretty self <+> pretty (AsBase58 chan) @@ -264,7 +265,7 @@ refChanUpdateProto :: forall e s m . ( MonadIO m ) => Bool -> PeerCredentials s - -> RefChanHeadAdapter e m + -> RefChanAdapter e m -> RefChanUpdate e -> m () @@ -296,7 +297,7 @@ refChanUpdateProto self pc adapter msg = do case msg of Propose chan box -> do - guard =<< lift (refChanHeadSubscribed adapter chan) + guard =<< lift (refChanSubscribed adapter chan) debug "RefChanUpdate/Propose" deferred proto do @@ -359,7 +360,7 @@ refChanUpdateProto self pc adapter msg = do pure () Accept chan box -> deferred proto do - guard =<< lift (refChanHeadSubscribed adapter chan) + guard =<< lift (refChanSubscribed adapter chan) debug "RefChanUpdate/ACCEPT" diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index bc0c288e..b33fd05c 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/hbs2-peer/app/PeerMain.hs @@ -562,9 +562,10 @@ runPeer opts = U.handle (\e -> myException e rce <- refChanWorkerEnv conf denv - let refChanHeadAdapter = RefChanHeadAdapter - { refChanHeadOnHead = refChanOnHead rce - , refChanHeadSubscribed = isPolledRef @e brains + let refChanAdapter = RefChanAdapter + { refChanOnHead = refChanOnHeadFn rce + , refChanSubscribed = isPolledRef @e brains + , refChanWriteTran = \_ _ -> pure () } let pexFilt pips = do @@ -890,8 +891,8 @@ runPeer opts = U.handle (\e -> myException e , makeResponse (refLogUpdateProto reflogAdapter) , makeResponse (refLogRequestProto reflogReqAdapter) , makeResponse (peerMetaProto (mkPeerMeta conf)) - , makeResponse (refChanHeadProto False refChanHeadAdapter) - , makeResponse (refChanUpdateProto False pc refChanHeadAdapter) + , makeResponse (refChanHeadProto False refChanAdapter) + , makeResponse (refChanUpdateProto False pc refChanAdapter) ] void $ liftIO $ waitAnyCancel workers @@ -993,7 +994,7 @@ runPeer opts = U.handle (\e -> myException e Right (SignedBox k _ _) -> do let msg = RefChanHead k (RefChanHeadBlockTran (HashRef h)) refChanNotifyOnUpdated rce k - runResponseM me $ refChanHeadProto @e True refChanHeadAdapter msg + runResponseM me $ refChanHeadProto @e True refChanAdapter msg let refChanHeadGetAction puk = do trace $ "refChanHeadGetAction" <+> pretty (AsBase58 puk) @@ -1022,7 +1023,7 @@ runPeer opts = U.handle (\e -> myException e -- FIXME: remove-this-debug-stuff -- или оставить? нода будет сама себе -- консенсус слать тогда. может, и оставить - lift $ runResponseM me $ refChanUpdateProto @e True pc refChanHeadAdapter (Propose @e puk proposed) + lift $ runResponseM me $ refChanUpdateProto @e True pc refChanAdapter (Propose @e puk proposed) let arpc = RpcAdapter pokeAction dieAction diff --git a/hbs2-peer/app/RefChan.hs b/hbs2-peer/app/RefChan.hs index 4a234ec5..a7e4b022 100644 --- a/hbs2-peer/app/RefChan.hs +++ b/hbs2-peer/app/RefChan.hs @@ -4,7 +4,7 @@ module RefChan ( RefChanWorkerEnv(..) , refChanWorkerEnvHeadQ , refChanWorkerEnvDownload - , refChanOnHead + , refChanOnHeadFn , refChanWorker , refChanWorkerEnv , refChanNotifyOnUpdated @@ -79,8 +79,8 @@ refChanWorkerEnv _ de = liftIO $ RefChanWorkerEnv @e de <$> newTQueueIO <*> newTVarIO mempty -refChanOnHead :: MonadIO m => RefChanWorkerEnv e -> RefChanId e -> RefChanHeadBlockTran e -> m () -refChanOnHead env chan tran = do +refChanOnHeadFn :: MonadIO m => RefChanWorkerEnv e -> RefChanId e -> RefChanHeadBlockTran e -> m () +refChanOnHeadFn env chan tran = do atomically $ writeTQueue (view refChanWorkerEnvHeadQ env) (chan, tran) -- FIXME: leak-when-block-never-really-updated @@ -171,7 +171,7 @@ refChanWorker env brains = do rest <- forM all $ \(r,item@(chan,t)) -> do here <- checkDownloaded r if here then do - refChanOnHead env chan (RefChanHeadBlockTran r) + refChanOnHeadFn env chan (RefChanHeadBlockTran r) pure mempty else do -- FIXME: fix-timeout-hardcode