mirror of https://github.com/voidlizard/hbs2
still working
This commit is contained in:
Dmitry Zuikov
parent
7536d9bbc9
commit
39d7e0c035
|
|
@ -13,6 +13,14 @@ import Data.Hashable
|
|||
class (Hashable (Peer e), Eq (Peer e)) => HasPeer e where
|
||||
data family (Peer e) :: Type
|
||||
|
||||
|
||||
class Response e p (m :: Type -> Type) | p -> e where
|
||||
response :: p -> m ()
|
||||
|
||||
class Request e p (m :: Type -> Type) | p -> e where
|
||||
request :: Peer e -> p -> m ()
|
||||
|
||||
|
||||
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
|
||||
|
|
|
|||
|
|
@ -1,34 +1,19 @@
|
|||
{-# Language TypeFamilyDependencies #-}
|
||||
{-# Language FunctionalDependencies #-}
|
||||
{-# Language AllowAmbiguousTypes #-}
|
||||
{-# Language UndecidableInstances #-}
|
||||
module TestUniqProtoId where
|
||||
|
||||
import HBS2.Clock
|
||||
|
||||
import HasProtocol
|
||||
import FakeMessaging
|
||||
|
||||
import Data.Kind
|
||||
import GHC.TypeLits
|
||||
import Data.Proxy
|
||||
import Data.Map qualified as Map
|
||||
import Data.Map (Map)
|
||||
import Control.Monad.Reader
|
||||
import Data.ByteString (ByteString)
|
||||
|
||||
import Control.Concurrent.Async
|
||||
import Control.Concurrent.STM
|
||||
import Control.Concurrent.STM.TChan as Chan
|
||||
import Data.Cache (Cache)
|
||||
import Data.Cache qualified as Cache
|
||||
import Data.Foldable
|
||||
import Data.Hashable
|
||||
import Data.List qualified as List
|
||||
import Data.Maybe
|
||||
import Safe
|
||||
|
||||
import Control.Logger.Simple qualified as Log
|
||||
|
||||
import Prettyprinter hiding (pipe)
|
||||
|
||||
|
||||
|
|
@ -41,11 +26,6 @@ data EngineEnv e = forall bus . (Messaging bus e (AnyMessage e)) =>
|
|||
, bus :: bus
|
||||
}
|
||||
|
||||
-- makeLenses 'EngineEnv
|
||||
|
||||
|
||||
|
||||
|
||||
data AnyProtocol e m = forall p . ( HasProtocol e p
|
||||
, KnownNat (ProtocolId p)
|
||||
, Response e p m
|
||||
|
|
@ -57,13 +37,6 @@ data AnyProtocol e m = forall p . ( HasProtocol e p
|
|||
, handle :: p -> m ()
|
||||
}
|
||||
|
||||
|
||||
class Response e p (m :: Type -> Type) where
|
||||
response :: p -> m ()
|
||||
|
||||
class Request e p (m :: Type -> Type) where
|
||||
request :: Peer e -> p -> m ()
|
||||
|
||||
makeResponse :: forall e p m . ( MonadIO m
|
||||
, Response e p m
|
||||
, HasProtocol e p
|
||||
|
|
@ -136,47 +109,46 @@ runPeer env@(EngineEnv {self = me, bus = pipe}) hh = do
|
|||
Just (AnyProtocol {protoDecode = decoder, handle = h}) -> maybe (pure ()) h (decoder msg)
|
||||
Nothing -> pure ()
|
||||
|
||||
data PingPong = Ping Int
|
||||
| Pong Int
|
||||
deriving stock (Show,Read)
|
||||
data PingPong e = Ping Int
|
||||
| Pong Int
|
||||
deriving stock (Show,Read)
|
||||
|
||||
data PeekPoke = Peek Int
|
||||
| Poke Int
|
||||
| Nop
|
||||
deriving stock (Show,Read)
|
||||
data PeekPoke e = Peek Int
|
||||
| Poke Int
|
||||
| Nop
|
||||
deriving stock (Show,Read)
|
||||
|
||||
|
||||
instance HasProtocol Fake PingPong where
|
||||
type instance ProtocolId PingPong = 1
|
||||
instance HasProtocol Fake (PingPong Fake) where
|
||||
type instance ProtocolId (PingPong Fake) = 1
|
||||
type instance Encoded Fake = String
|
||||
decode = readMay
|
||||
encode = show
|
||||
|
||||
instance HasProtocol Fake PeekPoke where
|
||||
type instance ProtocolId PeekPoke = 2
|
||||
instance HasProtocol Fake (PeekPoke Fake) where
|
||||
type instance ProtocolId (PeekPoke Fake) = 2
|
||||
type instance Encoded Fake = String
|
||||
decode = readMay
|
||||
encode = show
|
||||
|
||||
|
||||
pingPongHandler :: forall a m . (MonadIO m, Response a PingPong m, HasProtocol a PingPong) => PingPong -> m ()
|
||||
pingPongHandler =
|
||||
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 @a (Pong c)
|
||||
Pong c -> liftIO (print $ "effect: PONG" <+> pretty c) >> response @a (Ping (succ c))
|
||||
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 a m . (MonadIO m, Response a PeekPoke m, HasProtocol a PeekPoke) => PeekPoke -> 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 @a (Poke c)
|
||||
Poke c -> liftIO (print $ "effect: Poke" <+> pretty c) >> response @a Nop
|
||||
Nop -> liftIO (print $ pretty "effect: Nop") >> response @a (Peek 1)
|
||||
Peek c -> liftIO (print $ "effect: Peek" <+> pretty c) >> response (Poke @e c)
|
||||
Poke c -> liftIO (print $ "effect: Poke" <+> pretty c) >> response (Nop @e)
|
||||
Nop -> liftIO (print $ pretty "effect: Nop") >> response (Peek @e 1)
|
||||
|
||||
|
||||
testUniqiProtoId :: IO ()
|
||||
testUniqiProtoId = do
|
||||
|
||||
-- setLogLevel
|
||||
|
||||
fake <- newFakeP2P True
|
||||
|
||||
|
|
@ -187,10 +159,10 @@ testUniqiProtoId = do
|
|||
env1 <- newEnv peer1 fake
|
||||
|
||||
runEngineM env0 $ do
|
||||
request peer1 (Ping 0)
|
||||
request peer1 (Ping @Fake 0)
|
||||
|
||||
runEngineM env1 $ do
|
||||
request peer0 (Peek 0)
|
||||
request peer0 (Peek @Fake 0)
|
||||
|
||||
pip1 <- async $
|
||||
runPeer env0
|
||||
|
|
|
|||
Loading…
Reference in New Issue