voidlizard
/
hbs2
mirror of https://github.com/voidlizard/hbs2
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

wip

This commit is contained in:
Dmitry Zuikov 2024-08-07 13:13:30 +03:00
parent 57fb0516f1
commit bdd98632b4
2 changed files with 20 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
hbs2-peer/lib/HBS2/Peer/RPC/Client/RefChan.hs
View File

@ -141,10 +141,11 @@ walkRefChanTx :: forall proto m . ( MonadIO m
, HasProtocol proto (ServiceProto RefChanAPI proto) , HasProtocol proto (ServiceProto RefChanAPI proto)
, HasStorage m , HasStorage m
) )
=> PubKey 'Sign 'HBS2Basic => (HashRef -> m Bool)
-> (RefChanUpdateUnpacked L4Proto -> m ()) -> PubKey 'Sign 'HBS2Basic
-> (HashRef -> RefChanUpdateUnpacked L4Proto -> m ())
-> m () -> m ()
walkRefChanTx puk action = do walkRefChanTx filt puk action = do
sto <- getStorage sto <- getStorage
api <- getClientAPI @RefChanAPI @proto api <- getClientAPI @RefChanAPI @proto
@ -162,21 +163,23 @@ walkRefChanTx puk action = do
Right (hs :: [HashRef]) -> do Right (hs :: [HashRef]) -> do
for_ hs $ \h -> do for_ hs $ \h -> do
lbs' <- getBlock sto (coerce h) want <- lift (filt h)
lbs <- ContT $ maybe1 lbs' none when want do
lbs' <- getBlock sto (coerce h)
lbs <- ContT $ maybe1 lbs' none
let txraw = deserialiseOrFail @(RefChanUpdate L4Proto) lbs let txraw = deserialiseOrFail @(RefChanUpdate L4Proto) lbs
& either (const Nothing) Just & either (const Nothing) Just
tx <- ContT $ maybe1 txraw none tx <- ContT $ maybe1 txraw none
case tx of case tx of
Accept _ box -> do Accept _ box -> do
(_, txx) <- ContT $ maybe1 (unboxSignedBox0 box) none (_, txx) <- ContT $ maybe1 (unboxSignedBox0 box) none
lift $ action (A txx) lift $ action h (A txx)
Propose _ box -> do Propose _ box -> do
(_, txx) <- ContT $ maybe1 (unboxSignedBox0 box) none (_, txx) <- ContT $ maybe1 (unboxSignedBox0 box) none
lift $ action (P h txx) lift $ action h (P h txx)

3
hbs2-sync/src/HBS2/Sync/Prelude.hs
View File

@ -857,7 +857,8 @@ getStateFromRefChan rchan = do
outq <- newTQueueIO outq <- newTQueueIO
tss <- newTVarIO mempty tss <- newTVarIO mempty
walkRefChanTx @UNIX rchan $ \case -- FIXME: may-be-slow
walkRefChanTx @UNIX (const $ pure True) rchan $ \txh -> \case
A (AcceptTran ts _ what) -> do A (AcceptTran ts _ what) -> do
-- debug $ red "ACCEPT" <+> pretty ts <+> pretty what -- debug $ red "ACCEPT" <+> pretty ts <+> pretty what
for_ ts $ \w -> do for_ ts $ \w -> do