mirror of https://github.com/voidlizard/hbs2
110 lines
2.7 KiB
Haskell
110 lines
2.7 KiB
Haskell
{-# Language TypeFamilyDependencies #-}
|
|
{-# Language UndecidableInstances #-}
|
|
module TestUniqProtoId where
|
|
|
|
import HBS2.Prelude
|
|
import HBS2.Prelude.Plated
|
|
|
|
import HasProtocol
|
|
import FakeMessaging
|
|
|
|
import Data.ByteString.Lazy (ByteString)
|
|
import Control.Concurrent.Async
|
|
import Codec.Serialise hiding (encode,decode)
|
|
|
|
import System.IO
|
|
|
|
import Prettyprinter hiding (pipe)
|
|
|
|
debug :: (MonadIO m) => Doc ann -> m ()
|
|
debug p = liftIO $ hPrint stderr p
|
|
|
|
data PingPong e = Ping Int
|
|
| Pong Int
|
|
deriving stock (Generic,Show,Read)
|
|
|
|
data PeekPoke e = Peek Int
|
|
| Poke Int
|
|
| Nop
|
|
deriving stock (Generic,Show,Read)
|
|
|
|
|
|
instance Serialise (PingPong e)
|
|
|
|
instance Serialise (PeekPoke e)
|
|
|
|
instance HasProtocol Fake (PingPong Fake) where
|
|
type instance ProtocolId (PingPong Fake) = 1
|
|
type instance Encoded Fake = ByteString
|
|
decode = either (const Nothing) Just . deserialiseOrFail
|
|
encode = serialise
|
|
|
|
instance HasProtocol Fake (PeekPoke Fake) where
|
|
type instance ProtocolId (PeekPoke Fake) = 2
|
|
type instance Encoded Fake = ByteString
|
|
decode = either (const Nothing) Just . deserialiseOrFail
|
|
encode = serialise
|
|
|
|
pingPongHandler :: forall e m . ( MonadIO m
|
|
, Response e (PingPong e) m
|
|
, HasProtocol e (PingPong e)
|
|
)
|
|
=> PingPong e
|
|
-> m ()
|
|
|
|
pingPongHandler =
|
|
\case
|
|
Ping c -> debug ("effect: PING" <+> pretty c) >> response (Pong @e c)
|
|
Pong c -> debug ( "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 =
|
|
\case
|
|
Peek c -> debug ("effect: Peek" <+> pretty c) >> response (Poke @e c)
|
|
Poke c -> debug ("effect: Poke" <+> pretty c) >> response (Nop @e)
|
|
Nop -> debug "effect: Nop" >> response (Peek @e 1)
|
|
|
|
|
|
testUniqProtoId :: IO ()
|
|
testUniqProtoId = do
|
|
|
|
hSetBuffering stderr LineBuffering
|
|
|
|
fake <- newFakeP2P True
|
|
|
|
let peer0 = FakePeer 0
|
|
let peer1 = FakePeer 1
|
|
|
|
env0 <- newEnv peer0 fake
|
|
env1 <- newEnv peer1 fake
|
|
|
|
runEngineM env0 $ do
|
|
request peer1 (Ping @Fake 0)
|
|
|
|
runEngineM env1 $ do
|
|
request peer0 (Peek @Fake 0)
|
|
|
|
pip1 <- async $
|
|
runPeer env0
|
|
[ makeResponse pingPongHandler
|
|
, makeResponse peekPokeHandler
|
|
]
|
|
|
|
pip2 <- async $
|
|
runPeer env1
|
|
[ makeResponse pingPongHandler
|
|
, makeResponse peekPokeHandler
|
|
]
|
|
|
|
(_, e) <- waitAnyCatchCancel [pip1, pip2]
|
|
|
|
print e
|
|
|
|
|