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

refactor: removing Proxy in HasDeferred

This commit is contained in:
Dmitry Zuikov 2023-12-27 06:48:18 +03:00
parent f0d469766e
commit 5820b808c5
14 changed files with 162 additions and 179 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
hbs2-core/lib/HBS2/Actors/Peer.hs
View File

@ -455,8 +455,8 @@ runProto hh = do
instance (Monad m, HasProtocol e p) => HasThatPeer e p (ResponseM e m) where
thatPeer _ = asks (view answTo)
instance HasProtocol e p => HasDeferred e p (ResponseM e (PeerM e IO)) where
deferred _ action = do
instance HasProtocol e p => HasDeferred p e (ResponseM e (PeerM e IO)) where
deferred action = do
who <- asks (view answTo)
pip <- lift $ asks (view envDeferred)
env <- lift ask

41
hbs2-core/lib/HBS2/Net/Proto/BlockChunks.hs
View File

@ -3,7 +3,6 @@ module HBS2.Net.Proto.BlockChunks where
import HBS2.Events
import HBS2.Hash
import HBS2.Clock
import HBS2.Net.Proto
import HBS2.Net.Proto.Peer
import HBS2.Prelude.Plated
@ -11,15 +10,10 @@ import HBS2.Storage
import HBS2.Actors.Peer
import HBS2.Net.Proto.Sessions
import Data.Functor
import Data.Word
import Prettyprinter
import Data.ByteString.Lazy (ByteString)
import Data.Foldable hiding (find)
import Data.Maybe
import System.Random.Shuffle
newtype ChunkSize = ChunkSize Word16
deriving newtype (Num,Enum,Real,Integral,Pretty)
deriving stock (Eq,Ord,Show,Data,Generic)
@ -82,13 +76,14 @@ data instance Event e (BlockChunks e) =
| BlockChunksLost (Hash HbSync)
deriving stock (Typeable)
blockChunksProto :: forall e m . ( MonadIO m
, Response e (BlockChunks e) m
, HasDeferred e (BlockChunks e) m
, HasOwnPeer e m
, Sessions e (KnownPeer e) m
, Pretty (Peer e)
)
blockChunksProto :: forall e m proto . ( MonadIO m
, Response e (BlockChunks e) m
, HasDeferred (BlockChunks e) e m
, HasOwnPeer e m
, Sessions e (KnownPeer e) m
, Pretty (Peer e)
, proto ~ BlockChunks e
)
=> BlockChunksI e m
-> BlockChunks e
-> m ()
@ -109,21 +104,12 @@ blockChunksProto adapter (BlockChunks c p) = do
let offsets' = calcChunks bsz (fromIntegral size) :: [(Offset, Size)]
let offsets = take (fromIntegral num) $ drop (fromIntegral n1) $ zip offsets' [0..]
-- liftIO $ print $ "sending " <+> pretty (length offsets)
-- <+> "chunks for block"
-- <+> pretty h
-- for_ offsets $ \((o,sz),i) -> deferred proto do
for_ offsets $ \((o,sz),i) -> deferred proto do
-- liftIO $ print $ "send chunk " <+> pretty i <+> pretty sz
for_ offsets $ \((o,sz),i) -> deferred @proto do
chunk <- blkChunk adapter h o sz
maybe (pure ()) (response_ . BlockChunk @e i) chunk
BlockGetAllChunks h size | auth -> do
me <- ownPeer @e
who <- thatPeer proto
bsz' <- blkSize adapter h
maybe1 bsz' (pure ()) $ \bsz -> do
@ -131,17 +117,12 @@ blockChunksProto adapter (BlockChunks c p) = do
let offsets' = calcChunks bsz (fromIntegral size) :: [(Offset, Size)]
let offsets = zip offsets' [0..]
-- liftIO $ print $ "sending " <+> pretty (length offsets)
-- <+> "chunks for block"
-- <+> pretty h
for_ offsets $ \((o,sz),i) -> deferred proto do
for_ offsets $ \((o,sz),i) -> deferred @proto do
chunk <- blkChunk adapter h o sz
maybe (pure ()) (response_ . BlockChunk @e i) chunk
BlockChunk n bs | auth -> deferred proto do
BlockChunk n bs | auth -> deferred @(BlockChunks e) do
who <- thatPeer proto
me <- ownPeer @e
h <- blkGetHash adapter (who, c)
maybe1 h (response_ (BlockLost @e)) $ \hh -> do

16
hbs2-core/lib/HBS2/Net/Proto/BlockInfo.hs
View File

@ -7,7 +7,6 @@ import HBS2.Net.Proto.Sessions
import HBS2.Events
import HBS2.Hash
import Data.Functor
import Data.Maybe
data BlockInfo e = GetBlockSize (Hash HbSync)
@ -20,12 +19,13 @@ type HasBlockEvent h e m = (Peer e, Hash h, Maybe Integer) -> m ()
instance Serialise (BlockInfo e)
blockSizeProto :: forall e m . ( MonadIO m
, Response e (BlockInfo e) m
, HasDeferred e (BlockInfo e) m
, EventEmitter e (BlockInfo e) m
, Sessions e (KnownPeer e) m
)
blockSizeProto :: forall e m proto . ( MonadIO m
, Response e proto m
, HasDeferred proto e m
, EventEmitter e proto m
, Sessions e (KnownPeer e) m
, proto ~ BlockInfo e
)
=> GetBlockSize HbSync m
-> HasBlockEvent HbSync e m
-> ( (Peer e, Hash HbSync) -> m () )
@ -40,7 +40,7 @@ blockSizeProto getBlockSize evHasBlock onNoBlock =
p <- thatPeer (Proxy @(BlockInfo e))
auth <- find (KnownPeerKey p) id <&> isJust
when auth do
deferred (Proxy @(BlockInfo e))$ do
deferred @proto $ do
getBlockSize h >>= \case
Just size -> response (BlockSize @e h size)
Nothing -> do

17
hbs2-core/lib/HBS2/Net/Proto/Notify.hs
View File

@ -104,22 +104,21 @@ newNotifyEnvServer src = NotifyEnv src <$> newTVarIO mempty
<*> newTVarIO mempty
<*> newTQueueIO
makeNotifyServer :: forall ev src e m . ( MonadIO m
, Response e (NotifyProto ev e) m
, NotifySource ev src
, HasDeferred e (NotifyProto ev e) m
, Pretty (Peer e)
)
makeNotifyServer :: forall ev src e m proto . ( MonadIO m
, Response e proto m
, NotifySource ev src
, HasDeferred proto e m
, Pretty (Peer e)
, proto ~ NotifyProto ev e
)
=> NotifyEnv ev src e
-> NotifyProto ev e
-> m ()
makeNotifyServer (NotifyEnv{..}) what = do
let proxy = Proxy @(NotifyProto ev e)
case what of
NotifyWant rn key -> deferred proxy do
NotifyWant rn key -> deferred @proto do
debug "SERVER: NotifyWant"

29
hbs2-core/lib/HBS2/Net/Proto/PeerExchange.hs
View File

@ -54,19 +54,20 @@ sendPeerExchangeGet pip = do
request pip (PeerExchangeGet @e nonce)
request pip (PeerExchangeGet2 @e nonce)
peerExchangeProto :: forall e m . ( MonadIO m
, Response e (PeerExchange e) m
, HasPeerLocator e m
, HasDeferred e (PeerExchange e) m
, HasNonces (PeerExchange e) m
, IsPeerAddr e m
, Sessions e (KnownPeer e) m
, Sessions e (PeerExchange e) m
, EventEmitter e (PeerExchangePeersEv e) m
, Eq (Nonce (PeerExchange e))
, Pretty (Peer e)
, e ~ L4Proto
)
peerExchangeProto :: forall e m proto . ( MonadIO m
, Response e proto m
, HasPeerLocator e m
, HasDeferred proto e m
, HasNonces proto m
, IsPeerAddr e m
, Sessions e (KnownPeer e) m
, Sessions e proto m
, EventEmitter e (PeerExchangePeersEv e) m
, Eq (Nonce proto)
, Pretty (Peer e)
, e ~ L4Proto
, proto ~ PeerExchange e
)
=> PeerExchange e
-> m ()
@ -104,7 +105,7 @@ peerExchangeProto msg = do
expire @e (PeerExchangeKey nonce)
emit @e PeerExchangePeersKey (PeerExchangePeersData sa)
peerExchangeGet pex n = deferred proto do
peerExchangeGet pex n = deferred @proto do
that <- thatPeer proto
debug $ "PeerExchangeGet" <+> "from" <+> pretty that

17
hbs2-core/lib/HBS2/Net/Proto/PeerMeta.hs
View File

@ -27,13 +27,14 @@ data PeerMetaProto e
instance Serialise (PeerMetaProto e)
peerMetaProto :: forall e m . ( MonadIO m
, Response e (PeerMetaProto e) m
, HasDeferred e (PeerMetaProto e) m
, EventEmitter e (PeerMetaProto e) m
, Sessions e (KnownPeer e) m
, Pretty (Peer e)
)
peerMetaProto :: forall e m proto . ( MonadIO m
, Response e proto m
, HasDeferred proto e m
, EventEmitter e proto m
, Sessions e (KnownPeer e) m
, Pretty (Peer e)
, proto ~ PeerMetaProto e
)
=> AnnMetaData
-> PeerMetaProto e
-> m ()
@ -45,7 +46,7 @@ peerMetaProto peerMeta =
auth <- find (KnownPeerKey p) id <&> isJust
when auth do
debug $ "PEER META: ANSWERING" <+> pretty p <+> viaShow peerMeta
deferred (Proxy @(PeerMetaProto e)) do
deferred @proto do
response (ThePeerMeta @e peerMeta)
ThePeerMeta meta -> do

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

@ -389,21 +389,22 @@ instance HasRefChanId e (RefChanNotify e) where
instance HasRefChanId e (RefChanValidate e) where
getRefChanId = rcvChan
refChanHeadProto :: forall e s m . ( MonadIO m
, Request e (RefChanHead e) m
, Request e (BlockAnnounce e) m
, Response e (RefChanHead e) m
, HasPeerNonce e m
, HasDeferred e (RefChanHead e) m
, IsPeerAddr e m
, Pretty (Peer e)
, Sessions e (KnownPeer e) m
, HasStorage m
, Signatures s
, IsRefPubKey s
, Pretty (AsBase58 (PubKey 'Sign s))
, s ~ Encryption e
)
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
, Pretty (AsBase58 (PubKey 'Sign s))
, s ~ Encryption e
, proto ~ RefChanHead e
)
=> Bool
-> RefChanAdapter e m
-> RefChanHead e
@ -431,7 +432,7 @@ refChanHeadProto self adapter msg = do
-- откуда мы знаем, от кого мы получали данное сообщение?
lift $ refChanOnHead adapter chan pkt
RefChanGetHead chan -> deferred proto do
RefChanGetHead chan -> deferred @proto do
trace $ "RefChanGetHead" <+> pretty self <+> pretty (AsBase58 chan)
sto <- getStorage
@ -447,26 +448,25 @@ refChanHeadProto self adapter msg = do
proto = Proxy @(RefChanHead e)
refChanUpdateProto :: forall e s m . ( MonadIO m
, MonadUnliftIO m
, Request e (RefChanUpdate e) m
, Response e (RefChanUpdate e) m
, HasDeferred e (RefChanUpdate e) m
, IsPeerAddr e m
, Pretty (Peer e)
, Sessions e (KnownPeer e) m
, Sessions e (RefChanHeadBlock e) m
, Sessions e (RefChanRound e) m
, EventEmitter e (RefChanRound e) m
, HasStorage m
, HasGossip e (RefChanUpdate e) m
, Signatures s
, IsRefPubKey s
, Pretty (AsBase58 (PubKey 'Sign s))
-- , Serialise (Signature s)
, ForRefChans e
, s ~ Encryption e
)
refChanUpdateProto :: forall e s m proto . ( MonadIO m
, MonadUnliftIO m
, Request e proto m
, Response e proto m
, HasDeferred proto e m
, IsPeerAddr e m
, Pretty (Peer e)
, Sessions e (KnownPeer e) m
, Sessions e (RefChanHeadBlock e) m
, Sessions e (RefChanRound e) m
, EventEmitter e (RefChanRound e) m
, HasStorage m
, HasGossip e proto m
, Signatures s
, IsRefPubKey s
, ForRefChans e
, s ~ Encryption e
, proto ~ RefChanUpdate e
)
=> Bool
-> PeerCredentials s
-> RefChanAdapter e m
@ -509,7 +509,7 @@ refChanUpdateProto self pc adapter msg = do
debug $ "RefChanUpdate/Propose" <+> pretty h0
deferred proto do
deferred @proto do
-- проверили подпись пира
(peerKey, ProposeTran headRef abox) <- MaybeT $ pure $ unboxSignedBox0 box
@ -628,7 +628,7 @@ refChanUpdateProto self pc adapter msg = do
-- -- рассылаем ли себе? что бы был хоть один accept
lift $ refChanUpdateProto True pc adapter accept
Accept chan box -> deferred proto do
Accept chan box -> deferred @proto do
-- что если получили ACCEPT раньше PROPOSE ?
-- что если PROPOSE еще обрабатывается?
@ -768,7 +768,7 @@ checkACL theHead mbPeerKey authorKey = match
refChanRequestProto :: forall e s m . ( MonadIO m
, Request e (RefChanRequest e) m
, Response e (RefChanRequest e) m
, HasDeferred e (RefChanRequest e) m
, HasDeferred (RefChanRequest e) e m
, IsPeerAddr e m
, Pretty (Peer e)
, Sessions e (KnownPeer e) m
@ -778,7 +778,6 @@ refChanRequestProto :: forall e s m . ( MonadIO m
, Signatures s
, IsRefPubKey s
, Pretty (AsBase58 (PubKey 'Sign s))
-- , Serialise (Signature s)
, ForRefChans e
, s ~ Encryption e
)
@ -841,24 +840,24 @@ instance Expires (EventKey e (RefChanNotify e)) where
refChanNotifyProto :: forall e s m . ( MonadIO m
, Request e (RefChanNotify e) m
, Response e (RefChanNotify e) m
, HasRefChanId e (RefChanNotify e)
, HasDeferred e (RefChanNotify e) m
, HasGossip e (RefChanNotify e) m
, IsPeerAddr e m
, Pretty (Peer e)
, Sessions e (RefChanHeadBlock e) m
, Sessions e (KnownPeer e) m
, EventEmitter e (RefChanNotify e) m
, HasStorage m
, Signatures s
, IsRefPubKey s
, ForRefChans e
, Pretty (AsBase58 (PubKey 'Sign s))
, s ~ Encryption e
)
refChanNotifyProto :: forall e s m proto . ( MonadIO m
, Request e proto m
, Response e proto m
, HasRefChanId e proto
, HasDeferred proto e m
, HasGossip e proto m
, IsPeerAddr e m
, Pretty (Peer e)
, Sessions e (RefChanHeadBlock e) m
, Sessions e (KnownPeer e) m
, EventEmitter e proto m
, HasStorage m
, Signatures s
, IsRefPubKey s
, ForRefChans e
, s ~ Encryption e
, proto ~ RefChanNotify e
)
=> Bool
-> RefChanAdapter e m
-> RefChanNotify e
@ -889,7 +888,7 @@ refChanNotifyProto self adapter msg@(Notify rchan box) = do
debug $ "&&& refChanNotifyProto" <+> pretty self
deferred proto do
deferred @proto do
guard =<< liftIO (hasBlock sto h0 <&> isNothing)

33
hbs2-core/lib/HBS2/Net/Proto/RefLog.hs
View File

@ -165,7 +165,7 @@ data RefLogRequestI e m =
refLogRequestProto :: forall e s m . ( MonadIO m
, Request e (RefLogRequest e) m
, Response e (RefLogRequest e) m
, HasDeferred e (RefLogRequest e) m
, HasDeferred (RefLogRequest e) e m
, Sessions e (KnownPeer e) m
, IsPeerAddr e m
, Pretty (AsBase58 (PubKey 'Sign (Encryption e)))
@ -200,20 +200,21 @@ refLogRequestProto adapter cmd = do
where
proto = Proxy @(RefLogRequest e)
refLogUpdateProto :: forall e s m . ( MonadIO m
, Request e (RefLogUpdate e) m
, Response e (RefLogUpdate e) m
, HasDeferred e (RefLogUpdate e) m
, HasGossip e (RefLogUpdate e) m
, IsPeerAddr e m
, Pretty (Peer e)
, Nonce (RefLogUpdate e) ~ ByteString
, Sessions e (KnownPeer e) m
, Signatures s
, Pretty (AsBase58 (PubKey 'Sign s))
, EventEmitter e (RefLogUpdateEv e) m
, s ~ Encryption e
)
refLogUpdateProto :: forall e s m proto . ( MonadIO m
, Request e proto m
, Response e proto m
, HasDeferred proto e m
, HasGossip e (RefLogUpdate e) m
, IsPeerAddr e m
, Pretty (Peer e)
, Nonce (RefLogUpdate e) ~ ByteString
, Sessions e (KnownPeer e) m
, Signatures s
, Pretty (AsBase58 (PubKey 'Sign s))
, EventEmitter e (RefLogUpdateEv e) m
, s ~ Encryption e
, proto ~ RefLogUpdate e
)
=> RefLogUpdate e -> m ()
refLogUpdateProto =
@ -232,7 +233,7 @@ refLogUpdateProto =
trace "RefLogUpdate is signed properly"
-- FIXME: refactor:use-type-application-for-deferred
deferred proto do
deferred @proto do
emit @e RefLogUpdateEvKey (RefLogUpdateEvData (pubk, e, Just p))
gossip e

19
hbs2-core/lib/HBS2/Net/Proto/Service.hs
View File

@ -131,20 +131,19 @@ makeRequestR input = do
runWithContext :: r -> ReaderT r m a -> m a
runWithContext co m = runReaderT m co
makeServer :: forall api e m . ( MonadIO m
, EnumAll api (Int, SomeHandler m) m
, Response e (ServiceProto api e) m
, HasProtocol e (ServiceProto api e)
, HasDeferred e (ServiceProto api e) m
, Pretty (Peer e)
)
makeServer :: forall api e m proto . ( MonadIO m
, EnumAll api (Int, SomeHandler m) m
, Response e (ServiceProto api e) m
, HasProtocol e proto
, HasDeferred proto e m
, Pretty (Peer e)
, proto ~ ServiceProto api e
)
=> ServiceProto api e
-> m ()
makeServer msg = do
deferred proxy $ dispatch @api @e msg >>= response
where
proxy = Proxy @(ServiceProto api e)
deferred @proto $ dispatch @api @e msg >>= response
data ServiceCaller api e =
ServiceCaller

9
hbs2-core/lib/HBS2/Net/Proto/Types.hs
View File

@ -110,15 +110,16 @@ class ( Eq (PeerAddr e)
toPeerAddr :: Peer e -> m (PeerAddr e)
fromPeerAddr :: PeerAddr e -> m (Peer e)
-- FIXME: type-application-instead-of-proxy
class (Monad m, HasProtocol e p) => HasThatPeer e p (m :: Type -> Type) where
thatPeer :: Proxy p -> m (Peer e)
class (MonadIO m, HasProtocol e p) => HasDeferred e p m | p -> e where
deferred :: Proxy p -> m () -> m ()
class (MonadIO m, HasProtocol e p) => HasDeferred p e m | p -> e where
deferred :: m () -> m ()
-- TODO: actually-no-idea-if-it-works
instance (HasDeferred e p m, Monad m) => HasDeferred e p (MaybeT m) where
deferred p a = lift $ deferred p (void $ runMaybeT a)
instance (HasDeferred p e m, Monad m) => HasDeferred p e (MaybeT m) where
deferred a = lift $ deferred @p (void $ runMaybeT a)
class ( MonadIO m
, HasProtocol e p

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

@ -550,8 +550,8 @@ instance ( Monad m
response = lift . response
instance (MonadUnliftIO m, HasProtocol UNIX (NotifyProto ev e)) => HasDeferred UNIX (NotifyProto ev e) m where
deferred _ m = void $ async m
instance (MonadUnliftIO m, HasProtocol UNIX (NotifyProto ev e)) => HasDeferred (NotifyProto ev e) UNIX m where
deferred m = void $ async m
respawn :: PeerOpts -> IO ()
respawn opts =

4
hbs2-peer/lib/HBS2/Peer/RPC/Internal/Types.hs
View File

@ -46,7 +46,7 @@ instance Monad m => HasOwnPeer UNIX (ReaderT RPC2Context m) where
ownPeer = asks ( msgUnixSelf . rpcMessaging )
instance (MonadUnliftIO m, HasProtocol UNIX (ServiceProto (api :: [Type]) UNIX))
=> HasDeferred UNIX (ServiceProto api UNIX) m where
deferred _ m = void $ async m
=> HasDeferred (ServiceProto api UNIX) UNIX m where
deferred m = void $ async m

27
hbs2-tests/test/TestTCPNet.hs
View File

@ -61,20 +61,21 @@ testCmd p1 s p2 = do
<+> s
<+> parens (pretty p2)
pingPongHandler :: forall e m . ( MonadIO m
, Response e (PingPong e) m
, HasProtocol e (PingPong e)
, HasOwnPeer e m
, HasDeferred e (PingPong e) m
, Pretty (Peer e)
)
pingPongHandler :: forall e m proto . ( MonadIO m
, Response e (PingPong e) m
, HasProtocol e (PingPong e)
, HasOwnPeer e m
, HasDeferred proto e m
, Pretty (Peer e)
, proto ~ PingPong e
)
=> Int
-> PingPong e
-> m ()
pingPongHandler n req = do
pingPongHandler _ req = do
that <- thatPeer (Proxy @(PingPong e))
that <- thatPeer (Proxy @proto)
own <- ownPeer @e
case req of
@ -82,7 +83,7 @@ pingPongHandler n req = do
Ping c -> do
testCmd own ("RECV PING <<<" <+> pretty c) that
deferred (Proxy @(PingPong e)) do
deferred @proto do
pause @'Seconds 1
testCmd own ("SEND PONG >>>" <+> pretty (succ c)) that
response (Pong @e (succ c))
@ -90,7 +91,7 @@ pingPongHandler n req = do
Pong c -> do
testCmd own ("RECV PONG <<<" <+> pretty c) that
deferred (Proxy @(PingPong e)) do
deferred @proto do
pause @'Seconds 1
testCmd own ("SEND PING >>>" <+> pretty (succ c)) that
response (Ping @e c)
@ -125,8 +126,8 @@ instance HasTimeLimits L4Proto (PingPong L4Proto) IO where
tryLockForPeriod _ _ = pure True
instance HasDeferred L4Proto (PingPong L4Proto) (ResponseM L4Proto (PingPongM L4Proto IO)) where
deferred _ m = do
instance HasDeferred (PingPong L4Proto) L4Proto (ResponseM L4Proto (PingPongM L4Proto IO)) where
deferred m = do
self <- lift $ asks (view ppSelf)
bus <- lift $ asks (view ppFab)
who <- thatPeer (Proxy @(PingPong L4Proto))

4
hbs2-tests/test/notify-unix/Main.hs
View File

@ -38,8 +38,8 @@ instance HasProtocol UNIX (NotifyProto Tick UNIX) where
decode = either (const Nothing) Just . deserialiseOrFail
encode = serialise
instance (MonadUnliftIO m, HasProtocol UNIX (NotifyProto ev e)) => HasDeferred UNIX (NotifyProto ev e) m where
deferred _ m = void $ async m
instance (MonadUnliftIO m, HasProtocol UNIX (NotifyProto ev e)) => HasDeferred (NotifyProto ev e) UNIX m where
deferred m = void $ async m
data WhatTick = Odd | Even
deriving stock (Generic,Eq)