From 5820b808c50e6267739624414ace85b7d0272260 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Wed, 27 Dec 2023 06:48:18 +0300 Subject: [PATCH] refactor: removing Proxy in HasDeferred --- hbs2-core/lib/HBS2/Actors/Peer.hs | 4 +- hbs2-core/lib/HBS2/Net/Proto/BlockChunks.hs | 41 ++---- hbs2-core/lib/HBS2/Net/Proto/BlockInfo.hs | 16 +-- hbs2-core/lib/HBS2/Net/Proto/Notify.hs | 17 ++- hbs2-core/lib/HBS2/Net/Proto/PeerExchange.hs | 29 ++--- hbs2-core/lib/HBS2/Net/Proto/PeerMeta.hs | 17 +-- hbs2-core/lib/HBS2/Net/Proto/RefChan.hs | 117 +++++++++--------- hbs2-core/lib/HBS2/Net/Proto/RefLog.hs | 33 ++--- hbs2-core/lib/HBS2/Net/Proto/Service.hs | 19 ++- hbs2-core/lib/HBS2/Net/Proto/Types.hs | 9 +- hbs2-peer/app/PeerMain.hs | 4 +- hbs2-peer/lib/HBS2/Peer/RPC/Internal/Types.hs | 4 +- hbs2-tests/test/TestTCPNet.hs | 27 ++-- hbs2-tests/test/notify-unix/Main.hs | 4 +- 14 files changed, 162 insertions(+), 179 deletions(-) diff --git a/hbs2-core/lib/HBS2/Actors/Peer.hs b/hbs2-core/lib/HBS2/Actors/Peer.hs index 4efde844..2ff3c8a4 100644 --- a/hbs2-core/lib/HBS2/Actors/Peer.hs +++ b/hbs2-core/lib/HBS2/Actors/Peer.hs @@ -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 diff --git a/hbs2-core/lib/HBS2/Net/Proto/BlockChunks.hs b/hbs2-core/lib/HBS2/Net/Proto/BlockChunks.hs index 7ee24bdc..0b42b206 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/BlockChunks.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/BlockChunks.hs @@ -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 diff --git a/hbs2-core/lib/HBS2/Net/Proto/BlockInfo.hs b/hbs2-core/lib/HBS2/Net/Proto/BlockInfo.hs index 6ecb292c..accd0bad 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/BlockInfo.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/BlockInfo.hs @@ -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 diff --git a/hbs2-core/lib/HBS2/Net/Proto/Notify.hs b/hbs2-core/lib/HBS2/Net/Proto/Notify.hs index 062edebd..948d6e65 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/Notify.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/Notify.hs @@ -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" diff --git a/hbs2-core/lib/HBS2/Net/Proto/PeerExchange.hs b/hbs2-core/lib/HBS2/Net/Proto/PeerExchange.hs index 581432a4..24b8f503 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/PeerExchange.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/PeerExchange.hs @@ -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 diff --git a/hbs2-core/lib/HBS2/Net/Proto/PeerMeta.hs b/hbs2-core/lib/HBS2/Net/Proto/PeerMeta.hs index e0dd44a5..07ff625b 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/PeerMeta.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/PeerMeta.hs @@ -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 diff --git a/hbs2-core/lib/HBS2/Net/Proto/RefChan.hs b/hbs2-core/lib/HBS2/Net/Proto/RefChan.hs index a848e2ac..83f78e3a 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/RefChan.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/RefChan.hs @@ -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) diff --git a/hbs2-core/lib/HBS2/Net/Proto/RefLog.hs b/hbs2-core/lib/HBS2/Net/Proto/RefLog.hs index b9f2de20..a0e303d5 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/RefLog.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/RefLog.hs @@ -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 diff --git a/hbs2-core/lib/HBS2/Net/Proto/Service.hs b/hbs2-core/lib/HBS2/Net/Proto/Service.hs index 7cfa1a00..630473c7 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/Service.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/Service.hs @@ -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 diff --git a/hbs2-core/lib/HBS2/Net/Proto/Types.hs b/hbs2-core/lib/HBS2/Net/Proto/Types.hs index bef1f08d..23458c71 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/Types.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/Types.hs @@ -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 diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index 8ec28d38..182cf476 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/hbs2-peer/app/PeerMain.hs @@ -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 = diff --git a/hbs2-peer/lib/HBS2/Peer/RPC/Internal/Types.hs b/hbs2-peer/lib/HBS2/Peer/RPC/Internal/Types.hs index 70a15238..1f643089 100644 --- a/hbs2-peer/lib/HBS2/Peer/RPC/Internal/Types.hs +++ b/hbs2-peer/lib/HBS2/Peer/RPC/Internal/Types.hs @@ -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 diff --git a/hbs2-tests/test/TestTCPNet.hs b/hbs2-tests/test/TestTCPNet.hs index e57fcd37..70113749 100644 --- a/hbs2-tests/test/TestTCPNet.hs +++ b/hbs2-tests/test/TestTCPNet.hs @@ -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)) diff --git a/hbs2-tests/test/notify-unix/Main.hs b/hbs2-tests/test/notify-unix/Main.hs index 71e13cc8..ea5f7058 100644 --- a/hbs2-tests/test/notify-unix/Main.hs +++ b/hbs2-tests/test/notify-unix/Main.hs @@ -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)