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

wip

This commit is contained in:
Dmitry Zuikov 2023-01-21 10:57:01 +03:00
parent d3dcdbb186
commit f147ae962a
1 changed files with 11 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
hbs2-tests/test/Peer2Main.hs
View File

@ -130,6 +130,7 @@ data PeerEnv e =
PeerEnv PeerEnv
{ _envSelf :: Peer e { _envSelf :: Peer e
, _envFab :: Fabriq e , _envFab :: Fabriq e
, _envDeferred :: Pipeline IO ()
} }
newtype PeerM e m a = PeerM { fromPeerM :: ReaderT (PeerEnv e) m a } newtype PeerM e m a = PeerM { fromPeerM :: ReaderT (PeerEnv e) m a }
@ -173,9 +174,9 @@ instance Monad m => HasOwnPeer e (PeerM e m) where
instance Monad m => HasFabriq e (PeerM e m) where instance Monad m => HasFabriq e (PeerM e m) where
getFabriq = asks (view envFab) getFabriq = asks (view envFab)
runPeerM :: Peer e -> Fabriq e -> PeerM e m a -> m a runPeerM :: MonadIO m => Peer e -> Fabriq e -> PeerM e m a -> m a
runPeerM p bus f = do runPeerM p bus f = do
let env = PeerEnv p bus env <- PeerEnv p bus <$> newPipeline defProtoPipelineSize
runReaderT (fromPeerM f) env runReaderT (fromPeerM f) env
@ -218,20 +219,18 @@ runProto hh = do
}) -> maybe (pure ()) (runResponseM pip . h) (decoder msg) }) -> maybe (pure ()) (runResponseM pip . h) (decoder msg)
instance ( MonadIO m instance ( HasProtocol e p
, HasProtocol e p
, HasFabriq e m
, HasOwnPeer e m
, Serialise (Encoded e) , Serialise (Encoded e)
, MonadTrans (ResponseM e) , MonadTrans (ResponseM e)
) => Response e p (ResponseM e m) where ) => Response e p (ResponseM e (PeerM e IO)) where
thatPeer _ = asks (view answTo) thatPeer _ = asks (view answTo)
deferred _ action = do deferred _ action = do
-- d <- asks (view defer) who <- asks (view answTo)
undefined fab <- lift $ getFabriq @e
-- addJob d _ pip <- lift $ asks (view envDeferred)
liftIO $ addJob pip $ runPeerM who fab (runResponseM who action)
response msg = do response msg = do
let proto = protoId @e @p (Proxy @p) let proto = protoId @e @p (Proxy @p)