diff --git a/hbs2-core/test/TestUniqProtoId.hs b/hbs2-core/test/TestUniqProtoId.hs index fbb6e10a..3b09a9c3 100644 --- a/hbs2-core/test/TestUniqProtoId.hs +++ b/hbs2-core/test/TestUniqProtoId.hs @@ -1,6 +1,8 @@ {-# Language TypeFamilyDependencies #-} {-# Language FunctionalDependencies #-} {-# Language AllowAmbiguousTypes #-} +{-# Language TemplateHaskell #-} +-- {-# Language QuantifiedConstraints #-} module TestUniqProtoId where import HasProtocol @@ -12,7 +14,9 @@ import Data.Map qualified as Map import Data.Map (Map) import Control.Monad.Reader import Data.ByteString (ByteString) +import Lens.Micro.Platform +import Data.Foldable import Data.List qualified as List import Data.Cache qualified as Cache import Data.Cache (Cache) @@ -20,7 +24,7 @@ import Control.Concurrent.STM.TChan as Chan import Control.Concurrent.STM import Data.Hashable import Data.Maybe - +import Safe newtype From a = From (Peer a) @@ -32,6 +36,17 @@ class HasPeer proto => Messaging bus proto msg | bus -> proto, bus -> msg where receive :: MonadIO m => bus -> To proto -> m [(From proto, msg)] +data AnyMessage = AnyMessage Integer String + +data EngineEnv = forall p bus . (Messaging bus p AnyMessage) => + EngineEnv + { peer :: Maybe (Peer p) + , self :: Peer p + , bus :: bus + } + +-- makeLenses 'EngineEnv + data FakeP2P proto msg = FakeP2P { @@ -73,6 +88,7 @@ data AnyProtocol e m = forall p a . ( HasProtocol p a data PingPong = Ping Int | Pong Int + deriving stock (Show,Read) type family Encoding a :: Type @@ -87,8 +103,8 @@ instance HasPeer Fake where instance HasProtocol Fake PingPong where type instance ProtocolId PingPong = 1 type instance Encoded Fake = String - decode = undefined - encode = undefined + decode = readMay + encode = show class Response e p (m :: Type -> Type) where response :: p -> m () @@ -106,28 +122,31 @@ makeResponse h = AnyProtocol { getProtoId = natVal (Proxy @(ProtocolId p)) , handle = h } -data AnyMessage = AnyMessage Integer ByteString - -data EngineEnv = forall p bus . (HasPeer p, Messaging bus p AnyMessage) => - EngineEnv - { peer :: Maybe (Peer p) - , bus :: bus - } newtype EngineM m a = EngineM { fromEngine :: ReaderT EngineEnv m a } - deriving ( Functor, Applicative, Monad, MonadTrans, MonadIO ) + deriving ( Functor + , Applicative + , Monad + , MonadTrans + , MonadIO + , MonadReader EngineEnv + ) runEngineM :: EngineEnv -> EngineM m a -> m a runEngineM e f = runReaderT (fromEngine f) e -instance (Monad m, HasProtocol e p) => Response e p (EngineM m) where +instance (MonadIO m, HasProtocol e p, Encoded e ~ String) => Response e p (EngineM m) where response resp = do - -- TODO: get bus - -- TODO: encode - -- TODO: sendTo - undefined + env <- ask + case env of + (EngineEnv { peer = Just p + , bus = b + , self = s + } ) -> do + liftIO $ sendTo b (To p) (From s) (AnyMessage 1 (encode resp)) + _ -> pure () -pingPongHandler :: forall a m . (MonadIO m, Response a PingPong m) => PingPong -> m () +pingPongHandler :: forall a m . (MonadIO m, Response a PingPong m, HasProtocol a PingPong) => PingPong -> m () pingPongHandler = \case Ping c -> liftIO (print "effect: PING") >> response @a @PingPong (Pong c) @@ -138,23 +157,33 @@ testUniqiProtoId = do fake <- newFakeP2P True - let env = EngineEnv @Fake Nothing fake + let env = EngineEnv @Fake Nothing (FakePeer 0) fake + + sendTo fake (To (FakePeer 0)) (From (FakePeer 0)) (AnyMessage 1 (encode (Ping 0))) let pingpong = makeResponse pingPongHandler - let decoders = mempty :: Map Integer (AnyProtocol String (EngineM IO)) - let dec = Map.insert 1 pingpong decoders + let resp = [ (1, pingpong) ] + + let decoders = Map.fromList resp :: Map Integer (AnyProtocol (Encoded Fake) (EngineM IO)) -- TODO: GET MESSAGE -- TODO: GET RECIPIENT -- TODO: GET PROTO-ID FROM MESSAGE - let message = "" :: Encoded Fake + messages <- receive fake (To (FakePeer 0)) + + runEngineM env $ do + + for_ messages $ \(From peer, AnyMessage n msg) -> do + + local (\(EngineEnv _ s b) -> EngineEnv undefined s b) $ do + + -- FIXME: dispatcher! + case Map.lookup n decoders of + Just (AnyProtocol {protoDecode = decoder, handle = h}) -> maybe (pure ()) h (decoder msg) + Nothing -> pure () + - -- FIXME: dispatcher! - case Map.lookup 1 dec of - Just (AnyProtocol {protoDecode = decoder, handle = h}) -> maybe (pure ()) (runEngineM env . h) (decoder message) - Nothing -> pure () - pure ()