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

wip, log merging, debug-9

This commit is contained in:
Dmitry Zuikov 2023-07-19 12:23:05 +03:00
parent ccce48f84b
commit 85987c4902
1 changed files with 1 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
hbs2-peer/app/RefChan.hs
View File

@ -433,8 +433,6 @@ logMergeProcess _ q = do
current <- lift $ readLog sto (HashRef h) <&> HashSet.fromList current <- lift $ readLog sto (HashRef h) <&> HashSet.fromList
debug $ "ABOUT TO MERGE LOGS" <+> pretty (AsBase58 chan) <+> pretty (length logs)
trans <- filter (not . flip HashSet.member current) . mconcat <$> mapM (lift . readLog sto) logs trans <- filter (not . flip HashSet.member current) . mconcat <$> mapM (lift . readLog sto) logs
guard (not $ List.null trans) guard (not $ List.null trans)
@ -460,33 +458,23 @@ logMergeProcess _ q = do
blk <- MaybeT $ liftIO $ getBlock sto (fromHashRef href) blk <- MaybeT $ liftIO $ getBlock sto (fromHashRef href)
debug $ "BLOCK OK" <+> pretty href
tran <- MaybeT $ pure $ deserialiseOrFail @(RefChanUpdate e) blk tran <- MaybeT $ pure $ deserialiseOrFail @(RefChanUpdate e) blk
& either (const Nothing) Just & either (const Nothing) Just
debug $ "TRAN OK" <+> pretty href
case tran of case tran of
Propose _ box -> do Propose _ box -> do
(pk, ProposeTran headRef box) <- MaybeT $ pure $ unboxSignedBox0 box (pk, ProposeTran headRef box) <- MaybeT $ pure $ unboxSignedBox0 box
debug $ "PROPOSE" <+> pretty href <+> pretty headRef
(ak, _) <- MaybeT $ pure $ unboxSignedBox0 box (ak, _) <- MaybeT $ pure $ unboxSignedBox0 box
hd <- MaybeT $ lift $ getHead menv headRef hd <- MaybeT $ lift $ getHead menv headRef
let quo = view refChanHeadQuorum hd & fromIntegral let quo = view refChanHeadQuorum hd & fromIntegral
debug $ "PROPOSE QUO" <+> pretty href <+> pretty quo
guard $ checkACL hd pk ak guard $ checkACL hd pk ak
debug $ "PROPOSE ACL CHECK OK" <+> pretty href
pure [(href, (quo,mempty))] pure [(href, (quo,mempty))]
Accept _ box -> do Accept _ box -> do
(pk, AcceptTran headRef hashRef) <- MaybeT $ pure $ unboxSignedBox0 box (pk, AcceptTran headRef hashRef) <- MaybeT $ pure $ unboxSignedBox0 box
debug $ "ACCEPT" <+> pretty href <+> pretty headRef
hd <- MaybeT $ lift $ getHead menv headRef hd <- MaybeT $ lift $ getHead menv headRef
let quo = view refChanHeadQuorum hd & fromIntegral let quo = view refChanHeadQuorum hd & fromIntegral
debug $ "ACCEPT QUO" <+> pretty href <+> pretty quo
guard $ HashMap.member pk (view refChanHeadPeers hd) guard $ HashMap.member pk (view refChanHeadPeers hd)
debug $ "ACCEPT ACL CHECK OK" <+> pretty href
pure [(hashRef, (quo,[href]))] pure [(hashRef, (quo,[href]))]
let merge1 (q1, hs1) (q2, hs2) = (max q1 q2, List.nub (hs1 <> hs2) ) let merge1 (q1, hs1) (q2, hs2) = (max q1 q2, List.nub (hs1 <> hs2) )
@ -494,15 +482,13 @@ logMergeProcess _ q = do
let permitted = HashMap.fromListWith merge1 (mconcat (catMaybes r)) let permitted = HashMap.fromListWith merge1 (mconcat (catMaybes r))
& HashMap.toList & HashMap.toList
debug $ "PERMITTED" <+> pretty permitted
new <- S.toList_ do new <- S.toList_ do
forM_ permitted $ \(prop, (qx, accs)) -> do forM_ permitted $ \(prop, (qx, accs)) -> do
when (length accs >= qx) do when (length accs >= qx) do
S.yield prop S.yield prop
S.each accs S.each accs
debug $ "NEW TRANS TO MERGE" <+> pretty new debug $ "new trans to merge" <+> pretty (AsBase58 chan) <+> pretty (length new)
let merged = HashSet.union current (HashSet.fromList new) & HashSet.toList let merged = HashSet.union current (HashSet.fromList new) & HashSet.toList