mirror of https://github.com/voidlizard/hbs2
fixing-cpu-burning-and-further-optimizations
This commit is contained in:
Dmitry Zuikov
parent
21b951aaf9
commit
bd2c0e0367
|
|
@ -241,30 +241,29 @@ instance (ForConsensus m) => IsQBLF ConsensusQBLF (App m) where
|
||||||
let sk = view peerSignSk creds
|
let sk = view peerSignSk creds
|
||||||
let pk = view peerSignPk creds
|
let pk = view peerSignPk creds
|
||||||
|
|
||||||
-- let block = serialise (HashSet.toList $ HashSet.fromList txs)
|
|
||||||
|
|
||||||
hashes <- liftIO $ mapM (putBlock sto . serialise) txs <&> catMaybes
|
|
||||||
|
|
||||||
-- пробуем разослать бандлы с транзакциями
|
|
||||||
runMaybeT do
|
|
||||||
ref <- MaybeT $ createBundle sto (fmap HashRef hashes)
|
|
||||||
let refval = makeBundleRefValue @L4Proto pk sk (BundleRefSimple ref)
|
|
||||||
r <- MaybeT $ liftIO $ putBlock sto (serialise refval)
|
|
||||||
lift $ request self (ActionRequest @UNIX chan (RefChanAnnounceBlock (HashRef r)))
|
|
||||||
|
|
||||||
current <- readLog (getBlock sto) h0
|
|
||||||
|
|
||||||
-- основная проблема в том, что мы пересортировываем весь state
|
-- основная проблема в том, что мы пересортировываем весь state
|
||||||
-- однако, если считать его уже отсортированным, то, может быть,
|
-- однако, если считать его уже отсортированным, то, может быть,
|
||||||
-- все будет не так уж плохо.
|
-- все будет не так уж плохо.
|
||||||
-- так-то мы можем вообще его на диске держать
|
-- так-то мы можем вообще его на диске держать
|
||||||
let new = HashSet.fromList ( current <> fmap HashRef hashes )
|
|
||||||
|
|
||||||
let pt = toPTree (MaxSize 256) (MaxNum 256) (HashSet.toList new)
|
root <- if List.null txs then do
|
||||||
|
|
||||||
root <- if List.null hashes then do
|
|
||||||
pure h0
|
pure h0
|
||||||
else do
|
else do
|
||||||
|
hashes <- liftIO $ mapM (putBlock sto . serialise) txs <&> catMaybes
|
||||||
|
|
||||||
|
current <- readLog (getBlock sto) h0
|
||||||
|
|
||||||
|
let new = HashSet.fromList ( current <> fmap HashRef hashes )
|
||||||
|
|
||||||
|
let pt = toPTree (MaxSize 256) (MaxNum 256) (HashSet.toList new)
|
||||||
|
|
||||||
|
-- пробуем разослать бандлы с транзакциями
|
||||||
|
runMaybeT do
|
||||||
|
ref <- MaybeT $ createBundle sto (fmap HashRef hashes)
|
||||||
|
let refval = makeBundleRefValue @L4Proto pk sk (BundleRefSimple ref)
|
||||||
|
r <- MaybeT $ liftIO $ putBlock sto (serialise refval)
|
||||||
|
lift $ request self (ActionRequest @UNIX chan (RefChanAnnounceBlock (HashRef r)))
|
||||||
|
|
||||||
r <- makeMerkle 0 pt $ \(hx,_,bs) -> do
|
r <- makeMerkle 0 pt $ \(hx,_,bs) -> do
|
||||||
th <- liftIO (enqueueBlock sto bs)
|
th <- liftIO (enqueueBlock sto bs)
|
||||||
debug $ "WRITE TX" <+> pretty hx
|
debug $ "WRITE TX" <+> pretty hx
|
||||||
|
|
@ -320,63 +319,68 @@ instance (ForConsensus m) => IsQBLF ConsensusQBLF (App m) where
|
||||||
sto <- asks mySto
|
sto <- asks mySto
|
||||||
let readFn = liftIO . getBlock sto
|
let readFn = liftIO . getBlock sto
|
||||||
|
|
||||||
tx0 <- readLog readFn (fromDAppState s0) <&> HashSet.fromList
|
|
||||||
tx1 <- mapM (readLog readFn) (fmap fromDAppState s1) <&> mconcat
|
tx1 <- mapM (readLog readFn) (fmap fromDAppState s1) <&> mconcat
|
||||||
|
tx0 <- readLog readFn (fromDAppState s0) <&> HashSet.fromList
|
||||||
|
|
||||||
debug $ "READ TXS" <+> pretty s1 <+> pretty (length tx1)
|
let txNew = HashSet.fromList tx1 `HashSet.difference` tx0
|
||||||
|
|
||||||
r <- forM tx1 $ \t -> runMaybeT do
|
if List.null txNew then do
|
||||||
|
pure s0
|
||||||
|
else do
|
||||||
|
debug $ "READ TXS" <+> pretty s1 <+> pretty (length tx1)
|
||||||
|
|
||||||
-- игнорируем ранее добавленные транзакции
|
r <- forM tx1 $ \t -> runMaybeT do
|
||||||
guard (not (HashSet.member t tx0))
|
|
||||||
|
|
||||||
bs <- MaybeT $ liftIO $ getBlock sto (fromHashRef t)
|
-- игнорируем ранее добавленные транзакции
|
||||||
|
guard (not (HashSet.member t tx0))
|
||||||
|
|
||||||
tx <- MaybeT $ pure $ deserialiseOrFail @(QBLFDemoToken L4Proto) bs & either (const Nothing) Just
|
bs <- MaybeT $ liftIO $ getBlock sto (fromHashRef t)
|
||||||
|
|
||||||
case tx of
|
tx <- MaybeT $ pure $ deserialiseOrFail @(QBLFDemoToken L4Proto) bs & either (const Nothing) Just
|
||||||
Emit box -> do
|
|
||||||
(pk, e@(EmitTx a q _)) <- MaybeT $ pure $ unboxSignedBox0 @(EmitTx L4Proto) box
|
|
||||||
guard ( chan == pk )
|
|
||||||
debug $ "VALID EMIT TRANSACTION" <+> pretty t <+> pretty (AsBase58 a) <+> pretty q
|
|
||||||
pure ([(t,e)], mempty)
|
|
||||||
|
|
||||||
(Move box) -> do
|
case tx of
|
||||||
(_, m@(MoveTx _ _ qty _)) <- MaybeT $ pure $ unboxSignedBox0 @(MoveTx L4Proto) box
|
Emit box -> do
|
||||||
|
(pk, e@(EmitTx a q _)) <- MaybeT $ pure $ unboxSignedBox0 @(EmitTx L4Proto) box
|
||||||
|
guard ( chan == pk )
|
||||||
|
debug $ "VALID EMIT TRANSACTION" <+> pretty t <+> pretty (AsBase58 a) <+> pretty q
|
||||||
|
pure ([(t,e)], mempty)
|
||||||
|
|
||||||
guard (qty > 0)
|
(Move box) -> do
|
||||||
debug $ "MOVE TRANSACTION" <+> pretty t
|
(_, m@(MoveTx _ _ qty _)) <- MaybeT $ pure $ unboxSignedBox0 @(MoveTx L4Proto) box
|
||||||
pure (mempty, [(t,m)])
|
|
||||||
|
|
||||||
let parsed = catMaybes r
|
guard (qty > 0)
|
||||||
|
debug $ "MOVE TRANSACTION" <+> pretty t
|
||||||
|
pure (mempty, [(t,m)])
|
||||||
|
|
||||||
let emits = foldMap (view _1) parsed
|
let parsed = catMaybes r
|
||||||
|
|
||||||
let moves = foldMap (view _2) parsed & List.sortOn fst
|
let emits = foldMap (view _1) parsed
|
||||||
|
|
||||||
bal0 <- balances (fromDAppState s0)
|
let moves = foldMap (view _2) parsed & List.sortOn fst
|
||||||
|
|
||||||
-- баланс с учётом новых emit
|
bal0 <- balances (fromDAppState s0)
|
||||||
let balE = foldMap (toBalance @L4Proto . snd) emits
|
|
||||||
& HashMap.fromListWith (+)
|
|
||||||
& HashMap.unionWith (+) bal0
|
|
||||||
|
|
||||||
let moves' = updBalances @L4Proto balE moves
|
-- баланс с учётом новых emit
|
||||||
|
let balE = foldMap (toBalance @L4Proto . snd) emits
|
||||||
|
& HashMap.fromListWith (+)
|
||||||
|
& HashMap.unionWith (+) bal0
|
||||||
|
|
||||||
let merged = fmap fst emits <> fmap fst moves'
|
let moves' = updBalances @L4Proto balE moves
|
||||||
|
|
||||||
let pt = toPTree (MaxSize 256) (MaxNum 256) (HashSet.toList (tx0 <> HashSet.fromList merged))
|
let merged = fmap fst emits <> fmap fst moves'
|
||||||
|
|
||||||
root <- makeMerkle 0 pt $ \(_,_,bs) -> do
|
let pt = toPTree (MaxSize 256) (MaxNum 256) (HashSet.toList (tx0 <> HashSet.fromList merged))
|
||||||
void $ liftIO (putBlock sto bs)
|
|
||||||
|
|
||||||
let new = DAppState (HashRef root)
|
root <- makeMerkle 0 pt $ \(_,_,bs) -> do
|
||||||
|
void $ liftIO (putBlock sto bs)
|
||||||
|
|
||||||
-- FIXME: garbage-collect-discarded-states
|
let new = DAppState (HashRef root)
|
||||||
|
|
||||||
debug $ "MERGED" <+> pretty new
|
-- FIXME: garbage-collect-discarded-states
|
||||||
|
|
||||||
pure new
|
debug $ "MERGED" <+> pretty new
|
||||||
|
|
||||||
|
pure new
|
||||||
|
|
||||||
|
|
||||||
instance (HasConf (ReaderT Config IO)) where
|
instance (HasConf (ReaderT Config IO)) where
|
||||||
|
|
@ -478,7 +482,7 @@ fetchMissed env s = do
|
||||||
when here do
|
when here do
|
||||||
liftIO $ Cache.delete cache href
|
liftIO $ Cache.delete cache href
|
||||||
|
|
||||||
unless (here && not wip) do
|
unless (here || wip) do
|
||||||
debug $ "We might be need to fetch" <+> pretty s
|
debug $ "We might be need to fetch" <+> pretty s
|
||||||
liftIO $ Cache.insert cache href ()
|
liftIO $ Cache.insert cache href ()
|
||||||
request @UNIX tube (ActionRequest @UNIX chan (RefChanFetch (fromDAppState s)))
|
request @UNIX tube (ActionRequest @UNIX chan (RefChanFetch (fromDAppState s)))
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue