works

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

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 ()
+  sendTo  :: MonadIO m => bus -> To proto -> From proto -> msg -> m ()
-  receive :: MonadIO m => bus -> To addr -> m [(From addr, msg)]
+  receive :: MonadIO m => bus -> To proto -> m [(From proto, msg)]
-
-
--- data AnyMessaging p m = forall bus . Messaging bus (Peer p)
 

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) )
+instance ( (HasPeer proto, Hashable (Peer proto))
-         ) => Messaging (FakeP2P peer msg) peer msg where
+         ) => 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
-

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
 
 
+

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

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

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)

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
+

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)

hbs2-core/test/HasProtocol.hs

@@ -1,26 +1,13 @@
-{-# Language TypeFamilyDependencies  #-}
+module HasProtocol
-{-# Language FunctionalDependencies  #-}
+  ( module HBS2.Net.Proto.Types
-module HasProtocol where
+  , 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
 
 

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

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