diff --git a/hbs2-core/lib/HBS2/Net/Messaging/Fake.hs b/hbs2-core/lib/HBS2/Net/Messaging/Fake.hs index 130c95a8..354f39b6 100644 --- a/hbs2-core/lib/HBS2/Net/Messaging/Fake.hs +++ b/hbs2-core/lib/HBS2/Net/Messaging/Fake.hs @@ -1,7 +1,7 @@ module HBS2.Net.Messaging.Fake ( FakeP2P , newFakeP2P - , Messaging(..) + -- , Messaging(..) ) where import Control.Concurrent.STM (atomically) -- as STM @@ -17,11 +17,11 @@ import Data.Hashable import HBS2.Net.Proto import HBS2.Net.Messaging -data FakeP2P peer msg = +data FakeP2P proto msg = FakeP2P { blocking :: Bool - , fakeP2p :: Cache (Peer peer) (TChan (From peer,msg)) + , fakeP2p :: Cache (Peer proto) (TChan (From proto,msg)) } newFakeP2P :: Bool -> IO (FakeP2P peer msg) diff --git a/hbs2-core/test/HasProtocol.hs b/hbs2-core/test/HasProtocol.hs index 232fe9dd..c3345982 100644 --- a/hbs2-core/test/HasProtocol.hs +++ b/hbs2-core/test/HasProtocol.hs @@ -7,7 +7,7 @@ import Data.Proxy import GHC.TypeLits class HasPeer p where - type family (Peer p) :: Type + data family (Peer p) :: Type class HasPeer p => HasProtocol p a | a -> p where type family ProtocolId a = (id :: Nat) | id -> a diff --git a/hbs2-core/test/TestUniqProtoId.hs b/hbs2-core/test/TestUniqProtoId.hs index 8991de0c..fbb6e10a 100644 --- a/hbs2-core/test/TestUniqProtoId.hs +++ b/hbs2-core/test/TestUniqProtoId.hs @@ -1,4 +1,5 @@ {-# Language TypeFamilyDependencies #-} +{-# Language FunctionalDependencies #-} {-# Language AllowAmbiguousTypes #-} module TestUniqProtoId where @@ -10,6 +11,52 @@ import Data.Proxy import Data.Map qualified as Map import Data.Map (Map) import Control.Monad.Reader +import Data.ByteString (ByteString) + +import Data.List qualified as List +import Data.Cache qualified as Cache +import Data.Cache (Cache) +import Control.Concurrent.STM.TChan as Chan +import Control.Concurrent.STM +import Data.Hashable +import Data.Maybe + + +newtype From a = From (Peer a) + +newtype To a = To (Peer a) + +class HasPeer proto => Messaging bus proto msg | bus -> proto, bus -> msg where + + sendTo :: MonadIO m => bus -> To proto -> From proto -> msg -> m () + receive :: MonadIO m => bus -> To proto -> m [(From proto, msg)] + + +data FakeP2P proto msg = + FakeP2P + { + blocking :: Bool + , fakeP2p :: Cache (Peer proto) (TChan (From proto,msg)) + } + +newFakeP2P :: Bool -> IO (FakeP2P peer msg) +newFakeP2P block = FakeP2P block <$> Cache.newCache Nothing + +instance ( (HasPeer proto, Hashable (Peer proto)) + ) => Messaging (FakeP2P proto msg) proto msg where + + sendTo bus (To whom) who msg = liftIO do + chan <- Cache.fetchWithCache (fakeP2p bus) whom $ const newTChanIO + atomically $ Chan.writeTChan chan (who, msg) + + receive bus (To me) = liftIO do + readChan =<< Cache.fetchWithCache (fakeP2p bus) me (const newTChanIO) + + where + readChan | blocking bus = atomically . (List.singleton <$>) . Chan.readTChan + | otherwise = atomically . (maybeToList <$>) . Chan.tryReadTChan + + data AnyProtocol e m = forall p a . ( HasProtocol p a , KnownNat (ProtocolId a) @@ -31,8 +78,11 @@ type family Encoding a :: Type data Fake + instance HasPeer Fake where - type instance Peer Fake = Int + newtype instance Peer Fake = FakePeer Int + deriving newtype (Hashable) + deriving stock (Eq) instance HasProtocol Fake PingPong where type instance ProtocolId PingPong = 1 @@ -56,9 +106,12 @@ makeResponse h = AnyProtocol { getProtoId = natVal (Proxy @(ProtocolId p)) , handle = h } -data EngineEnv = forall p . HasPeer p => +data AnyMessage = AnyMessage Integer ByteString + +data EngineEnv = forall p bus . (HasPeer p, Messaging bus p AnyMessage) => EngineEnv - { peer :: Maybe (Peer p) + { peer :: Maybe (Peer p) + , bus :: bus } newtype EngineM m a = EngineM { fromEngine :: ReaderT EngineEnv m a } @@ -68,7 +121,7 @@ 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 - response _ = do + response resp = do -- TODO: get bus -- TODO: encode -- TODO: sendTo @@ -83,7 +136,9 @@ pingPongHandler = testUniqiProtoId :: IO () testUniqiProtoId = do - let env = EngineEnv @Fake Nothing + fake <- newFakeP2P True + + let env = EngineEnv @Fake Nothing fake let pingpong = makeResponse pingPongHandler