still working

flake.lock

@@ -91,11 +91,11 @@
     },
     "nixpkgs": {
       "locked": {
-        "lastModified": 1673163619,
+        "lastModified": 1673800717,
-        "narHash": "sha256-B33PFBL64ZgTWgMnhFL3jgheAN/DjHPsZ1Ih3z0VE5I=",
+        "narHash": "sha256-SFHraUqLSu5cC6IxTprex/nTsI81ZQAtDvlBvGDWfnA=",
         "owner": "nixos",
         "repo": "nixpkgs",
-        "rev": "8c54d842d9544361aac5f5b212ba04e4089e8efe",
+        "rev": "2f9fd351ec37f5d479556cd48be4ca340da59b8f",
         "type": "github"
       },
       "original": {

hbs2-core/hbs2-core.cabal

@@ -75,6 +75,7 @@ library
                     , HBS2.Net.Messaging.Fake
                     , HBS2.Net.PeerLocator
                     , HBS2.Net.PeerLocator.Static
+                    , HBS2.Net.Peer
                     , HBS2.Net.Proto
                     , HBS2.Net.Proto.Types
                     , HBS2.Net.Proto.Actors.BlockInfo
@@ -101,6 +102,7 @@ library
                      , interpolatedstring-perl6
                      , memory
                      , microlens-platform
+                     , mtl
                      , prettyprinter
                      , safe
                      , serialise

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

@@ -0,0 +1,101 @@
+{-# Language UndecidableInstances #-}
+module HBS2.Net.Peer where
+
+import HBS2.Prelude
+import HBS2.Net.Proto
+import HBS2.Net.Messaging
+
+import Data.Foldable
+import Control.Monad.Reader
+import Data.Map qualified as Map
+import Data.Proxy
+import GHC.TypeLits
+
+data AnyMessage e = AnyMessage Integer (Encoded e)
+
+data EngineEnv e = forall bus . (Messaging bus e (AnyMessage e))  =>
+  EngineEnv
+  { peer   :: Maybe (Peer e)
+  , self   :: Peer e
+  , bus    :: bus
+  }
+
+data AnyProtocol e m = forall p  . ( HasProtocol e p
+                                   , Response e p m
+                                   ) =>
+  AnyProtocol
+  { myProtoId   :: Integer
+  , protoDecode :: Encoded e -> Maybe p
+  , protoEncode :: p -> Encoded e
+  , handle      :: p -> m ()
+  }
+
+makeResponse :: forall e p  m . ( MonadIO m
+                                , Response e p m
+                                , HasProtocol e p
+                                )
+            => (p ->  m ()) -> AnyProtocol e m
+
+makeResponse h = AnyProtocol { myProtoId  = natVal (Proxy @(ProtocolId p))
+                             , protoDecode = decode
+                             , protoEncode = encode
+                             , handle = h
+                             }
+
+
+newtype EngineM e m a = EngineM { fromEngine :: ReaderT (EngineEnv e) m a }
+                        deriving ( Functor
+                                 , Applicative
+                                 , Monad
+                                 , MonadIO
+                                 , MonadReader (EngineEnv e)
+                                )
+
+runEngineM :: EngineEnv e -> EngineM e m a -> m a
+runEngineM e f = runReaderT (fromEngine f) e
+
+
+instance (MonadIO m, HasProtocol e p) => Request e p (EngineM e m) where
+  request p msg = do
+    let proto = protoId @e @p (Proxy @p)
+    ask >>= \case
+      EngineEnv { self = s, bus = b} -> do
+        liftIO $ sendTo b (To p) (From s) (AnyMessage proto (encode msg))
+
+instance (MonadIO m, HasProtocol e p) => Response e p (EngineM e m) where
+  response resp = do
+    env <- ask
+    let proto = protoId @e @p (Proxy @p)
+    case env of
+      (EngineEnv { peer = Just p
+                 , bus = b
+                 , self = s
+                 } ) -> do
+                  liftIO $ sendTo b (To p) (From s) (AnyMessage proto (encode resp))
+      _ -> pure ()
+
+
+newEnv :: forall e bus m . (Monad m, Messaging bus e (AnyMessage e)) => Peer e -> bus -> m (EngineEnv e)
+newEnv p pipe = pure $ EngineEnv Nothing p pipe
+
+
+runPeer :: MonadIO m => EngineEnv e -> [AnyProtocol e (EngineM e m)] -> m a
+runPeer env@(EngineEnv {self = me, bus = pipe}) hh = do
+
+  let resp = [ (pid, a) | a@AnyProtocol { myProtoId = pid } <- hh ]
+
+  let disp = Map.fromList resp
+
+  runEngineM env $ do
+
+    forever $ do
+      messages <- receive pipe (To me)
+
+      for_ messages $ \(From pip, AnyMessage n msg) -> do
+
+        local (\e -> e { peer = Just pip  } ) $ do
+
+          case Map.lookup n disp of
+            Just (AnyProtocol {protoDecode = decoder, handle = h}) -> maybe (pure ()) h (decoder msg)
+            Nothing -> pure ()
+

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

@@ -1,7 +1,7 @@
 module HBS2.Net.PeerLocator where
 
 -- import HBS2.Prelude
-import HBS2.Net.Proto
+import HBS2.Net.Proto.Types
 
 class PeerLocator l where
   knownPeers :: (HasPeer p, Monad m) => l -> m [Peer p]

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

@@ -1,6 +1,8 @@
 {-# Language TypeFamilyDependencies #-}
 {-# Language FunctionalDependencies #-}
-module HBS2.Net.Proto.Types where
+module HBS2.Net.Proto.Types
+  ( module HBS2.Net.Proto.Types
+  ) where
 
 import Data.Kind
 import GHC.TypeLits

hbs2-core/lib/HBS2/Prelude.hs

@@ -2,12 +2,13 @@ module HBS2.Prelude
   ( module Data.String
   , module Safe
   , MonadIO(..)
-  -- , module HBS2.Prelude
+  , void
   ) where
 
 import Data.String (IsString(..))
 import Safe
 import Control.Monad.IO.Class (MonadIO(..))
+import Control.Monad (void)
 
 
 

hbs2-core/test/HasProtocol.hs

@@ -2,11 +2,13 @@ module HasProtocol
   ( module HBS2.Net.Proto.Types
   , module HBS2.Net.Messaging
   , module HBS2.Net.Messaging.Fake
+  , module HBS2.Net.Peer
   ) where
 
-import HBS2.Net.Proto.Types
 import HBS2.Net.Messaging
 import HBS2.Net.Messaging.Fake
+import HBS2.Net.Peer
+import HBS2.Net.Proto.Types
 
 
 

hbs2-core/test/TestUniqProtoId.hs

@@ -2,113 +2,16 @@
 {-# Language UndecidableInstances #-}
 module TestUniqProtoId where
 
+import HBS2.Prelude
+
 import HasProtocol
 import FakeMessaging
 
-import GHC.TypeLits
-import Data.Proxy
-import Data.Map qualified as Map
-import Control.Monad.Reader
-
 import Control.Concurrent.Async
-import Data.Foldable
-import Safe
 
 import Prettyprinter hiding (pipe)
 
 
-data AnyMessage e = AnyMessage Integer (Encoded e)
-
-data EngineEnv e = forall bus . (Messaging bus e (AnyMessage e))  =>
-  EngineEnv
-  { peer   :: Maybe (Peer e)
-  , self   :: Peer e
-  , bus    :: bus
-  }
-
-data AnyProtocol e m = forall p  . ( HasProtocol e p
-                                   , KnownNat (ProtocolId p)
-                                   , Response e p m
-                                   ) =>
-  AnyProtocol
-  { myProtoId   :: Integer
-  , protoDecode :: Encoded e -> Maybe p
-  , protoEncode :: p -> Encoded e
-  , handle      :: p -> m ()
-  }
-
-makeResponse :: forall e p  m . ( MonadIO m
-                                , Response e p m
-                                , HasProtocol e p
-                                )
-            => (p ->  m ()) -> AnyProtocol e m
-
-makeResponse h = AnyProtocol { myProtoId  = natVal (Proxy @(ProtocolId p))
-                             , protoDecode = decode
-                             , protoEncode = encode
-                             , handle = h
-                             }
-
-
-newtype EngineM e m a = EngineM { fromEngine :: ReaderT (EngineEnv e) m a }
-                        deriving ( Functor
-                                 , Applicative
-                                 , Monad
-                                 , MonadTrans
-                                 , MonadIO
-                                 , MonadReader (EngineEnv e)
-                                )
-
-runEngineM :: EngineEnv e -> EngineM e m a -> m a
-runEngineM e f = runReaderT (fromEngine f) e
-
-
-instance (MonadIO m, HasProtocol e p) => Request e p (EngineM e m) where
-  request p msg = do
-    let proto = protoId @e @p (Proxy @p)
-    ask >>= \case
-      EngineEnv { self = s, bus = b} -> do
-        liftIO $ sendTo b (To p) (From s) (AnyMessage proto (encode msg))
-
-instance (MonadIO m, HasProtocol e p) => Response e p (EngineM e m) where
-  response resp = do
-    env <- ask
-    let proto = protoId @e @p (Proxy @p)
-    case env of
-      (EngineEnv { peer = Just p
-                 , bus = b
-                 , self = s
-                 } ) -> do
-                  liftIO $ sendTo b (To p) (From s) (AnyMessage proto (encode resp))
-      _ -> pure ()
-
-
-
-
-newEnv :: forall e bus m . (Monad m, Messaging bus e (AnyMessage e)) => Peer e -> bus -> m (EngineEnv e)
-newEnv p pipe = pure $ EngineEnv Nothing p pipe
-
-
-runPeer :: MonadIO m => EngineEnv e -> [AnyProtocol e (EngineM e m)] -> m a
-runPeer env@(EngineEnv {self = me, bus = pipe}) hh = do
-
-  let resp = [ (pid, a) | a@AnyProtocol { myProtoId = pid } <- hh ]
-
-  let disp = Map.fromList resp
-
-  runEngineM env $ do
-
-    forever $ do
-      messages <- receive pipe (To me)
-
-      for_ messages $ \(From pip, AnyMessage n msg) -> do
-
-        local (\e -> e { peer = Just pip  } ) $ do
-
-          case Map.lookup n disp of
-            Just (AnyProtocol {protoDecode = decoder, handle = h}) -> maybe (pure ()) h (decoder msg)
-            Nothing -> pure ()
-
 data PingPong e = Ping Int
                 | Pong Int
                 deriving stock (Show,Read)
@@ -132,13 +35,25 @@ instance HasProtocol Fake (PeekPoke Fake) where
   encode = show
 
 
-pingPongHandler :: forall e m  . (MonadIO m, Response e (PingPong e) m, HasProtocol e (PingPong e)) => PingPong e -> m ()
+pingPongHandler :: forall e m  . ( MonadIO m
+                                 , Response e (PingPong e) m
+                                 , HasProtocol e (PingPong e)
+                                 )
+                => PingPong e
+                -> m ()
+
 pingPongHandler  =
   \case
     Ping c -> liftIO (print $ "effect: PING" <+> pretty c) >> response (Pong @e c)
     Pong c -> liftIO (print $ "effect: PONG" <+> pretty c) >> response (Ping @e (succ c))
 
-peekPokeHandler :: forall e m  . (MonadIO m, Response e (PeekPoke e) m, HasProtocol e (PeekPoke e)) => PeekPoke e -> m ()
+peekPokeHandler :: forall e m  . ( MonadIO m
+                                 , Response e (PeekPoke e) m
+                                 , HasProtocol e (PeekPoke e)
+                                 )
+                => PeekPoke e
+                -> m ()
+
 peekPokeHandler =
   \case
     Peek c -> liftIO (print $ "effect: Peek" <+> pretty c) >> response (Poke @e c)
@@ -146,9 +61,8 @@ peekPokeHandler =
     Nop    -> liftIO (print $ pretty "effect: Nop") >> response (Peek @e 1)
 
 
-testUniqiProtoId :: IO ()
+testUniqProtoId :: IO ()
-testUniqiProtoId = do
+testUniqProtoId = do
-
 
   fake <- newFakeP2P True