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

update after merge

This commit is contained in:
Sergey Ivanov 2023-07-25 18:47:11 +04:00
parent 75f03b9c95
commit c60a0b4696
3 changed files with 118 additions and 104 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

111
hbs2-core/lib/HBS2/Net/Proto/RefChan.hs
View File

@ -5,6 +5,8 @@
{-# LANGUAGE ImplicitParams #-} {-# LANGUAGE ImplicitParams #-}
module HBS2.Net.Proto.RefChan where module HBS2.Net.Proto.RefChan where
-- import HBS2.Actors.Peer.Types
import HBS2.Data.Types.Peer
import HBS2.Prelude.Plated import HBS2.Prelude.Plated
import HBS2.Hash import HBS2.Hash
import HBS2.Data.Detect import HBS2.Data.Detect
@ -151,6 +153,9 @@ data RefChanHead e =
| RefChanGetHead (RefChanId e) | RefChanGetHead (RefChanId e)
deriving stock (Generic) deriving stock (Generic)
instance Show (RefChanHead e) where
show _ = "RefChanHead"
instance ForRefChans e => Serialise (RefChanHead e) instance ForRefChans e => Serialise (RefChanHead e)
@ -221,6 +226,9 @@ data RefChanUpdate e =
| Accept (RefChanId e) (SignedBox (AcceptTran e) e) -- подписано ключом пира | Accept (RefChanId e) (SignedBox (AcceptTran e) e) -- подписано ключом пира
deriving stock (Generic) deriving stock (Generic)
instance Show (RefChanUpdate e) where
show _ = "RefChanUpdate"
instance ForRefChans e => Serialise (RefChanUpdate e) instance ForRefChans e => Serialise (RefChanUpdate e)
data RefChanRequest e = data RefChanRequest e =
@ -228,6 +236,9 @@ data RefChanRequest e =
| RefChanResponse (RefChanId e) HashRef | RefChanResponse (RefChanId e) HashRef
deriving stock (Generic,Typeable) deriving stock (Generic,Typeable)
instance Show (RefChanRequest e) where
show _ = "RefChanRequest"
instance ForRefChans e => Serialise (RefChanRequest e) instance ForRefChans e => Serialise (RefChanRequest e)
data instance EventKey e (RefChanRequest e) = data instance EventKey e (RefChanRequest e) =
@ -469,85 +480,89 @@ refChanUpdateProto self pc adapter msg = do
-- -- рассылаем ли себе? что бы был хоть один accept -- -- рассылаем ли себе? что бы был хоть один accept
lift $ refChanUpdateProto True pc adapter accept lift $ refChanUpdateProto True pc adapter accept
Accept chan box -> deferred proto do Accept chan box -> undefined
-- TODO: fix refchain
-- deferred proto do
debug $ "RefChanUpdate/ACCEPT" <+> pretty h0 -- debug $ "RefChanUpdate/ACCEPT" <+> pretty h0
(peerKey, AcceptTran headRef hashRef) <- MaybeT $ pure $ unboxSignedBox0 box -- (peerKey, AcceptTran headRef hashRef) <- MaybeT $ pure $ unboxSignedBox0 box
let refchanKey = RefChanHeadKey @s chan -- let refchanKey = RefChanHeadKey @s chan
h <- MaybeT $ liftIO $ getRef sto refchanKey -- h <- MaybeT $ liftIO $ getRef sto refchanKey
guard (HashRef h == headRef) -- guard (HashRef h == headRef)
lift $ gossip msg -- lift $ gossip msg
-- тут может так случиться, что propose еще нет -- -- тут может так случиться, что propose еще нет
-- UDP вообще не гарантирует порядок доставки, а отправляем мы транзы -- -- UDP вообще не гарантирует порядок доставки, а отправляем мы транзы
-- почти одновременно. ну или не успело записаться. и что делать? -- -- почти одновременно. ну или не успело записаться. и что делать?
here <- liftIO (hasBlock sto (fromHashRef hashRef)) <&> isJust -- here <- liftIO (hasBlock sto (fromHashRef hashRef)) <&> isJust
unless here do -- unless here do
warn $ "No propose transaction saved yet!" <+> pretty hashRef -- warn $ "No propose transaction saved yet!" <+> pretty hashRef
tranBs <- MaybeT $ liftIO $ getBlock sto (fromHashRef hashRef) -- tranBs <- MaybeT $ liftIO $ getBlock sto (fromHashRef hashRef)
tran <- MaybeT $ pure $ deserialiseOrFail @(RefChanUpdate e) tranBs & either (const Nothing) Just -- tran <- MaybeT $ pure $ deserialiseOrFail @(RefChanUpdate e) tranBs & either (const Nothing) Just
headBlock <- MaybeT $ getActualRefChanHead @e refchanKey -- headBlock <- MaybeT $ getActualRefChanHead @e refchanKey
proposed <- MaybeT $ pure $ case tran of -- proposed <- MaybeT $ pure $ case tran of
Propose _ pbox -> Just pbox -- Propose _ pbox -> Just pbox
_ -> Nothing -- _ -> Nothing
(_, ptran) <- MaybeT $ pure $ unboxSignedBox0 @(ProposeTran e) @e proposed -- (_, ptran) <- MaybeT $ pure $ unboxSignedBox0 @(ProposeTran e) @e proposed
debug $ "ACCEPT FROM:" <+> pretty (AsBase58 peerKey) <+> pretty h0 -- debug $ "ACCEPT FROM:" <+> pretty (AsBase58 peerKey) <+> pretty h0
-- compiler bug? -- -- compiler bug?
let (ProposeTran _ pbox) = ptran -- let (ProposeTran _ pbox) = ptran
(authorKey, _) <- MaybeT $ pure $ unboxSignedBox0 pbox -- (authorKey, _) <- MaybeT $ pure $ unboxSignedBox0 pbox
-- может, и не надо второй раз проверять -- -- может, и не надо второй раз проверять
guard $ checkACL headBlock peerKey authorKey -- guard $ checkACL headBlock peerKey authorKey
debug $ "JUST GOT TRANSACTION FROM STORAGE! ABOUT TO CHECK IT" <+> pretty hashRef -- debug $ "JUST GOT TRANSACTION FROM STORAGE! ABOUT TO CHECK IT" <+> pretty hashRef
rcRound <- MaybeT $ find (RefChanRoundKey @e hashRef) id -- rcRound <- MaybeT $ find (RefChanRoundKey @e hashRef) id
atomically $ modifyTVar (view refChanRoundAccepts rcRound) (HashMap.insert peerKey ()) -- atomically $ modifyTVar (view refChanRoundAccepts rcRound) (HashMap.insert peerKey ())
-- TODO: garbage-collection-strongly-required -- -- TODO: garbage-collection-strongly-required
ha <- MaybeT $ liftIO $ putBlock sto (serialise msg) -- ha <- MaybeT $ liftIO $ putBlock sto (serialise msg)
atomically $ modifyTVar (view refChanRoundTrans rcRound) (HashSet.insert (HashRef ha)) -- atomically $ modifyTVar (view refChanRoundTrans rcRound) (HashSet.insert (HashRef ha))
-- atomically $ modifyTVar (view refChanRoundTrans rcRound) (HashSet.insert hashRef) -- propose just in case we missed it? -- -- atomically $ modifyTVar (view refChanRoundTrans rcRound) (HashSet.insert hashRef) -- propose just in case we missed it?
accepts <- atomically $ readTVar (view refChanRoundAccepts rcRound) <&> HashMap.size -- accepts <- atomically $ readTVar (view refChanRoundAccepts rcRound) <&> HashMap.size
debug $ "ACCEPTS:" <+> pretty accepts -- debug $ "ACCEPTS:" <+> pretty accepts
closed <- readTVarIO (view refChanRoundClosed rcRound) -- closed <- readTVarIO (view refChanRoundClosed rcRound)
-- FIXME: round! -- -- FIXME: round!
when (fromIntegral accepts >= view refChanHeadQuorum headBlock && not closed) do -- when (fromIntegral accepts >= view refChanHeadQuorum headBlock && not closed) do
debug $ "ROUND!" <+> pretty accepts <+> pretty hashRef -- debug $ "ROUND!" <+> pretty accepts <+> pretty hashRef
trans <- atomically $ readTVar (view refChanRoundTrans rcRound) <&> HashSet.toList -- trans <- atomically $ readTVar (view refChanRoundTrans rcRound) <&> HashSet.toList
forM_ trans $ \t -> do -- forM_ trans $ \t -> do
lift $ refChanWriteTran adapter t -- lift $ refChanWriteTran adapter t
debug $ "WRITING TRANS" <+> pretty t -- debug $ "WRITING TRANS" <+> pretty t
let pips = view refChanHeadPeers headBlock & HashMap.keys & HashSet.fromList -- let pips = view refChanHeadPeers headBlock & HashMap.keys & HashSet.fromList
votes <- readTVarIO (view refChanRoundAccepts rcRound) <&> HashSet.fromList . HashMap.keys -- votes <- readTVarIO (view refChanRoundAccepts rcRound) <&> HashSet.fromList . HashMap.keys
when (pips `HashSet.isSubsetOf` votes) do -- when (pips `HashSet.isSubsetOf` votes) do
debug $ "CLOSING ROUND" <+> pretty hashRef <+> pretty (length trans) -- debug $ "CLOSING ROUND" <+> pretty hashRef <+> pretty (length trans)
atomically $ writeTVar (view refChanRoundClosed rcRound) True -- atomically $ writeTVar (view refChanRoundClosed rcRound) True
-- lift $ refChanUpdateProto True pc adapter msg
where where
proto = Proxy @(RefChanUpdate e) proto = Proxy @(RefChanUpdate e)

51
hbs2-peer/app/PeerMain.hs
View File

@ -1135,31 +1135,36 @@ runPeer opts = U.handle (\e -> myException e
void $ liftIO $ async $ withPeerM penv $ do void $ liftIO $ async $ withPeerM penv $ do
gossip (RefChanRequest @e puk) gossip (RefChanRequest @e puk)
let arpc = RpcAdapter pokeAction let arpc = RpcAdapter
dieAction { rpcOnPoke = pokeAction
dontHandle , rpcOnDie = dieAction
dontHandle , rpcOnPokeAnswer = dontHandle
annAction , rpcOnPokeAnswerFull = dontHandle
pingAction , rpcOnAnnounce = annAction
dontHandle , rpcOnPing = pingAction
fetchAction , rpcOnPong = dontHandle
peersAction , rpcOnFetch = fetchAction
dontHandle , rpcOnPeers = peersAction
logLevelAction , rpcOnPeersAnswer = dontHandle
reflogUpdateAction , rpcOnPexInfo = pexInfoAction
reflogFetchAction , rpcOnPexInfoAnswer = dontHandle
reflogGetAction , rpcOnLogLevel = logLevelAction
dontHandle , rpcOnRefLogUpdate = reflogUpdateAction
refChanHeadSendAction -- rpcOnRefChanHeadSend , rpcOnRefLogFetch = reflogFetchAction
refChanHeadGetAction , rpcOnRefLogGet = reflogGetAction
dontHandle , rpcOnRefLogGetAnsw = dontHandle
refChanHeadFetchAction
refChanFetchAction , rpcOnRefChanHeadSend = refChanHeadSendAction
refChanGetAction , rpcOnRefChanHeadGet = refChanHeadGetAction
dontHandle -- rpcOnRefChanGetAnsw , rpcOnRefChanHeadGetAnsw = dontHandle
, rpcOnRefChanHeadFetch = refChanHeadFetchAction
refChanProposeAction , rpcOnRefChanFetch = refChanFetchAction
, rpcOnRefChanGet = refChanGetAction
, rpcOnRefChanGetAnsw = dontHandle -- rpcOnRefChanGetAnsw
, rpcOnRefChanPropose = refChanProposeAction
}
rpc <- async $ runRPC udp1 do rpc <- async $ runRPC udp1 do
runProto @e runProto @e

60
hbs2-peer/app/RPC.hs
View File

@ -289,42 +289,36 @@ withRPC o cmd = rpcClientMain o $ runResourceT do
rchangetMVar <- liftIO newEmptyMVar rchangetMVar <- liftIO newEmptyMVar
let adapter = let adapter = RpcAdapter
RpcAdapter dontHandle { rpcOnPoke = dontHandle
dontHandle , rpcOnDie = dontHandle
(liftIO . atomically . writeTQueue pokeQ) , rpcOnPokeAnswer = (liftIO . atomically . writeTQueue pokeQ)
(liftIO . atomically . writeTQueue pokeFQ) , rpcOnPokeAnswerFull = (liftIO . atomically . writeTQueue pokeFQ)
(const $ liftIO exitSuccess) , rpcOnAnnounce = (const $ liftIO exitSuccess)
(const $ notice "ping?") , rpcOnPing = (const $ notice "ping?")
(liftIO . atomically . writeTQueue pingQ) , rpcOnPong = (liftIO . atomically . writeTQueue pingQ)
dontHandle , rpcOnFetch = dontHandle
dontHandle , rpcOnPeers = dontHandle
, rpcOnPeersAnswer = (\(pa, k) -> Log.info $ pretty (AsBase58 k) <+> pretty pa)
, rpcOnPexInfo = dontHandle
, rpcOnPexInfoAnswer = dontHandle
, rpcOnLogLevel = dontHandle
, rpcOnRefLogUpdate = dontHandle
, rpcOnRefLogFetch = dontHandle
, rpcOnRefLogGet = dontHandle
, rpcOnRefLogGetAnsw = ( liftIO . atomically . writeTQueue refQ )
(\(pa, k) -> Log.info $ pretty (AsBase58 k) <+> pretty pa , rpcOnRefChanHeadSend = dontHandle
) , rpcOnRefChanHeadGet = dontHandle
, rpcOnRefChanHeadGetAnsw = (liftIO . putMVar rchanheadMVar)
, rpcOnRefChanHeadFetch = dontHandle
dontHandle , rpcOnRefChanFetch = dontHandle
dontHandle , rpcOnRefChanGet = dontHandle
dontHandle , rpcOnRefChanGetAnsw = (liftIO . putMVar rchangetMVar)
dontHandle
( liftIO . atomically . writeTQueue refQ )
dontHandle
dontHandle -- rpcOnRefChanHeadGet
(liftIO . putMVar rchanheadMVar) -- rpcOnRefChanHeadGetAnsw
dontHandle -- rpcOnRefChanHeadFetch
dontHandle -- rpcOnRefChanFetch
dontHandle -- rpcOnRefChanGet
(liftIO . putMVar rchangetMVar) -- rpcOnRefChanHeadGetAnsw
dontHandle -- rpcOnRefChanPropose
, rpcOnRefChanPropose = dontHandle
}
prpc <- async $ runRPC udp1 do prpc <- async $ runRPC udp1 do
env <- ask env <- ask