mirror of https://github.com/voidlizard/hbs2
wip, renamed some stuff
This commit is contained in:
Dmitry Zuikov
parent
758efdd455
commit
697c79133e
|
|
@ -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"
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue