mirror of https://github.com/voidlizard/hbs2
79 lines
2.8 KiB
Haskell
79 lines
2.8 KiB
Haskell
{-# Language UndecidableInstances #-}
|
|
{-# Language AllowAmbiguousTypes #-}
|
|
module HBS2.Peer.Proto.RefChan.RefChanHead where
|
|
|
|
import HBS2.Prelude.Plated
|
|
import HBS2.Net.Proto
|
|
import HBS2.Net.Auth.Credentials
|
|
import HBS2.Base58
|
|
import HBS2.Peer.Proto.Peer
|
|
import HBS2.Peer.Proto.BlockAnnounce
|
|
import HBS2.Peer.Proto.RefChan.Adapter
|
|
import HBS2.Net.Proto.Sessions
|
|
import HBS2.Data.Types.Refs
|
|
import HBS2.Storage
|
|
|
|
import HBS2.Peer.Proto.RefChan.Types
|
|
|
|
import HBS2.System.Logger.Simple
|
|
|
|
import Control.Monad.Trans.Maybe
|
|
import Data.Maybe
|
|
|
|
|
|
refChanHeadProto :: forall e s m proto . ( MonadIO m
|
|
, Request e proto m
|
|
, Response e proto m
|
|
, Request e (BlockAnnounce e) m
|
|
, HasPeerNonce e m
|
|
, HasDeferred proto e m
|
|
, IsPeerAddr e m
|
|
, Pretty (Peer e)
|
|
, Sessions e (KnownPeer e) m
|
|
, HasStorage m
|
|
, Signatures s
|
|
, IsRefPubKey s
|
|
, s ~ Encryption e
|
|
, proto ~ RefChanHead e
|
|
)
|
|
=> Bool
|
|
-> RefChanAdapter e m
|
|
-> RefChanHead e
|
|
-> m ()
|
|
|
|
refChanHeadProto self adapter msg = do
|
|
-- авторизовать пира
|
|
peer <- thatPeer @proto
|
|
|
|
auth <- find (KnownPeerKey peer) id <&> isJust
|
|
|
|
no <- peerNonce @e
|
|
|
|
void $ runMaybeT do
|
|
|
|
guard (auth || self)
|
|
|
|
case msg of
|
|
RefChanHead chan pkt -> do
|
|
guard =<< lift (refChanSubscribed adapter chan)
|
|
trace $ "RefChanHead" <+> pretty self <+> pretty (AsBase58 chan)
|
|
-- TODO: notify-others-for-new-head
|
|
-- нужно ли уведомить остальных, что голова поменялась?
|
|
-- всех, от кого мы еще не получали данное сообщение
|
|
-- откуда мы знаем, от кого мы получали данное сообщение?
|
|
lift $ refChanOnHead adapter chan pkt
|
|
|
|
RefChanGetHead chan -> deferred @proto do
|
|
trace $ "RefChanGetHead" <+> pretty self <+> pretty (AsBase58 chan)
|
|
|
|
sto <- getStorage
|
|
ref <- MaybeT $ liftIO $ getRef sto (RefChanHeadKey @s chan)
|
|
sz <- MaybeT $ liftIO $ hasBlock sto ref
|
|
|
|
let annInfo = BlockAnnounceInfo 0 NoBlockInfoMeta sz ref
|
|
let announce = BlockAnnounce @e no annInfo
|
|
lift $ request peer announce
|
|
lift $ request peer (RefChanHead @e chan (RefChanHeadBlockTran (HashRef ref)))
|
|
|
|
|