diff --git a/hbs2-core/hbs2-core.cabal b/hbs2-core/hbs2-core.cabal index 5eccf41d..d6912eee 100644 --- a/hbs2-core/hbs2-core.cabal +++ b/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 diff --git a/hbs2-core/lib/HBS2/Net/Messaging.hs b/hbs2-core/lib/HBS2/Net/Messaging.hs index a8835898..c0188da5 100644 --- a/hbs2-core/lib/HBS2/Net/Messaging.hs +++ b/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] diff --git a/hbs2-core/lib/HBS2/Net/Messaging/Fake.hs b/hbs2-core/lib/HBS2/Net/Messaging/Fake.hs index c79bcfec..6c94f4dc 100644 --- a/hbs2-core/lib/HBS2/Net/Messaging/Fake.hs +++ b/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 diff --git a/hbs2-core/lib/HBS2/Net/Proto.hs b/hbs2-core/lib/HBS2/Net/Proto.hs index 748571ff..455b5171 100644 --- a/hbs2-core/lib/HBS2/Net/Proto.hs +++ b/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 diff --git a/hbs2-core/test/Main.hs b/hbs2-core/test/Main.hs new file mode 100644 index 00000000..cccb3d05 --- /dev/null +++ b/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 + ] + + diff --git a/hbs2-core/test/TestFakeMessaging.hs b/hbs2-core/test/TestFakeMessaging.hs index 536133d3..5099a42e 100644 --- a/hbs2-core/test/TestFakeMessaging.hs +++ b/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 +