wip, renamed some stuff

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)
 
-
+-- FIXME: rename
-data RefChanHeadAdapter e m =
+data RefChanAdapter e m =
-  RefChanHeadAdapter
+  RefChanAdapter
-  { refChanHeadOnHead     :: RefChanId e -> RefChanHeadBlockTran e -> m ()
+  { refChanOnHead     :: RefChanId e -> RefChanHeadBlockTran e -> m ()
-  , refChanHeadSubscribed :: RefChanId e -> m Bool
+  , 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"
 

hbs2-peer/app/PeerMain.hs

@@ -562,9 +562,10 @@ runPeer opts = U.handle (\e -> myException e
 
   rce <- refChanWorkerEnv conf denv
 
-  let refChanHeadAdapter = RefChanHeadAdapter
+  let refChanAdapter = RefChanAdapter
-                           { refChanHeadOnHead = refChanOnHead rce
+                           { refChanOnHead = refChanOnHeadFn rce
-                           , refChanHeadSubscribed = isPolledRef @e brains
+                           , 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 (refChanHeadProto False refChanAdapter)
-                    , makeResponse (refChanUpdateProto False pc refChanHeadAdapter)
+                    , 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

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 ()
+refChanOnHeadFn :: MonadIO m => RefChanWorkerEnv e -> RefChanId e -> RefChanHeadBlockTran e -> m ()
-refChanOnHead env chan tran = do
+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