From 7536d9bbc9d3210bd74a3667c2b4075374b90e3c Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Tue, 17 Jan 2023 05:20:47 +0300 Subject: [PATCH] works --- hbs2-core/hbs2-core.cabal | 1 + hbs2-core/lib/HBS2/Net/Messaging.hs | 9 ++-- hbs2-core/lib/HBS2/Net/Messaging/Fake.hs | 5 +-- hbs2-core/lib/HBS2/Net/PeerLocator.hs | 3 +- hbs2-core/lib/HBS2/Net/PeerLocator/Static.hs | 2 +- hbs2-core/lib/HBS2/Net/Proto.hs | 11 +++-- .../lib/HBS2/Net/Proto/Actors/BlockInfo.hs | 4 +- hbs2-core/lib/HBS2/Net/Proto/Types.hs | 25 +++++++++++ hbs2-core/test/FakeMessaging.hs | 6 ++- hbs2-core/test/HasProtocol.hs | 33 +++++---------- hbs2-core/test/TestBlockInfoActor.hs | 8 +--- hbs2-core/test/TestUniqProtoId.hs | 41 +------------------ 12 files changed, 57 insertions(+), 91 deletions(-) create mode 100644 hbs2-core/lib/HBS2/Net/Proto/Types.hs diff --git a/hbs2-core/hbs2-core.cabal b/hbs2-core/hbs2-core.cabal index 69e4d9e2..77955d2d 100644 --- a/hbs2-core/hbs2-core.cabal +++ b/hbs2-core/hbs2-core.cabal @@ -76,6 +76,7 @@ library , HBS2.Net.PeerLocator , HBS2.Net.PeerLocator.Static , HBS2.Net.Proto + , HBS2.Net.Proto.Types , HBS2.Net.Proto.Actors.BlockInfo , HBS2.Prelude , HBS2.Prelude.Plated diff --git a/hbs2-core/lib/HBS2/Net/Messaging.hs b/hbs2-core/lib/HBS2/Net/Messaging.hs index bdcb5161..30853048 100644 --- a/hbs2-core/lib/HBS2/Net/Messaging.hs +++ b/hbs2-core/lib/HBS2/Net/Messaging.hs @@ -9,11 +9,8 @@ newtype From a = From (Peer a) newtype To a = To (Peer a) -class IsPeer addr => Messaging bus addr msg | bus -> addr, bus -> msg where +class HasPeer proto => Messaging bus proto msg | bus -> proto, bus -> msg where - sendTo :: MonadIO m => bus -> To addr -> From addr -> msg -> m () - receive :: MonadIO m => bus -> To addr -> m [(From addr, msg)] - - --- data AnyMessaging p m = forall bus . Messaging bus (Peer p) + sendTo :: MonadIO m => bus -> To proto -> From proto -> msg -> m () + receive :: MonadIO m => bus -> To proto -> m [(From proto, msg)] diff --git a/hbs2-core/lib/HBS2/Net/Messaging/Fake.hs b/hbs2-core/lib/HBS2/Net/Messaging/Fake.hs index 354f39b6..bf703400 100644 --- a/hbs2-core/lib/HBS2/Net/Messaging/Fake.hs +++ b/hbs2-core/lib/HBS2/Net/Messaging/Fake.hs @@ -27,8 +27,8 @@ data FakeP2P proto msg = newFakeP2P :: Bool -> IO (FakeP2P peer msg) newFakeP2P block = FakeP2P block <$> Cache.newCache Nothing -instance ( (IsPeer peer, Hashable (Peer peer) ) - ) => Messaging (FakeP2P peer msg) peer msg where +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 @@ -40,4 +40,3 @@ instance ( (IsPeer peer, Hashable (Peer peer) ) where readChan | blocking bus = atomically . (List.singleton <$>) . Chan.readTChan | otherwise = atomically . (maybeToList <$>) . Chan.tryReadTChan - diff --git a/hbs2-core/lib/HBS2/Net/PeerLocator.hs b/hbs2-core/lib/HBS2/Net/PeerLocator.hs index 336c71d5..8aecde92 100644 --- a/hbs2-core/lib/HBS2/Net/PeerLocator.hs +++ b/hbs2-core/lib/HBS2/Net/PeerLocator.hs @@ -4,7 +4,7 @@ module HBS2.Net.PeerLocator where import HBS2.Net.Proto class PeerLocator l where - knownPeers :: (IsPeer peer, Monad m) => l -> m [Peer peer] + knownPeers :: (HasPeer p, Monad m) => l -> m [Peer p] data AnyPeerLocator = forall a . PeerLocator a => AnyPeerLocator a @@ -12,3 +12,4 @@ instance PeerLocator AnyPeerLocator where knownPeers (AnyPeerLocator l) = knownPeers l + diff --git a/hbs2-core/lib/HBS2/Net/PeerLocator/Static.hs b/hbs2-core/lib/HBS2/Net/PeerLocator/Static.hs index b8ede9cf..bb70d70c 100644 --- a/hbs2-core/lib/HBS2/Net/PeerLocator/Static.hs +++ b/hbs2-core/lib/HBS2/Net/PeerLocator/Static.hs @@ -12,7 +12,7 @@ newtype StaticPeerLocator p = StaticPeerLocator (TVar (Set (Peer p))) -newStaticPeerLocator :: (IsPeer p, MonadIO m) => [Peer p] -> m (StaticPeerLocator p) +newStaticPeerLocator :: (Ord (Peer p), HasPeer p, MonadIO m) => [Peer p] -> m (StaticPeerLocator p) newStaticPeerLocator seeds = do tv <- liftIO $ newTVarIO (Set.fromList seeds) pure $ StaticPeerLocator tv diff --git a/hbs2-core/lib/HBS2/Net/Proto.hs b/hbs2-core/lib/HBS2/Net/Proto.hs index 373b346c..a29435bb 100644 --- a/hbs2-core/lib/HBS2/Net/Proto.hs +++ b/hbs2-core/lib/HBS2/Net/Proto.hs @@ -1,12 +1,11 @@ -module HBS2.Net.Proto where +module HBS2.Net.Proto + ( module HBS2.Net.Proto + , module HBS2.Net.Proto.Types + ) where import HBS2.Prelude.Plated +import HBS2.Net.Proto.Types -import Data.Kind -import Data.Hashable - -class (Hashable (Peer a), Eq (Peer a), Ord (Peer a)) => IsPeer a where - data family Peer a :: Type newtype BlockInfo = BlockInfo Integer diff --git a/hbs2-core/lib/HBS2/Net/Proto/Actors/BlockInfo.hs b/hbs2-core/lib/HBS2/Net/Proto/Actors/BlockInfo.hs index 1b26df30..3e569d9b 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/Actors/BlockInfo.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/Actors/BlockInfo.hs @@ -1,13 +1,11 @@ module HBS2.Net.Proto.Actors.BlockInfo where import HBS2.Actors -import HBS2.Clock import HBS2.Hash import HBS2.Net.PeerLocator import HBS2.Net.Proto import HBS2.Prelude -import Data.Function import Data.Kind import Prettyprinter @@ -42,7 +40,7 @@ stopBlockInfoActor b = stopPipeline (tasks b) requestBlockInfo :: forall peer h m . ( MonadIO m , Pretty (Hash h) - , IsPeer peer + , HasPeer peer ) => BlockInfoActor m -> Maybe (Peer peer) diff --git a/hbs2-core/lib/HBS2/Net/Proto/Types.hs b/hbs2-core/lib/HBS2/Net/Proto/Types.hs new file mode 100644 index 00000000..02d113c5 --- /dev/null +++ b/hbs2-core/lib/HBS2/Net/Proto/Types.hs @@ -0,0 +1,25 @@ +{-# Language TypeFamilyDependencies #-} +{-# Language FunctionalDependencies #-} +module HBS2.Net.Proto.Types where + +import Data.Kind +import GHC.TypeLits +import Data.Proxy +import Data.Hashable + +-- e -> Transport (like, UDP or TChan) +-- p -> L4 Protocol (like Ping/Pong) + +class (Hashable (Peer e), Eq (Peer e)) => HasPeer e where + data family (Peer e) :: Type + +class (KnownNat (ProtocolId p), HasPeer e) => HasProtocol e p | p -> e where + type family ProtocolId p = (id :: Nat) | id -> p + type family Encoded e :: Type + + protoId :: forall . KnownNat (ProtocolId p) => Proxy p -> Integer + protoId _ = natVal (Proxy @(ProtocolId p)) + + decode :: Encoded e -> Maybe p + encode :: p -> Encoded e + diff --git a/hbs2-core/test/FakeMessaging.hs b/hbs2-core/test/FakeMessaging.hs index d9aad4d8..dc693102 100644 --- a/hbs2-core/test/FakeMessaging.hs +++ b/hbs2-core/test/FakeMessaging.hs @@ -10,12 +10,14 @@ import HBS2.Net.Messaging.Fake import Data.Hashable import Prettyprinter + data Fake -instance IsPeer Fake where +instance HasPeer Fake where newtype instance Peer Fake = FakePeer Int + deriving newtype (Hashable,Num,Enum) deriving stock (Eq,Ord,Show) - deriving newtype (Hashable,Num,Enum,Real,Integral) + instance Pretty (Peer Fake) where pretty (FakePeer n) = parens ("peer" <+> pretty n) diff --git a/hbs2-core/test/HasProtocol.hs b/hbs2-core/test/HasProtocol.hs index 0d5659f9..9801e1f5 100644 --- a/hbs2-core/test/HasProtocol.hs +++ b/hbs2-core/test/HasProtocol.hs @@ -1,26 +1,13 @@ -{-# Language TypeFamilyDependencies #-} -{-# Language FunctionalDependencies #-} -module HasProtocol where +module HasProtocol + ( module HBS2.Net.Proto.Types + , module HBS2.Net.Messaging + , module HBS2.Net.Messaging.Fake + ) where + +import HBS2.Net.Proto.Types +import HBS2.Net.Messaging +import HBS2.Net.Messaging.Fake + -import Data.Kind -import Data.Proxy -import GHC.TypeLits -import Data.Hashable - --- e -> Transport (like, UDP or TChan) --- p -> L4 Protocol (like Ping/Pong) - -class (Hashable (Peer e), Eq (Peer e)) =>HasPeer e where - data family (Peer e) :: Type - -class (KnownNat (ProtocolId p), HasPeer e) => HasProtocol e p | p -> e where - type family ProtocolId p = (id :: Nat) | id -> p - type family Encoded e :: Type - - protoId :: forall . KnownNat (ProtocolId p) => Proxy p -> Integer - protoId _ = natVal (Proxy @(ProtocolId p)) - - decode :: Encoded e -> Maybe p - encode :: p -> Encoded e diff --git a/hbs2-core/test/TestBlockInfoActor.hs b/hbs2-core/test/TestBlockInfoActor.hs index c43e3949..321ef3d6 100644 --- a/hbs2-core/test/TestBlockInfoActor.hs +++ b/hbs2-core/test/TestBlockInfoActor.hs @@ -7,6 +7,8 @@ import HBS2.Net.Proto.Actors.BlockInfo import HBS2.Net.PeerLocator import HBS2.Net.PeerLocator.Static +import FakeMessaging + import Test.Tasty.HUnit import Test.QuickCheck @@ -16,12 +18,6 @@ import Data.ByteString (ByteString) import Data.ByteString qualified as B import Control.Concurrent.Async -data Fake - -instance IsPeer Fake where - newtype instance Peer Fake = FakePeer Int - deriving stock (Eq,Ord,Show) - deriving newtype (Hashable,Num,Enum,Real,Integral) testBlockInfoActor :: IO () testBlockInfoActor = do diff --git a/hbs2-core/test/TestUniqProtoId.hs b/hbs2-core/test/TestUniqProtoId.hs index 2bc78e50..20b85e6e 100644 --- a/hbs2-core/test/TestUniqProtoId.hs +++ b/hbs2-core/test/TestUniqProtoId.hs @@ -1,13 +1,12 @@ {-# Language TypeFamilyDependencies #-} {-# Language FunctionalDependencies #-} {-# Language AllowAmbiguousTypes #-} --- {-# Language #-} --- {-# Language QuantifiedConstraints #-} module TestUniqProtoId where import HBS2.Clock import HasProtocol +import FakeMessaging import Data.Kind import GHC.TypeLits @@ -32,15 +31,6 @@ import Control.Logger.Simple qualified as Log import Prettyprinter hiding (pipe) -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 AnyMessage e = AnyMessage Integer (Encoded e) @@ -53,29 +43,6 @@ data EngineEnv e = forall bus . (Messaging bus e (AnyMessage e)) => -- makeLenses 'EngineEnv -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 @@ -178,12 +145,6 @@ data PeekPoke = Peek Int | Nop deriving stock (Show,Read) -data Fake - -instance HasPeer Fake where - newtype instance Peer Fake = FakePeer Int - deriving newtype (Hashable) - deriving stock (Eq,Show) instance HasProtocol Fake PingPong where type instance ProtocolId PingPong = 1