wip

hbs2-core/hbs2-core.cabal

@@ -19,6 +19,7 @@ common warnings
 common shared-properties
   ghc-options:
         -Wall
+        -fno-warn-type-defaults
         -- -fno-warn-unused-matches
         -- -fno-warn-unused-do-bind
         -- -Werror=missing-methods

hbs2-core/lib/HBS2/Net/Messaging.hs

@@ -1,18 +1,15 @@
 {-# Language FunctionalDependencies #-}
 module HBS2.Net.Messaging where
 
+import HBS2.Net.Proto
+
 import Control.Monad.IO.Class
-import Data.Kind
-import Prettyprinter
 
-newtype From a = From a
-                 deriving newtype (Eq,Show,Pretty)
+newtype From a = From (Peer a)
 
-newtype To a = To a
-               deriving newtype (Eq,Show,Pretty)
+newtype To a = To (Peer a)
 
-
-class Messaging bus addr msg  | bus -> addr, bus -> msg where
+class IsPeer addr => Messaging bus addr msg  | bus -> addr, bus -> msg where
 
   sendTo  :: MonadIO m => bus -> To addr -> From addr -> msg -> m ()
   receive :: MonadIO m => bus -> To addr -> m [msg]

hbs2-core/lib/HBS2/Net/Messaging/Fake.hs

@@ -12,6 +12,7 @@ import Data.Cache (Cache)
 import Data.Cache qualified as Cache
 import Data.List qualified as List
 import Data.Maybe
+import Data.Hashable
 
 import HBS2.Net.Proto
 import HBS2.Net.Messaging
@@ -20,13 +21,13 @@ data FakeP2P peer msg =
   FakeP2P
   {
     blocking :: Bool
-  , fakeP2p  :: Cache peer (TChan msg)
+  , fakeP2p  :: Cache (Peer peer) (TChan msg)
   }
 
 newFakeP2P :: Bool -> IO (FakeP2P peer msg)
 newFakeP2P block = FakeP2P block <$> Cache.newCache Nothing
 
-instance ( IsPeer peer
+instance ( (IsPeer peer, Hashable (Peer peer) )
          ) => Messaging (FakeP2P peer msg) peer msg where
 
   sendTo bus (To whom) _ msg = liftIO do

hbs2-core/lib/HBS2/Net/Proto.hs

@@ -1,6 +1,8 @@
 module HBS2.Net.Proto where
 
+import Data.Kind
 import Data.Hashable
 
-class (Hashable a, Eq a) => IsPeer a where
+class (Hashable (Peer a), Eq (Peer a)) => IsPeer a where
+  data family Peer a :: Type
 

hbs2-core/test/Main.hs

@@ -0,0 +1,16 @@
+module Main where
+
+import TestFakeMessaging
+
+import Test.Tasty
+import Test.Tasty.HUnit
+
+main :: IO ()
+main =
+  defaultMain $
+    testGroup "root"
+      [
+        testCase "testFakeMessaging1" testFakeMessaging1
+      ]
+
+

hbs2-core/test/TestFakeMessaging.hs

@@ -1,3 +1,68 @@
 module TestFakeMessaging where
 
+import HBS2.Net.Proto
+import HBS2.Net.Messaging
+import HBS2.Net.Messaging.Fake
+
+import Test.Tasty.HUnit
+
+import Control.Monad
+import Data.Tuple
+import Data.Hashable
+import System.Random
+import Data.IORef
+import Data.Word
+import Data.Set qualified as Set
+import Data.Map qualified as Map
+
+-- import Control.Monad.Writer
+-- import Data.Hashable
+-- import Data.IORef
+-- import Data.Map qualified as Map
+-- import Data.Set qualified as Set
+-- import Data.Tuple
+-- import Data.Word
+-- import System.Random
+
+-- import Data.HbSync.Types
+-- import Network.HbSync.Protocol.Messaging
+-- import Network.HbSync.Protocol.Messaging.Fake
+
+
+data Fake
+
+instance IsPeer Fake where
+  newtype instance Peer Fake = FakePeer Int
+                               deriving stock (Eq,Ord,Show)
+                               deriving newtype (Hashable,Num,Enum,Real,Integral)
+
+
+testFakeMessaging1 :: IO ()
+testFakeMessaging1 = do
+
+  gen <- newIORef (mkStdGen 0x4387ddaA10124)
+
+
+  let peers = fmap FakePeer [1..10]
+
+  bus <- newFakeP2P @Fake @Word16 False
+
+  sent <- forM (zip peers peers) $ \(to,from) -> do
+            msg <- replicateM 10 $ atomicModifyIORef' gen (swap . random) :: IO [Word16]
+            forM msg $ \m -> do
+              sendTo bus (To to) (From from) m
+              pure ( to, Set.singleton m )
+
+  received <- forM peers $ \me -> do
+                msg <- replicateM 10 $ receive bus (To me)
+                pure ( me, Set.fromList (mconcat msg) )
+
+  let s1 = Map.fromListWith (<>) (mconcat sent)
+  let s2 = Map.fromList received
+
+  -- print ("sent", s1)
+  -- print ("receive", s2)
+
+  assertEqual "sent == received" s1 s2
+