mirror of https://github.com/voidlizard/hbs2
still working
This commit is contained in:
Dmitry Zuikov
parent
39d7e0c035
commit
4008971946
|
|
@ -91,11 +91,11 @@
|
|||
},
|
||||
"nixpkgs": {
|
||||
"locked": {
|
||||
"lastModified": 1673163619,
|
||||
"narHash": "sha256-B33PFBL64ZgTWgMnhFL3jgheAN/DjHPsZ1Ih3z0VE5I=",
|
||||
"lastModified": 1673800717,
|
||||
"narHash": "sha256-SFHraUqLSu5cC6IxTprex/nTsI81ZQAtDvlBvGDWfnA=",
|
||||
"owner": "nixos",
|
||||
"repo": "nixpkgs",
|
||||
"rev": "8c54d842d9544361aac5f5b212ba04e4089e8efe",
|
||||
"rev": "2f9fd351ec37f5d479556cd48be4ca340da59b8f",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ()
|
||||
|
||||
|
|
@ -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]
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ()
|
||||
testUniqiProtoId = do
|
||||
|
||||
testUniqProtoId :: IO ()
|
||||
testUniqProtoId = do
|
||||
|
||||
fake <- newFakeP2P True
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue