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 instance (Monad m, HasProtocol e p) => HasThatPeer e p (ResponseM e m) where
thatPeer _ = asks (view answTo) thatPeer _ = asks (view answTo)
instance HasProtocol e p => HasDeferred e p (ResponseM e (PeerM e IO)) where instance HasProtocol e p => HasDeferred p e (ResponseM e (PeerM e IO)) where
deferred _ action = do deferred action = do
who <- asks (view answTo) who <- asks (view answTo)
pip <- lift $ asks (view envDeferred) pip <- lift $ asks (view envDeferred)
env <- lift ask env <- lift ask

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

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

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

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

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

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

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

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

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

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

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

13
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 refLogRequestProto :: forall e s m . ( MonadIO m
, Request e (RefLogRequest e) m , Request e (RefLogRequest e) m
, Response e (RefLogRequest e) m , Response e (RefLogRequest e) m
, HasDeferred e (RefLogRequest e) m , HasDeferred (RefLogRequest e) e m
, Sessions e (KnownPeer e) m , Sessions e (KnownPeer e) m
, IsPeerAddr e m , IsPeerAddr e m
, Pretty (AsBase58 (PubKey 'Sign (Encryption e))) , Pretty (AsBase58 (PubKey 'Sign (Encryption e)))
@ -200,10 +200,10 @@ refLogRequestProto adapter cmd = do
where where
proto = Proxy @(RefLogRequest e) proto = Proxy @(RefLogRequest e)
refLogUpdateProto :: forall e s m . ( MonadIO m refLogUpdateProto :: forall e s m proto . ( MonadIO m
, Request e (RefLogUpdate e) m , Request e proto m
, Response e (RefLogUpdate e) m , Response e proto m
, HasDeferred e (RefLogUpdate e) m , HasDeferred proto e m
, HasGossip e (RefLogUpdate e) m , HasGossip e (RefLogUpdate e) m
, IsPeerAddr e m , IsPeerAddr e m
, Pretty (Peer e) , Pretty (Peer e)
@ -213,6 +213,7 @@ refLogUpdateProto :: forall e s m . ( MonadIO m
, Pretty (AsBase58 (PubKey 'Sign s)) , Pretty (AsBase58 (PubKey 'Sign s))
, EventEmitter e (RefLogUpdateEv e) m , EventEmitter e (RefLogUpdateEv e) m
, s ~ Encryption e , s ~ Encryption e
, proto ~ RefLogUpdate e
) )
=> RefLogUpdate e -> m () => RefLogUpdate e -> m ()
@ -232,7 +233,7 @@ refLogUpdateProto =
trace "RefLogUpdate is signed properly" trace "RefLogUpdate is signed properly"
-- FIXME: refactor:use-type-application-for-deferred -- FIXME: refactor:use-type-application-for-deferred
deferred proto do deferred @proto do
emit @e RefLogUpdateEvKey (RefLogUpdateEvData (pubk, e, Just p)) emit @e RefLogUpdateEvKey (RefLogUpdateEvData (pubk, e, Just p))
gossip e gossip e

11
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 :: r -> ReaderT r m a -> m a
runWithContext co m = runReaderT m co runWithContext co m = runReaderT m co
makeServer :: forall api e m . ( MonadIO m makeServer :: forall api e m proto . ( MonadIO m
, EnumAll api (Int, SomeHandler m) m , EnumAll api (Int, SomeHandler m) m
, Response e (ServiceProto api e) m , Response e (ServiceProto api e) m
, HasProtocol e (ServiceProto api e) , HasProtocol e proto
, HasDeferred e (ServiceProto api e) m , HasDeferred proto e m
, Pretty (Peer e) , Pretty (Peer e)
, proto ~ ServiceProto api e
) )
=> ServiceProto api e => ServiceProto api e
-> m () -> m ()
makeServer msg = do makeServer msg = do
deferred proxy $ dispatch @api @e msg >>= response deferred @proto $ dispatch @api @e msg >>= response
where
proxy = Proxy @(ServiceProto api e)
data ServiceCaller api e = data ServiceCaller api e =
ServiceCaller 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) toPeerAddr :: Peer e -> m (PeerAddr e)
fromPeerAddr :: PeerAddr e -> m (Peer 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 class (Monad m, HasProtocol e p) => HasThatPeer e p (m :: Type -> Type) where
thatPeer :: Proxy p -> m (Peer e) thatPeer :: Proxy p -> m (Peer e)
class (MonadIO m, HasProtocol e p) => HasDeferred e p m | p -> e where class (MonadIO m, HasProtocol e p) => HasDeferred p e m | p -> e where
deferred :: Proxy p -> m () -> m () deferred :: m () -> m ()
-- TODO: actually-no-idea-if-it-works -- TODO: actually-no-idea-if-it-works
instance (HasDeferred e p m, Monad m) => HasDeferred e p (MaybeT m) where instance (HasDeferred p e m, Monad m) => HasDeferred p e (MaybeT m) where
deferred p a = lift $ deferred p (void $ runMaybeT a) deferred a = lift $ deferred @p (void $ runMaybeT a)
class ( MonadIO m class ( MonadIO m
, HasProtocol e p , HasProtocol e p

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

@ -550,8 +550,8 @@ instance ( Monad m
response = lift . response response = lift . response
instance (MonadUnliftIO m, HasProtocol UNIX (NotifyProto ev e)) => HasDeferred UNIX (NotifyProto ev e) m where instance (MonadUnliftIO m, HasProtocol UNIX (NotifyProto ev e)) => HasDeferred (NotifyProto ev e) UNIX m where
deferred _ m = void $ async m deferred m = void $ async m
respawn :: PeerOpts -> IO () respawn :: PeerOpts -> IO ()
respawn opts = 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 ) ownPeer = asks ( msgUnixSelf . rpcMessaging )
instance (MonadUnliftIO m, HasProtocol UNIX (ServiceProto (api :: [Type]) UNIX)) instance (MonadUnliftIO m, HasProtocol UNIX (ServiceProto (api :: [Type]) UNIX))
=> HasDeferred UNIX (ServiceProto api UNIX) m where => HasDeferred (ServiceProto api UNIX) UNIX m where
deferred _ m = void $ async m deferred m = void $ async m

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

@ -61,20 +61,21 @@ testCmd p1 s p2 = do
<+> s <+> s
<+> parens (pretty p2) <+> parens (pretty p2)
pingPongHandler :: forall e m . ( MonadIO m pingPongHandler :: forall e m proto . ( MonadIO m
, Response e (PingPong e) m , Response e (PingPong e) m
, HasProtocol e (PingPong e) , HasProtocol e (PingPong e)
, HasOwnPeer e m , HasOwnPeer e m
, HasDeferred e (PingPong e) m , HasDeferred proto e m
, Pretty (Peer e) , Pretty (Peer e)
, proto ~ PingPong e
) )
=> Int => Int
-> PingPong e -> PingPong e
-> m () -> m ()
pingPongHandler n req = do pingPongHandler _ req = do
that <- thatPeer (Proxy @(PingPong e)) that <- thatPeer (Proxy @proto)
own <- ownPeer @e own <- ownPeer @e
case req of case req of
@ -82,7 +83,7 @@ pingPongHandler n req = do
Ping c -> do Ping c -> do
testCmd own ("RECV PING <<<" <+> pretty c) that testCmd own ("RECV PING <<<" <+> pretty c) that
deferred (Proxy @(PingPong e)) do deferred @proto do
pause @'Seconds 1 pause @'Seconds 1
testCmd own ("SEND PONG >>>" <+> pretty (succ c)) that testCmd own ("SEND PONG >>>" <+> pretty (succ c)) that
response (Pong @e (succ c)) response (Pong @e (succ c))
@ -90,7 +91,7 @@ pingPongHandler n req = do
Pong c -> do Pong c -> do
testCmd own ("RECV PONG <<<" <+> pretty c) that testCmd own ("RECV PONG <<<" <+> pretty c) that
deferred (Proxy @(PingPong e)) do deferred @proto do
pause @'Seconds 1 pause @'Seconds 1
testCmd own ("SEND PING >>>" <+> pretty (succ c)) that testCmd own ("SEND PING >>>" <+> pretty (succ c)) that
response (Ping @e c) response (Ping @e c)
@ -125,8 +126,8 @@ instance HasTimeLimits L4Proto (PingPong L4Proto) IO where
tryLockForPeriod _ _ = pure True tryLockForPeriod _ _ = pure True
instance HasDeferred L4Proto (PingPong L4Proto) (ResponseM L4Proto (PingPongM L4Proto IO)) where instance HasDeferred (PingPong L4Proto) L4Proto (ResponseM L4Proto (PingPongM L4Proto IO)) where
deferred _ m = do deferred m = do
self <- lift $ asks (view ppSelf) self <- lift $ asks (view ppSelf)
bus <- lift $ asks (view ppFab) bus <- lift $ asks (view ppFab)
who <- thatPeer (Proxy @(PingPong L4Proto)) 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 decode = either (const Nothing) Just . deserialiseOrFail
encode = serialise encode = serialise
instance (MonadUnliftIO m, HasProtocol UNIX (NotifyProto ev e)) => HasDeferred UNIX (NotifyProto ev e) m where instance (MonadUnliftIO m, HasProtocol UNIX (NotifyProto ev e)) => HasDeferred (NotifyProto ev e) UNIX m where
deferred _ m = void $ async m deferred m = void $ async m
data WhatTick = Odd | Even data WhatTick = Odd | Even
deriving stock (Generic,Eq) deriving stock (Generic,Eq)