From 4008971946b16ce3bdd6e4717bef7fe9d88eea20 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Tue, 17 Jan 2023 05:53:59 +0300 Subject: [PATCH] still working --- flake.lock | 6 +- hbs2-core/hbs2-core.cabal | 2 + hbs2-core/lib/HBS2/Net/Peer.hs | 101 +++++++++++++++++++++ hbs2-core/lib/HBS2/Net/PeerLocator.hs | 2 +- hbs2-core/lib/HBS2/Net/Proto/Types.hs | 4 +- hbs2-core/lib/HBS2/Prelude.hs | 3 +- hbs2-core/test/HasProtocol.hs | 4 +- hbs2-core/test/TestUniqProtoId.hs | 122 ++++---------------------- 8 files changed, 133 insertions(+), 111 deletions(-) create mode 100644 hbs2-core/lib/HBS2/Net/Peer.hs diff --git a/flake.lock b/flake.lock index c10fa0c3..068893e4 100644 --- a/flake.lock +++ b/flake.lock @@ -91,11 +91,11 @@ }, "nixpkgs": { "locked": { - "lastModified": 1673163619, - "narHash": "sha256-B33PFBL64ZgTWgMnhFL3jgheAN/DjHPsZ1Ih3z0VE5I=", + "lastModified": 1673800717, + "narHash": "sha256-SFHraUqLSu5cC6IxTprex/nTsI81ZQAtDvlBvGDWfnA=", "owner": "nixos", "repo": "nixpkgs", - "rev": "8c54d842d9544361aac5f5b212ba04e4089e8efe", + "rev": "2f9fd351ec37f5d479556cd48be4ca340da59b8f", "type": "github" }, "original": { diff --git a/hbs2-core/hbs2-core.cabal b/hbs2-core/hbs2-core.cabal index 77955d2d..9f69a8a9 100644 --- a/hbs2-core/hbs2-core.cabal +++ b/hbs2-core/hbs2-core.cabal @@ -75,6 +75,7 @@ library , HBS2.Net.Messaging.Fake , HBS2.Net.PeerLocator , HBS2.Net.PeerLocator.Static + , HBS2.Net.Peer , HBS2.Net.Proto , HBS2.Net.Proto.Types , HBS2.Net.Proto.Actors.BlockInfo @@ -101,6 +102,7 @@ library , interpolatedstring-perl6 , memory , microlens-platform + , mtl , prettyprinter , safe , serialise diff --git a/hbs2-core/lib/HBS2/Net/Peer.hs b/hbs2-core/lib/HBS2/Net/Peer.hs new file mode 100644 index 00000000..c3608a7c --- /dev/null +++ b/hbs2-core/lib/HBS2/Net/Peer.hs @@ -0,0 +1,101 @@ +{-# Language UndecidableInstances #-} +module HBS2.Net.Peer where + +import HBS2.Prelude +import HBS2.Net.Proto +import HBS2.Net.Messaging + +import Data.Foldable +import Control.Monad.Reader +import Data.Map qualified as Map +import Data.Proxy +import GHC.TypeLits + +data AnyMessage e = AnyMessage Integer (Encoded e) + +data EngineEnv e = forall bus . (Messaging bus e (AnyMessage e)) => + EngineEnv + { peer :: Maybe (Peer e) + , self :: Peer e + , bus :: bus + } + +data AnyProtocol e m = forall p . ( HasProtocol e p + , Response e p m + ) => + AnyProtocol + { myProtoId :: Integer + , protoDecode :: Encoded e -> Maybe p + , protoEncode :: p -> Encoded e + , handle :: p -> m () + } + +makeResponse :: forall e p m . ( MonadIO m + , Response e p m + , HasProtocol e p + ) + => (p -> m ()) -> AnyProtocol e m + +makeResponse h = AnyProtocol { myProtoId = natVal (Proxy @(ProtocolId p)) + , protoDecode = decode + , protoEncode = encode + , handle = h + } + + +newtype EngineM e m a = EngineM { fromEngine :: ReaderT (EngineEnv e) m a } + deriving ( Functor + , Applicative + , Monad + , MonadIO + , MonadReader (EngineEnv e) + ) + +runEngineM :: EngineEnv e -> EngineM e m a -> m a +runEngineM e f = runReaderT (fromEngine f) e + + +instance (MonadIO m, HasProtocol e p) => Request e p (EngineM e m) where + request p msg = do + let proto = protoId @e @p (Proxy @p) + ask >>= \case + EngineEnv { self = s, bus = b} -> do + liftIO $ sendTo b (To p) (From s) (AnyMessage proto (encode msg)) + +instance (MonadIO m, HasProtocol e p) => Response e p (EngineM e m) where + response resp = do + env <- ask + let proto = protoId @e @p (Proxy @p) + case env of + (EngineEnv { peer = Just p + , bus = b + , self = s + } ) -> do + liftIO $ sendTo b (To p) (From s) (AnyMessage proto (encode resp)) + _ -> pure () + + +newEnv :: forall e bus m . (Monad m, Messaging bus e (AnyMessage e)) => Peer e -> bus -> m (EngineEnv e) +newEnv p pipe = pure $ EngineEnv Nothing p pipe + + +runPeer :: MonadIO m => EngineEnv e -> [AnyProtocol e (EngineM e m)] -> m a +runPeer env@(EngineEnv {self = me, bus = pipe}) hh = do + + let resp = [ (pid, a) | a@AnyProtocol { myProtoId = pid } <- hh ] + + let disp = Map.fromList resp + + runEngineM env $ do + + forever $ do + messages <- receive pipe (To me) + + for_ messages $ \(From pip, AnyMessage n msg) -> do + + local (\e -> e { peer = Just pip } ) $ do + + case Map.lookup n disp of + Just (AnyProtocol {protoDecode = decoder, handle = h}) -> maybe (pure ()) h (decoder msg) + Nothing -> pure () + diff --git a/hbs2-core/lib/HBS2/Net/PeerLocator.hs b/hbs2-core/lib/HBS2/Net/PeerLocator.hs index 8aecde92..c7b25085 100644 --- a/hbs2-core/lib/HBS2/Net/PeerLocator.hs +++ b/hbs2-core/lib/HBS2/Net/PeerLocator.hs @@ -1,7 +1,7 @@ module HBS2.Net.PeerLocator where -- import HBS2.Prelude -import HBS2.Net.Proto +import HBS2.Net.Proto.Types class PeerLocator l where knownPeers :: (HasPeer p, Monad m) => l -> m [Peer p] diff --git a/hbs2-core/lib/HBS2/Net/Proto/Types.hs b/hbs2-core/lib/HBS2/Net/Proto/Types.hs index e8a65a7f..adc4325b 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/Types.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/Types.hs @@ -1,6 +1,8 @@ {-# Language TypeFamilyDependencies #-} {-# Language FunctionalDependencies #-} -module HBS2.Net.Proto.Types where +module HBS2.Net.Proto.Types + ( module HBS2.Net.Proto.Types + ) where import Data.Kind import GHC.TypeLits diff --git a/hbs2-core/lib/HBS2/Prelude.hs b/hbs2-core/lib/HBS2/Prelude.hs index 13683cb4..2c0d14fa 100644 --- a/hbs2-core/lib/HBS2/Prelude.hs +++ b/hbs2-core/lib/HBS2/Prelude.hs @@ -2,12 +2,13 @@ module HBS2.Prelude ( module Data.String , module Safe , MonadIO(..) - -- , module HBS2.Prelude + , void ) where import Data.String (IsString(..)) import Safe import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad (void) diff --git a/hbs2-core/test/HasProtocol.hs b/hbs2-core/test/HasProtocol.hs index 9801e1f5..db7b49d9 100644 --- a/hbs2-core/test/HasProtocol.hs +++ b/hbs2-core/test/HasProtocol.hs @@ -2,11 +2,13 @@ module HasProtocol ( module HBS2.Net.Proto.Types , module HBS2.Net.Messaging , module HBS2.Net.Messaging.Fake + , module HBS2.Net.Peer ) where -import HBS2.Net.Proto.Types import HBS2.Net.Messaging import HBS2.Net.Messaging.Fake +import HBS2.Net.Peer +import HBS2.Net.Proto.Types diff --git a/hbs2-core/test/TestUniqProtoId.hs b/hbs2-core/test/TestUniqProtoId.hs index e0a198cb..f400d356 100644 --- a/hbs2-core/test/TestUniqProtoId.hs +++ b/hbs2-core/test/TestUniqProtoId.hs @@ -2,113 +2,16 @@ {-# Language UndecidableInstances #-} module TestUniqProtoId where +import HBS2.Prelude + import HasProtocol import FakeMessaging -import GHC.TypeLits -import Data.Proxy -import Data.Map qualified as Map -import Control.Monad.Reader - import Control.Concurrent.Async -import Data.Foldable -import Safe import Prettyprinter hiding (pipe) -data AnyMessage e = AnyMessage Integer (Encoded e) - -data EngineEnv e = forall bus . (Messaging bus e (AnyMessage e)) => - EngineEnv - { peer :: Maybe (Peer e) - , self :: Peer e - , bus :: bus - } - -data AnyProtocol e m = forall p . ( HasProtocol e p - , KnownNat (ProtocolId p) - , Response e p m - ) => - AnyProtocol - { myProtoId :: Integer - , protoDecode :: Encoded e -> Maybe p - , protoEncode :: p -> Encoded e - , handle :: p -> m () - } - -makeResponse :: forall e p m . ( MonadIO m - , Response e p m - , HasProtocol e p - ) - => (p -> m ()) -> AnyProtocol e m - -makeResponse h = AnyProtocol { myProtoId = natVal (Proxy @(ProtocolId p)) - , protoDecode = decode - , protoEncode = encode - , handle = h - } - - -newtype EngineM e m a = EngineM { fromEngine :: ReaderT (EngineEnv e) m a } - deriving ( Functor - , Applicative - , Monad - , MonadTrans - , MonadIO - , MonadReader (EngineEnv e) - ) - -runEngineM :: EngineEnv e -> EngineM e m a -> m a -runEngineM e f = runReaderT (fromEngine f) e - - -instance (MonadIO m, HasProtocol e p) => Request e p (EngineM e m) where - request p msg = do - let proto = protoId @e @p (Proxy @p) - ask >>= \case - EngineEnv { self = s, bus = b} -> do - liftIO $ sendTo b (To p) (From s) (AnyMessage proto (encode msg)) - -instance (MonadIO m, HasProtocol e p) => Response e p (EngineM e m) where - response resp = do - env <- ask - let proto = protoId @e @p (Proxy @p) - case env of - (EngineEnv { peer = Just p - , bus = b - , self = s - } ) -> do - liftIO $ sendTo b (To p) (From s) (AnyMessage proto (encode resp)) - _ -> pure () - - - - -newEnv :: forall e bus m . (Monad m, Messaging bus e (AnyMessage e)) => Peer e -> bus -> m (EngineEnv e) -newEnv p pipe = pure $ EngineEnv Nothing p pipe - - -runPeer :: MonadIO m => EngineEnv e -> [AnyProtocol e (EngineM e m)] -> m a -runPeer env@(EngineEnv {self = me, bus = pipe}) hh = do - - let resp = [ (pid, a) | a@AnyProtocol { myProtoId = pid } <- hh ] - - let disp = Map.fromList resp - - runEngineM env $ do - - forever $ do - messages <- receive pipe (To me) - - for_ messages $ \(From pip, AnyMessage n msg) -> do - - local (\e -> e { peer = Just pip } ) $ do - - case Map.lookup n disp of - Just (AnyProtocol {protoDecode = decoder, handle = h}) -> maybe (pure ()) h (decoder msg) - Nothing -> pure () - data PingPong e = Ping Int | Pong Int deriving stock (Show,Read) @@ -132,13 +35,25 @@ instance HasProtocol Fake (PeekPoke Fake) where encode = show -pingPongHandler :: forall e m . (MonadIO m, Response e (PingPong e) m, HasProtocol e (PingPong e)) => PingPong e -> m () +pingPongHandler :: forall e m . ( MonadIO m + , Response e (PingPong e) m + , HasProtocol e (PingPong e) + ) + => PingPong e + -> m () + pingPongHandler = \case Ping c -> liftIO (print $ "effect: PING" <+> pretty c) >> response (Pong @e c) Pong c -> liftIO (print $ "effect: PONG" <+> pretty c) >> response (Ping @e (succ c)) -peekPokeHandler :: forall e m . (MonadIO m, Response e (PeekPoke e) m, HasProtocol e (PeekPoke e)) => PeekPoke e -> m () +peekPokeHandler :: forall e m . ( MonadIO m + , Response e (PeekPoke e) m + , HasProtocol e (PeekPoke e) + ) + => PeekPoke e + -> m () + peekPokeHandler = \case Peek c -> liftIO (print $ "effect: Peek" <+> pretty c) >> response (Poke @e c) @@ -146,9 +61,8 @@ peekPokeHandler = Nop -> liftIO (print $ pretty "effect: Nop") >> response (Peek @e 1) -testUniqiProtoId :: IO () -testUniqiProtoId = do - +testUniqProtoId :: IO () +testUniqProtoId = do fake <- newFakeP2P True