{-# LANGUAGE BangPatterns         #-}
{-# LANGUAGE DataKinds            #-}
{-# LANGUAGE FlexibleContexts     #-}
{-# LANGUAGE GADTs                #-}
{-# LANGUAGE NamedFieldPuns       #-}
{-# LANGUAGE PolyKinds            #-}
{-# LANGUAGE RankNTypes           #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE TypeFamilies         #-}
-- @UndecidableInstances@ extensions is required for defining @Show@ instance
-- of @'TraceSendRecv'@.
{-# LANGUAGE UndecidableInstances #-}

-- | Drivers for running 'Peer's with a 'Codec' and a 'Channel'.
--
module Network.TypedProtocol.Driver.Simple
  ( -- * Introduction
    -- $intro
    -- * Normal peers
    runPeer
  , TraceSendRecv (..)
  , Role (..)
    -- * Pipelined peers
  , runPipelinedPeer
    -- * Connected peers
  , runConnectedPeers
  , runConnectedPeersPipelined
  , runConnectedPeersAsymmetric
    -- * Driver utilities
    -- | This may be useful if you want to write your own driver.
  , driverSimple
  , runDecoderWithChannel
  ) where

import           Network.TypedProtocol.Channel
import           Network.TypedProtocol.Codec
import           Network.TypedProtocol.Core
import           Network.TypedProtocol.Driver
import           Network.TypedProtocol.Peer

import           Control.Monad.Class.MonadAsync
import           Control.Monad.Class.MonadThrow
import           Control.Tracer (Tracer (..), contramap, traceWith)


-- $intro
--
-- A 'Peer' is a particular implementation of an agent that engages in a
-- typed protocol. To actualy run one we need a source and sink for the typed
-- protocol messages. These are provided by a 'Channel' and a 'Codec'. The
-- 'Channel' represents one end of an untyped duplex message transport, and
-- the 'Codec' handles conversion between the typed protocol messages and
-- the untyped channel.
--
-- So given the 'Peer' and a compatible 'Codec' and 'Channel' we can run the
-- peer in some appropriate monad. The peer and codec have to agree on
-- the same protocol and role in that protocol. The codec and channel have to
-- agree on the same untyped medium, e.g. text or bytes. All three have to
-- agree on the same monad in which they will run.
--
-- This module provides drivers for normal and pipelined peers. There is
-- very little policy involved here so typically it should be possible to
-- use these drivers, and customise things by adjusting the peer, or codec
-- or channel.
--
-- It is of course possible to write custom drivers and the code for these ones
-- may provide a useful starting point. The 'runDecoder' function may be a
-- helpful utility for use in custom drives.
--

-- | Structured 'Tracer' output for 'runPeer' and derivitives.
--
data TraceSendRecv ps where
     TraceSendMsg :: AnyMessage ps -> TraceSendRecv ps
     TraceRecvMsg :: AnyMessage ps -> TraceSendRecv ps

instance Show (AnyMessage ps) => Show (TraceSendRecv ps) where
  show :: TraceSendRecv ps -> String
show (TraceSendMsg AnyMessage ps
msg) = String
"Send " String -> ShowS
forall a. [a] -> [a] -> [a]
++ AnyMessage ps -> String
forall a. Show a => a -> String
show AnyMessage ps
msg
  show (TraceRecvMsg AnyMessage ps
msg) = String
"Recv " String -> ShowS
forall a. [a] -> [a] -> [a]
++ AnyMessage ps -> String
forall a. Show a => a -> String
show AnyMessage ps
msg


driverSimple :: forall ps pr failure bytes m.
                (MonadThrow m, Exception failure)
             => Tracer m (TraceSendRecv ps)
             -> Codec ps failure m bytes
             -> Channel m bytes
             -> Driver ps pr (Maybe bytes) m
driverSimple :: forall ps (pr :: PeerRole) failure bytes (m :: * -> *).
(MonadThrow m, Exception failure) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Channel m bytes
-> Driver ps pr (Maybe bytes) m
driverSimple Tracer m (TraceSendRecv ps)
tracer Codec{forall (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
Message ps st st' -> bytes
encode :: forall (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
Message ps st st' -> bytes
encode :: forall ps failure (m :: * -> *) bytes.
Codec ps failure m bytes
-> forall (st :: ps) (st' :: ps).
   (StateTokenI st, ActiveState st) =>
   Message ps st st' -> bytes
encode, forall (st :: ps).
ActiveState st =>
StateToken st -> m (DecodeStep bytes failure m (SomeMessage st))
decode :: forall (st :: ps).
ActiveState st =>
StateToken st -> m (DecodeStep bytes failure m (SomeMessage st))
decode :: forall ps failure (m :: * -> *) bytes.
Codec ps failure m bytes
-> forall (st :: ps).
   ActiveState st =>
   StateToken st -> m (DecodeStep bytes failure m (SomeMessage st))
decode} channel :: Channel m bytes
channel@Channel{bytes -> m ()
send :: bytes -> m ()
send :: forall (m :: * -> *) a. Channel m a -> a -> m ()
send} =
    Driver { ReflRelativeAgency
  (StateAgency st) 'WeHaveAgency (Relative pr (StateAgency st))
-> Message ps st st' -> m ()
forall (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
ReflRelativeAgency
  (StateAgency st) 'WeHaveAgency (Relative pr (StateAgency st))
-> Message ps st st' -> m ()
forall (st :: ps) (st' :: ps).
(StateTokenI st, StateTokenI st', ActiveState st) =>
WeHaveAgencyProof pr st -> Message ps st st' -> m ()
sendMessage :: forall (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
ReflRelativeAgency
  (StateAgency st) 'WeHaveAgency (Relative pr (StateAgency st))
-> Message ps st st' -> m ()
sendMessage :: forall (st :: ps) (st' :: ps).
(StateTokenI st, StateTokenI st', ActiveState st) =>
WeHaveAgencyProof pr st -> Message ps st st' -> m ()
sendMessage, ReflRelativeAgency
  (StateAgency st) 'TheyHaveAgency (Relative pr (StateAgency st))
-> Maybe bytes -> m (SomeMessage st, Maybe bytes)
forall (st :: ps).
(StateTokenI st, ActiveState st) =>
TheyHaveAgencyProof pr st
-> Maybe bytes -> m (SomeMessage st, Maybe bytes)
recvMessage :: forall (st :: ps).
(StateTokenI st, ActiveState st) =>
TheyHaveAgencyProof pr st
-> Maybe bytes -> m (SomeMessage st, Maybe bytes)
recvMessage :: forall (st :: ps).
(StateTokenI st, ActiveState st) =>
TheyHaveAgencyProof pr st
-> Maybe bytes -> m (SomeMessage st, Maybe bytes)
recvMessage, initialDState :: Maybe bytes
initialDState = Maybe bytes
forall a. Maybe a
Nothing }
  where
    sendMessage :: forall (st :: ps) (st' :: ps).
                   ( StateTokenI st
                   , ActiveState st
                   )
                => ReflRelativeAgency (StateAgency st)
                                       WeHaveAgency
                                      (Relative pr (StateAgency st))
                -> Message ps st st'
                -> m ()
    sendMessage :: forall (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
ReflRelativeAgency
  (StateAgency st) 'WeHaveAgency (Relative pr (StateAgency st))
-> Message ps st st' -> m ()
sendMessage !ReflRelativeAgency
  (StateAgency st) 'WeHaveAgency (Relative pr (StateAgency st))
_refl Message ps st st'
msg = do
      bytes -> m ()
send (Message ps st st' -> bytes
forall (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
Message ps st st' -> bytes
encode Message ps st st'
msg)
      Tracer m (TraceSendRecv ps) -> TraceSendRecv ps -> m ()
forall (m :: * -> *) a. Monad m => Tracer m a -> a -> m ()
traceWith Tracer m (TraceSendRecv ps)
tracer (AnyMessage ps -> TraceSendRecv ps
forall ps. AnyMessage ps -> TraceSendRecv ps
TraceSendMsg (Message ps st st' -> AnyMessage ps
forall ps (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
Message ps st st' -> AnyMessage ps
AnyMessage Message ps st st'
msg))

    recvMessage :: forall (st :: ps).
                   ( StateTokenI st
                   , ActiveState st
                   )
                => ReflRelativeAgency (StateAgency st)
                                       TheyHaveAgency
                                      (Relative pr (StateAgency st))
                -> Maybe bytes
                -> m (SomeMessage st, Maybe bytes)
    recvMessage :: forall (st :: ps).
(StateTokenI st, ActiveState st) =>
TheyHaveAgencyProof pr st
-> Maybe bytes -> m (SomeMessage st, Maybe bytes)
recvMessage !ReflRelativeAgency
  (StateAgency st) 'TheyHaveAgency (Relative pr (StateAgency st))
_refl Maybe bytes
trailing = do
      decoder <- StateToken st -> m (DecodeStep bytes failure m (SomeMessage st))
forall (st :: ps).
ActiveState st =>
StateToken st -> m (DecodeStep bytes failure m (SomeMessage st))
decode StateToken st
forall {ps} (st :: ps). StateTokenI st => StateToken st
stateToken
      result  <- runDecoderWithChannel channel trailing decoder
      case result of
        Right x :: (SomeMessage st, Maybe bytes)
x@(SomeMessage Message ps st st'
msg, Maybe bytes
_trailing') -> do
          Tracer m (TraceSendRecv ps) -> TraceSendRecv ps -> m ()
forall (m :: * -> *) a. Monad m => Tracer m a -> a -> m ()
traceWith Tracer m (TraceSendRecv ps)
tracer (AnyMessage ps -> TraceSendRecv ps
forall ps. AnyMessage ps -> TraceSendRecv ps
TraceRecvMsg (Message ps st st' -> AnyMessage ps
forall ps (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
Message ps st st' -> AnyMessage ps
AnyMessage Message ps st st'
msg))
          (SomeMessage st, Maybe bytes) -> m (SomeMessage st, Maybe bytes)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (SomeMessage st, Maybe bytes)
x
        Left failure
failure ->
          failure -> m (SomeMessage st, Maybe bytes)
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO failure
failure


-- | Run a peer with the given channel via the given codec.
--
-- This runs the peer to completion (if the protocol allows for termination).
--
runPeer
  :: forall ps (st :: ps) pr failure bytes m a.
     (MonadThrow m, Exception failure)
  => Tracer m (TraceSendRecv ps)
  -> Codec ps failure m bytes
  -> Channel m bytes
  -> Peer ps pr 'NonPipelined st m a
  -> m (a, Maybe bytes)
runPeer :: forall ps (st :: ps) (pr :: PeerRole) failure bytes (m :: * -> *)
       a.
(MonadThrow m, Exception failure) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Channel m bytes
-> Peer ps pr 'NonPipelined st m a
-> m (a, Maybe bytes)
runPeer Tracer m (TraceSendRecv ps)
tracer Codec ps failure m bytes
codec Channel m bytes
channel Peer ps pr 'NonPipelined st m a
peer =
    Driver ps pr (Maybe bytes) m
-> Peer ps pr 'NonPipelined st m a -> m (a, Maybe bytes)
forall ps (st :: ps) (pr :: PeerRole) dstate (m :: * -> *) a.
Monad m =>
Driver ps pr dstate m
-> Peer ps pr 'NonPipelined st m a -> m (a, dstate)
runPeerWithDriver Driver ps pr (Maybe bytes) m
driver Peer ps pr 'NonPipelined st m a
peer
  where
    driver :: Driver ps pr (Maybe bytes) m
driver = Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Channel m bytes
-> Driver ps pr (Maybe bytes) m
forall ps (pr :: PeerRole) failure bytes (m :: * -> *).
(MonadThrow m, Exception failure) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Channel m bytes
-> Driver ps pr (Maybe bytes) m
driverSimple Tracer m (TraceSendRecv ps)
tracer Codec ps failure m bytes
codec Channel m bytes
channel


-- | Run a pipelined peer with the given channel via the given codec.
--
-- This runs the peer to completion (if the protocol allows for termination).
--
-- Unlike normal peers, running pipelined peers rely on concurrency, hence the
-- 'MonadSTM' constraint.
--
runPipelinedPeer
  :: forall ps (st :: ps) pr failure bytes m a.
     (MonadAsync m, MonadThrow m, Exception failure)
  => Tracer m (TraceSendRecv ps)
  -> Codec ps failure m bytes
  -> Channel m bytes
  -> PeerPipelined ps pr st m a
  -> m (a, Maybe bytes)
runPipelinedPeer :: forall ps (st :: ps) (pr :: PeerRole) failure bytes (m :: * -> *)
       a.
(MonadAsync m, MonadThrow m, Exception failure) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Channel m bytes
-> PeerPipelined ps pr st m a
-> m (a, Maybe bytes)
runPipelinedPeer Tracer m (TraceSendRecv ps)
tracer Codec ps failure m bytes
codec Channel m bytes
channel PeerPipelined ps pr st m a
peer =
    Driver ps pr (Maybe bytes) m
-> PeerPipelined ps pr st m a -> m (a, Maybe bytes)
forall ps (st :: ps) (pr :: PeerRole) dstate (m :: * -> *) a.
MonadAsync m =>
Driver ps pr dstate m
-> PeerPipelined ps pr st m a -> m (a, dstate)
runPipelinedPeerWithDriver Driver ps pr (Maybe bytes) m
driver PeerPipelined ps pr st m a
peer
  where
    driver :: Driver ps pr (Maybe bytes) m
driver = Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Channel m bytes
-> Driver ps pr (Maybe bytes) m
forall ps (pr :: PeerRole) failure bytes (m :: * -> *).
(MonadThrow m, Exception failure) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Channel m bytes
-> Driver ps pr (Maybe bytes) m
driverSimple Tracer m (TraceSendRecv ps)
tracer Codec ps failure m bytes
codec Channel m bytes
channel


--
-- Utils
--

-- | Run a codec incremental decoder 'DecodeStep' against a channel. It also
-- takes any extra input data and returns any unused trailing data.
--
runDecoderWithChannel :: Monad m
                      => Channel m bytes
                      -> Maybe bytes
                      -> DecodeStep bytes failure m a
                      -> m (Either failure (a, Maybe bytes))

runDecoderWithChannel :: forall (m :: * -> *) bytes failure a.
Monad m =>
Channel m bytes
-> Maybe bytes
-> DecodeStep bytes failure m a
-> m (Either failure (a, Maybe bytes))
runDecoderWithChannel Channel{m (Maybe bytes)
recv :: m (Maybe bytes)
recv :: forall (m :: * -> *) a. Channel m a -> m (Maybe a)
recv} = Maybe bytes
-> DecodeStep bytes failure m a
-> m (Either failure (a, Maybe bytes))
go
  where
    go :: Maybe bytes
-> DecodeStep bytes failure m a
-> m (Either failure (a, Maybe bytes))
go Maybe bytes
_ (DecodeDone a
x Maybe bytes
trailing)         = Either failure (a, Maybe bytes)
-> m (Either failure (a, Maybe bytes))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((a, Maybe bytes) -> Either failure (a, Maybe bytes)
forall a b. b -> Either a b
Right (a
x, Maybe bytes
trailing))
    go Maybe bytes
_ (DecodeFail failure
failure)            = Either failure (a, Maybe bytes)
-> m (Either failure (a, Maybe bytes))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (failure -> Either failure (a, Maybe bytes)
forall a b. a -> Either a b
Left failure
failure)
    go Maybe bytes
Nothing         (DecodePartial Maybe bytes -> m (DecodeStep bytes failure m a)
k) = m (Maybe bytes)
recv m (Maybe bytes)
-> (Maybe bytes -> m (DecodeStep bytes failure m a))
-> m (DecodeStep bytes failure m a)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe bytes -> m (DecodeStep bytes failure m a)
k        m (DecodeStep bytes failure m a)
-> (DecodeStep bytes failure m a
    -> m (Either failure (a, Maybe bytes)))
-> m (Either failure (a, Maybe bytes))
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe bytes
-> DecodeStep bytes failure m a
-> m (Either failure (a, Maybe bytes))
go Maybe bytes
forall a. Maybe a
Nothing
    go (Just bytes
trailing) (DecodePartial Maybe bytes -> m (DecodeStep bytes failure m a)
k) = Maybe bytes -> m (DecodeStep bytes failure m a)
k (bytes -> Maybe bytes
forall a. a -> Maybe a
Just bytes
trailing) m (DecodeStep bytes failure m a)
-> (DecodeStep bytes failure m a
    -> m (Either failure (a, Maybe bytes)))
-> m (Either failure (a, Maybe bytes))
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe bytes
-> DecodeStep bytes failure m a
-> m (Either failure (a, Maybe bytes))
go Maybe bytes
forall a. Maybe a
Nothing


data Role = Client | Server
  deriving Int -> Role -> ShowS
[Role] -> ShowS
Role -> String
(Int -> Role -> ShowS)
-> (Role -> String) -> ([Role] -> ShowS) -> Show Role
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Role -> ShowS
showsPrec :: Int -> Role -> ShowS
$cshow :: Role -> String
show :: Role -> String
$cshowList :: [Role] -> ShowS
showList :: [Role] -> ShowS
Show

-- | Run two 'Peer's via a pair of connected 'Channel's and a common 'Codec'.
--
-- This is useful for tests and quick experiments.
--
-- The first argument is expected to create two channels that are connected,
-- for example 'createConnectedChannels'.
--
runConnectedPeers :: (MonadAsync m, MonadCatch m,
                      Exception failure)
                  => m (Channel m bytes, Channel m bytes)
                  -> Tracer m (Role, TraceSendRecv ps)
                  -> Codec ps failure m bytes
                  -> Peer ps             pr  'NonPipelined st m a
                  -> Peer ps (FlipAgency pr) 'NonPipelined st m b
                  -> m (a, b)
runConnectedPeers :: forall (m :: * -> *) failure bytes ps (pr :: PeerRole) (st :: ps) a
       b.
(MonadAsync m, MonadCatch m, Exception failure) =>
m (Channel m bytes, Channel m bytes)
-> Tracer m (Role, TraceSendRecv ps)
-> Codec ps failure m bytes
-> Peer ps pr 'NonPipelined st m a
-> Peer ps (FlipAgency pr) 'NonPipelined st m b
-> m (a, b)
runConnectedPeers m (Channel m bytes, Channel m bytes)
createChannels Tracer m (Role, TraceSendRecv ps)
tracer Codec ps failure m bytes
codec Peer ps pr 'NonPipelined st m a
client Peer ps (FlipAgency pr) 'NonPipelined st m b
server =
    m (Channel m bytes, Channel m bytes)
createChannels m (Channel m bytes, Channel m bytes)
-> ((Channel m bytes, Channel m bytes) -> m (a, b)) -> m (a, b)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Channel m bytes
clientChannel, Channel m bytes
serverChannel) ->

    ((a, Maybe bytes) -> a
forall a b. (a, b) -> a
fst ((a, Maybe bytes) -> a) -> m (a, Maybe bytes) -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Channel m bytes
-> Peer ps pr 'NonPipelined st m a
-> m (a, Maybe bytes)
forall ps (st :: ps) (pr :: PeerRole) failure bytes (m :: * -> *)
       a.
(MonadThrow m, Exception failure) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Channel m bytes
-> Peer ps pr 'NonPipelined st m a
-> m (a, Maybe bytes)
runPeer Tracer m (TraceSendRecv ps)
tracerClient Codec ps failure m bytes
codec Channel m bytes
clientChannel Peer ps pr 'NonPipelined st m a
client)
      m a -> m b -> m (a, b)
forall a b. m a -> m b -> m (a, b)
forall (m :: * -> *) a b. MonadAsync m => m a -> m b -> m (a, b)
`concurrently`
    ((b, Maybe bytes) -> b
forall a b. (a, b) -> a
fst ((b, Maybe bytes) -> b) -> m (b, Maybe bytes) -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Channel m bytes
-> Peer ps (FlipAgency pr) 'NonPipelined st m b
-> m (b, Maybe bytes)
forall ps (st :: ps) (pr :: PeerRole) failure bytes (m :: * -> *)
       a.
(MonadThrow m, Exception failure) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Channel m bytes
-> Peer ps pr 'NonPipelined st m a
-> m (a, Maybe bytes)
runPeer Tracer m (TraceSendRecv ps)
tracerServer Codec ps failure m bytes
codec Channel m bytes
serverChannel Peer ps (FlipAgency pr) 'NonPipelined st m b
server)
  where
    tracerClient :: Tracer m (TraceSendRecv ps)
tracerClient = (TraceSendRecv ps -> (Role, TraceSendRecv ps))
-> Tracer m (Role, TraceSendRecv ps) -> Tracer m (TraceSendRecv ps)
forall a' a. (a' -> a) -> Tracer m a -> Tracer m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap ((,) Role
Client) Tracer m (Role, TraceSendRecv ps)
tracer
    tracerServer :: Tracer m (TraceSendRecv ps)
tracerServer = (TraceSendRecv ps -> (Role, TraceSendRecv ps))
-> Tracer m (Role, TraceSendRecv ps) -> Tracer m (TraceSendRecv ps)
forall a' a. (a' -> a) -> Tracer m a -> Tracer m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap ((,) Role
Server) Tracer m (Role, TraceSendRecv ps)
tracer

runConnectedPeersPipelined :: (MonadAsync m, MonadCatch m,
                               Exception failure)
                           => m (Channel m bytes, Channel m bytes)
                           -> Tracer m (PeerRole, TraceSendRecv ps)
                           -> Codec ps failure m bytes
                           -> PeerPipelined ps             pr                st m a
                           -> Peer          ps (FlipAgency pr) 'NonPipelined st m b
                           -> m (a, b)
runConnectedPeersPipelined :: forall (m :: * -> *) failure bytes ps (pr :: PeerRole) (st :: ps) a
       b.
(MonadAsync m, MonadCatch m, Exception failure) =>
m (Channel m bytes, Channel m bytes)
-> Tracer m (PeerRole, TraceSendRecv ps)
-> Codec ps failure m bytes
-> PeerPipelined ps pr st m a
-> Peer ps (FlipAgency pr) 'NonPipelined st m b
-> m (a, b)
runConnectedPeersPipelined m (Channel m bytes, Channel m bytes)
createChannels Tracer m (PeerRole, TraceSendRecv ps)
tracer Codec ps failure m bytes
codec PeerPipelined ps pr st m a
client Peer ps (FlipAgency pr) 'NonPipelined st m b
server =
    m (Channel m bytes, Channel m bytes)
createChannels m (Channel m bytes, Channel m bytes)
-> ((Channel m bytes, Channel m bytes) -> m (a, b)) -> m (a, b)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Channel m bytes
clientChannel, Channel m bytes
serverChannel) ->

    ((a, Maybe bytes) -> a
forall a b. (a, b) -> a
fst ((a, Maybe bytes) -> a) -> m (a, Maybe bytes) -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Channel m bytes
-> PeerPipelined ps pr st m a
-> m (a, Maybe bytes)
forall ps (st :: ps) (pr :: PeerRole) failure bytes (m :: * -> *)
       a.
(MonadAsync m, MonadThrow m, Exception failure) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Channel m bytes
-> PeerPipelined ps pr st m a
-> m (a, Maybe bytes)
runPipelinedPeer Tracer m (TraceSendRecv ps)
tracerClient Codec ps failure m bytes
codec Channel m bytes
clientChannel PeerPipelined ps pr st m a
client)
      m a -> m b -> m (a, b)
forall a b. m a -> m b -> m (a, b)
forall (m :: * -> *) a b. MonadAsync m => m a -> m b -> m (a, b)
`concurrently`
    ((b, Maybe bytes) -> b
forall a b. (a, b) -> a
fst ((b, Maybe bytes) -> b) -> m (b, Maybe bytes) -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Channel m bytes
-> Peer ps (FlipAgency pr) 'NonPipelined st m b
-> m (b, Maybe bytes)
forall ps (st :: ps) (pr :: PeerRole) failure bytes (m :: * -> *)
       a.
(MonadThrow m, Exception failure) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Channel m bytes
-> Peer ps pr 'NonPipelined st m a
-> m (a, Maybe bytes)
runPeer          Tracer m (TraceSendRecv ps)
tracerServer Codec ps failure m bytes
codec Channel m bytes
serverChannel Peer ps (FlipAgency pr) 'NonPipelined st m b
server)
  where
    tracerClient :: Tracer m (TraceSendRecv ps)
tracerClient = (TraceSendRecv ps -> (PeerRole, TraceSendRecv ps))
-> Tracer m (PeerRole, TraceSendRecv ps)
-> Tracer m (TraceSendRecv ps)
forall a' a. (a' -> a) -> Tracer m a -> Tracer m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap ((,) PeerRole
AsClient) Tracer m (PeerRole, TraceSendRecv ps)
tracer
    tracerServer :: Tracer m (TraceSendRecv ps)
tracerServer = (TraceSendRecv ps -> (PeerRole, TraceSendRecv ps))
-> Tracer m (PeerRole, TraceSendRecv ps)
-> Tracer m (TraceSendRecv ps)
forall a' a. (a' -> a) -> Tracer m a -> Tracer m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap ((,) PeerRole
AsServer) Tracer m (PeerRole, TraceSendRecv ps)
tracer


-- Run the same protocol with different codes.  This is useful for testing
-- 'Handshake' protocol which knows how to decode different versions.
--
runConnectedPeersAsymmetric
    :: ( MonadAsync      m
       , MonadMask       m
       , Exception failure
       )
    => m (Channel m bytes, Channel m bytes)
    -> Tracer m (Role, TraceSendRecv ps)
    -> Codec ps failure m bytes
    -> Codec ps failure m bytes
    -> PeerPipelined ps             pr                st m a
    -> Peer          ps (FlipAgency pr) 'NonPipelined st m b
    -> m (a, b)
runConnectedPeersAsymmetric :: forall (m :: * -> *) failure bytes ps (pr :: PeerRole) (st :: ps) a
       b.
(MonadAsync m, MonadMask m, Exception failure) =>
m (Channel m bytes, Channel m bytes)
-> Tracer m (Role, TraceSendRecv ps)
-> Codec ps failure m bytes
-> Codec ps failure m bytes
-> PeerPipelined ps pr st m a
-> Peer ps (FlipAgency pr) 'NonPipelined st m b
-> m (a, b)
runConnectedPeersAsymmetric m (Channel m bytes, Channel m bytes)
createChannels Tracer m (Role, TraceSendRecv ps)
tracer Codec ps failure m bytes
codec Codec ps failure m bytes
codec' PeerPipelined ps pr st m a
client Peer ps (FlipAgency pr) 'NonPipelined st m b
server =
    m (Channel m bytes, Channel m bytes)
createChannels m (Channel m bytes, Channel m bytes)
-> ((Channel m bytes, Channel m bytes) -> m (a, b)) -> m (a, b)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Channel m bytes
clientChannel, Channel m bytes
serverChannel) ->

    ((a, Maybe bytes) -> a
forall a b. (a, b) -> a
fst ((a, Maybe bytes) -> a) -> m (a, Maybe bytes) -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Channel m bytes
-> PeerPipelined ps pr st m a
-> m (a, Maybe bytes)
forall ps (st :: ps) (pr :: PeerRole) failure bytes (m :: * -> *)
       a.
(MonadAsync m, MonadThrow m, Exception failure) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Channel m bytes
-> PeerPipelined ps pr st m a
-> m (a, Maybe bytes)
runPipelinedPeer Tracer m (TraceSendRecv ps)
tracerClient Codec ps failure m bytes
codec  Channel m bytes
clientChannel PeerPipelined ps pr st m a
client)
      m a -> m b -> m (a, b)
forall a b. m a -> m b -> m (a, b)
forall (m :: * -> *) a b. MonadAsync m => m a -> m b -> m (a, b)
`concurrently`
    ((b, Maybe bytes) -> b
forall a b. (a, b) -> a
fst ((b, Maybe bytes) -> b) -> m (b, Maybe bytes) -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Channel m bytes
-> Peer ps (FlipAgency pr) 'NonPipelined st m b
-> m (b, Maybe bytes)
forall ps (st :: ps) (pr :: PeerRole) failure bytes (m :: * -> *)
       a.
(MonadThrow m, Exception failure) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Channel m bytes
-> Peer ps pr 'NonPipelined st m a
-> m (a, Maybe bytes)
runPeer Tracer m (TraceSendRecv ps)
tracerServer Codec ps failure m bytes
codec' Channel m bytes
serverChannel Peer ps (FlipAgency pr) 'NonPipelined st m b
server)
  where
    tracerClient :: Tracer m (TraceSendRecv ps)
tracerClient = (TraceSendRecv ps -> (Role, TraceSendRecv ps))
-> Tracer m (Role, TraceSendRecv ps) -> Tracer m (TraceSendRecv ps)
forall a' a. (a' -> a) -> Tracer m a -> Tracer m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap ((,) Role
Client) Tracer m (Role, TraceSendRecv ps)
tracer
    tracerServer :: Tracer m (TraceSendRecv ps)
tracerServer = (TraceSendRecv ps -> (Role, TraceSendRecv ps))
-> Tracer m (Role, TraceSendRecv ps) -> Tracer m (TraceSendRecv ps)
forall a' a. (a' -> a) -> Tracer m a -> Tracer m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap ((,) Role
Server) Tracer m (Role, TraceSendRecv ps)
tracer