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

-- | Drivers for running 'Peer's with a 'Codec' and a 'Channel'.
--
module Ouroboros.Network.Driver.Simple
  ( -- * Introduction
    -- $intro
    -- * Normal peers
    runPeer
  , TraceSendRecv (..)
  , DecoderFailure (..)
    -- * Pipelined peers
  , runPipelinedPeer
    -- * Connected peers
    -- TODO: move these to a test lib
  , Role (..)
  , runConnectedPeers
  , runConnectedPeersAsymmetric
  , runConnectedPeersPipelined
  ) where

import           Network.TypedProtocol.Codec
import           Network.TypedProtocol.Core
import           Network.TypedProtocol.Driver
import           Network.TypedProtocol.Pipelined

import           Ouroboros.Network.Util.ShowProxy

import           Ouroboros.Network.Channel

import           Control.Monad.Class.MonadAsync
import           Control.Monad.Class.MonadSTM
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 :: AnyMessageAndAgency ps -> TraceSendRecv ps
     TraceRecvMsg :: AnyMessageAndAgency ps -> TraceSendRecv ps

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


data DecoderFailure where
    DecoderFailure :: forall (pr :: PeerRole) ps (st :: ps) failure.
                      ( forall (st' :: ps). Show (ClientHasAgency st')
                      , forall (st' :: ps). Show (ServerHasAgency st')
                      , ShowProxy ps
                      , Show failure
                      )
                   => PeerHasAgency pr st
                   -> failure
                   -> DecoderFailure

instance Show DecoderFailure where
    show :: DecoderFailure -> String
show (DecoderFailure (PeerHasAgency pr st
tok :: PeerHasAgency pr (st :: ps)) failure
failure) =
      [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"DecoderFailure ("
        , Proxy ps -> String
forall k (p :: k). ShowProxy p => Proxy p -> String
showProxy (Proxy ps
forall k (t :: k). Proxy t
Proxy :: Proxy ps)
        , String
") "
        , PeerHasAgency pr st -> String
forall a. Show a => a -> String
show PeerHasAgency pr st
tok
        , String
") ("
        , failure -> String
forall a. Show a => a -> String
show failure
failure
        , String
")"
        ]

instance Exception DecoderFailure where


driverSimple :: forall ps failure bytes m.
                ( MonadThrow m
                , Show failure
                , forall (st :: ps). Show (ClientHasAgency st)
                , forall (st :: ps). Show (ServerHasAgency st)
                , ShowProxy ps
                )
             => Tracer m (TraceSendRecv ps)
             -> Codec ps failure m bytes
             -> Channel m bytes
             -> Driver ps (Maybe bytes) m
driverSimple :: Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Channel m bytes
-> Driver ps (Maybe bytes) m
driverSimple Tracer m (TraceSendRecv ps)
tracer Codec{forall (pr :: PeerRole) (st :: ps) (st' :: ps).
PeerHasAgency pr st -> Message ps st st' -> bytes
encode :: forall ps failure (m :: * -> *) bytes.
Codec ps failure m bytes
-> forall (pr :: PeerRole) (st :: ps) (st' :: ps).
   PeerHasAgency pr st -> Message ps st st' -> bytes
encode :: forall (pr :: PeerRole) (st :: ps) (st' :: ps).
PeerHasAgency pr st -> Message ps st st' -> bytes
encode, forall (pr :: PeerRole) (st :: ps).
PeerHasAgency pr st
-> m (DecodeStep bytes failure m (SomeMessage st))
decode :: forall ps failure (m :: * -> *) bytes.
Codec ps failure m bytes
-> forall (pr :: PeerRole) (st :: ps).
   PeerHasAgency pr st
   -> m (DecodeStep bytes failure m (SomeMessage st))
decode :: forall (pr :: PeerRole) (st :: ps).
PeerHasAgency pr st
-> m (DecodeStep bytes failure m (SomeMessage st))
decode} channel :: Channel m bytes
channel@Channel{bytes -> m ()
send :: forall (m :: * -> *) a. Channel m a -> a -> m ()
send :: bytes -> m ()
send} =
    Driver :: forall ps dstate (m :: * -> *).
(forall (pr :: PeerRole) (st :: ps) (st' :: ps).
 PeerHasAgency pr st -> Message ps st st' -> m ())
-> (forall (pr :: PeerRole) (st :: ps).
    PeerHasAgency pr st -> dstate -> m (SomeMessage st, dstate))
-> dstate
-> Driver ps dstate m
Driver { forall (pr :: PeerRole) (st :: ps) (st' :: ps).
PeerHasAgency pr st -> Message ps st st' -> m ()
sendMessage :: forall (pr :: PeerRole) (st :: ps) (st' :: ps).
PeerHasAgency pr st -> Message ps st st' -> m ()
sendMessage :: forall (pr :: PeerRole) (st :: ps) (st' :: ps).
PeerHasAgency pr st -> Message ps st st' -> m ()
sendMessage, forall (pr :: PeerRole) (st :: ps).
PeerHasAgency pr st
-> Maybe bytes -> m (SomeMessage st, Maybe bytes)
recvMessage :: forall (pr :: PeerRole) (st :: ps).
PeerHasAgency pr st
-> Maybe bytes -> m (SomeMessage st, Maybe bytes)
recvMessage :: forall (pr :: PeerRole) (st :: ps).
PeerHasAgency pr st
-> Maybe bytes -> m (SomeMessage st, Maybe bytes)
recvMessage, startDState :: Maybe bytes
startDState = Maybe bytes
forall a. Maybe a
Nothing }
  where
    sendMessage :: forall (pr :: PeerRole) (st :: ps) (st' :: ps).
                   PeerHasAgency pr st
                -> Message ps st st'
                -> m ()
    sendMessage :: PeerHasAgency pr st -> Message ps st st' -> m ()
sendMessage PeerHasAgency pr st
stok Message ps st st'
msg = do
      bytes -> m ()
send (PeerHasAgency pr st -> Message ps st st' -> bytes
forall (pr :: PeerRole) (st :: ps) (st' :: ps).
PeerHasAgency pr st -> Message ps st st' -> bytes
encode PeerHasAgency pr st
stok Message ps st st'
msg)
      Tracer m (TraceSendRecv ps) -> TraceSendRecv ps -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceSendRecv ps)
tracer (AnyMessageAndAgency ps -> TraceSendRecv ps
forall ps. AnyMessageAndAgency ps -> TraceSendRecv ps
TraceSendMsg (PeerHasAgency pr st -> Message ps st st' -> AnyMessageAndAgency ps
forall (pr :: PeerRole) ps (st :: ps) (st' :: ps).
PeerHasAgency pr st -> Message ps st st' -> AnyMessageAndAgency ps
AnyMessageAndAgency PeerHasAgency pr st
stok Message ps st st'
msg))

    recvMessage :: forall (pr :: PeerRole) (st :: ps).
                   PeerHasAgency pr st
                -> Maybe bytes
                -> m (SomeMessage st, Maybe bytes)
    recvMessage :: PeerHasAgency pr st
-> Maybe bytes -> m (SomeMessage st, Maybe bytes)
recvMessage PeerHasAgency pr st
stok Maybe bytes
trailing = do
      DecodeStep bytes failure m (SomeMessage st)
decoder <- PeerHasAgency pr st
-> m (DecodeStep bytes failure m (SomeMessage st))
forall (pr :: PeerRole) (st :: ps).
PeerHasAgency pr st
-> m (DecodeStep bytes failure m (SomeMessage st))
decode PeerHasAgency pr st
stok
      Either failure (SomeMessage st, Maybe bytes)
result  <- Channel m bytes
-> Maybe bytes
-> DecodeStep bytes failure m (SomeMessage st)
-> m (Either failure (SomeMessage st, Maybe bytes))
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 bytes
channel Maybe bytes
trailing DecodeStep bytes failure m (SomeMessage st)
decoder
      case Either failure (SomeMessage st, Maybe bytes)
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. Tracer m a -> a -> m ()
traceWith Tracer m (TraceSendRecv ps)
tracer (AnyMessageAndAgency ps -> TraceSendRecv ps
forall ps. AnyMessageAndAgency ps -> TraceSendRecv ps
TraceRecvMsg (PeerHasAgency pr st -> Message ps st st' -> AnyMessageAndAgency ps
forall (pr :: PeerRole) ps (st :: ps) (st' :: ps).
PeerHasAgency pr st -> Message ps st st' -> AnyMessageAndAgency ps
AnyMessageAndAgency PeerHasAgency pr st
stok Message ps st st'
msg))
          (SomeMessage st, Maybe bytes) -> m (SomeMessage st, Maybe bytes)
forall (m :: * -> *) a. Monad m => a -> m a
return (SomeMessage st, Maybe bytes)
x
        Left failure
failure ->
          DecoderFailure -> m (SomeMessage st, Maybe bytes)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (PeerHasAgency pr st -> failure -> DecoderFailure
forall (pr :: PeerRole) ps (st :: ps) failure.
(forall (st' :: ps). Show (ClientHasAgency st'),
 forall (st' :: ps). Show (ServerHasAgency st'), ShowProxy ps,
 Show failure) =>
PeerHasAgency pr st -> failure -> DecoderFailure
DecoderFailure PeerHasAgency pr st
stok 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
     , Show failure
     , forall (st' :: ps). Show (ClientHasAgency st')
     , forall (st' :: ps). Show (ServerHasAgency st')
     , ShowProxy ps
     )
  => Tracer m (TraceSendRecv ps)
  -> Codec ps failure m bytes
  -> Channel m bytes
  -> Peer ps pr st m a
  -> m (a, Maybe bytes)
runPeer :: Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Channel m bytes
-> Peer ps pr 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 st m a
peer =
    Driver ps (Maybe bytes) m
-> Peer ps pr st m a -> Maybe bytes -> m (a, Maybe bytes)
forall ps (st :: ps) (pr :: PeerRole) dstate (m :: * -> *) a.
Monad m =>
Driver ps dstate m -> Peer ps pr st m a -> dstate -> m (a, dstate)
runPeerWithDriver Driver ps (Maybe bytes) m
driver Peer ps pr st m a
peer (Driver ps (Maybe bytes) m -> Maybe bytes
forall ps dstate (m :: * -> *). Driver ps dstate m -> dstate
startDState Driver ps (Maybe bytes) m
driver)
  where
    driver :: Driver ps (Maybe bytes) m
driver = Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Channel m bytes
-> Driver ps (Maybe bytes) m
forall ps failure bytes (m :: * -> *).
(MonadThrow m, Show failure,
 forall (st :: ps). Show (ClientHasAgency st),
 forall (st :: ps). Show (ServerHasAgency st), ShowProxy ps) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Channel m bytes
-> Driver ps (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
     , Show failure
     , forall (st' :: ps). Show (ClientHasAgency st')
     , forall (st' :: ps). Show (ServerHasAgency st')
     , ShowProxy ps
     )
  => 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)
-> 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 (Maybe bytes) m
-> PeerPipelined ps pr st m a -> Maybe bytes -> m (a, Maybe bytes)
forall ps (st :: ps) (pr :: PeerRole) dstate (m :: * -> *) a.
MonadAsync m =>
Driver ps dstate m
-> PeerPipelined ps pr st m a -> dstate -> m (a, dstate)
runPipelinedPeerWithDriver Driver ps (Maybe bytes) m
driver PeerPipelined ps pr st m a
peer (Driver ps (Maybe bytes) m -> Maybe bytes
forall ps dstate (m :: * -> *). Driver ps dstate m -> dstate
startDState Driver ps (Maybe bytes) m
driver)
  where
    driver :: Driver ps (Maybe bytes) m
driver = Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Channel m bytes
-> Driver ps (Maybe bytes) m
forall ps failure bytes (m :: * -> *).
(MonadThrow m, Show failure,
 forall (st :: ps). Show (ClientHasAgency st),
 forall (st :: ps). Show (ServerHasAgency st), ShowProxy ps) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Channel m bytes
-> Driver ps (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 :: Channel m bytes
-> Maybe bytes
-> DecodeStep bytes failure m a
-> m (Either failure (a, Maybe bytes))
runDecoderWithChannel Channel{m (Maybe bytes)
recv :: forall (m :: * -> *) a. Channel m a -> m (Maybe a)
recv :: m (Maybe bytes)
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 (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 (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 (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 (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 (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

-- | 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 :: ( MonadSTM m
                     , MonadAsync m
                     , MonadCatch m
                     , Show failure
                     , forall (st' :: ps). Show (ClientHasAgency st')
                     , forall (st' :: ps). Show (ServerHasAgency st')
                     , ShowProxy ps
                     )
                  => m (Channel m bytes, Channel m bytes)
                  -> Tracer m (Role, TraceSendRecv ps)
                  -> Codec ps failure m bytes
                  -> Peer ps pr st m a
                  -> Peer ps (FlipAgency pr) st m b
                  -> m (a, b)
runConnectedPeers :: m (Channel m bytes, Channel m bytes)
-> Tracer m (Role, TraceSendRecv ps)
-> Codec ps failure m bytes
-> Peer ps pr st m a
-> Peer ps (FlipAgency pr) 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 st m a
client Peer ps (FlipAgency pr) 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 (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 st m a
-> m (a, Maybe bytes)
forall ps (st :: ps) (pr :: PeerRole) failure bytes (m :: * -> *)
       a.
(MonadThrow m, Show failure,
 forall (st' :: ps). Show (ClientHasAgency st'),
 forall (st' :: ps). Show (ServerHasAgency st'), ShowProxy ps) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Channel m bytes
-> Peer ps pr 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 st m a
client)
      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) st m b
-> m (b, Maybe bytes)
forall ps (st :: ps) (pr :: PeerRole) failure bytes (m :: * -> *)
       a.
(MonadThrow m, Show failure,
 forall (st' :: ps). Show (ClientHasAgency st'),
 forall (st' :: ps). Show (ServerHasAgency st'), ShowProxy ps) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Channel m bytes
-> Peer ps pr 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) 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 (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> 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 (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap ((,) Role
Server) Tracer m (Role, 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
    :: ( MonadSTM m
       , MonadAsync m
       , MonadCatch m
       , Show failure
       , forall (st' :: ps). Show (ClientHasAgency st')
       , forall (st' :: ps). Show (ServerHasAgency st')
       , ShowProxy ps
       )
    => m (Channel m bytes, Channel m bytes)
    -> Tracer m (Role, TraceSendRecv ps)
    -> Codec ps failure m bytes
    -> Codec ps failure m bytes
    -> Peer ps pr st m a
    -> Peer ps (FlipAgency pr) st m b
    -> m (a, b)
runConnectedPeersAsymmetric :: m (Channel m bytes, Channel m bytes)
-> Tracer m (Role, TraceSendRecv ps)
-> Codec ps failure m bytes
-> Codec ps failure m bytes
-> Peer ps pr st m a
-> Peer ps (FlipAgency pr) 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' Peer ps pr st m a
client Peer ps (FlipAgency pr) 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 (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 st m a
-> m (a, Maybe bytes)
forall ps (st :: ps) (pr :: PeerRole) failure bytes (m :: * -> *)
       a.
(MonadThrow m, Show failure,
 forall (st' :: ps). Show (ClientHasAgency st'),
 forall (st' :: ps). Show (ServerHasAgency st'), ShowProxy ps) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Channel m bytes
-> Peer ps pr 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 st m a
client)
      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) st m b
-> m (b, Maybe bytes)
forall ps (st :: ps) (pr :: PeerRole) failure bytes (m :: * -> *)
       a.
(MonadThrow m, Show failure,
 forall (st' :: ps). Show (ClientHasAgency st'),
 forall (st' :: ps). Show (ServerHasAgency st'), ShowProxy ps) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Channel m bytes
-> Peer ps pr 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) 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 (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> 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 (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap ((,) Role
Server) Tracer m (Role, TraceSendRecv ps)
tracer


runConnectedPeersPipelined :: ( MonadSTM m
                              , MonadAsync m
                              , MonadCatch m
                              , Show failure
                              , forall (st' :: ps). Show (ClientHasAgency st')
                              , forall (st' :: ps). Show (ServerHasAgency st')
                              , ShowProxy ps
                              )
                           => m (Channel m bytes, Channel m bytes)
                           -> Tracer m (Role, TraceSendRecv ps)
                           -> Codec ps failure m bytes
                           -> PeerPipelined ps pr st m a
                           -> Peer          ps (FlipAgency pr) st m b
                           -> m (a, b)
runConnectedPeersPipelined :: m (Channel m bytes, Channel m bytes)
-> Tracer m (Role, TraceSendRecv ps)
-> Codec ps failure m bytes
-> PeerPipelined ps pr st m a
-> Peer ps (FlipAgency pr) st m b
-> m (a, b)
runConnectedPeersPipelined m (Channel m bytes, Channel m bytes)
createChannels Tracer m (Role, TraceSendRecv ps)
tracer Codec ps failure m bytes
codec PeerPipelined ps pr st m a
client Peer ps (FlipAgency pr) 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 (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, Show failure,
 forall (st' :: ps). Show (ClientHasAgency st'),
 forall (st' :: ps). Show (ServerHasAgency st'), ShowProxy ps) =>
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 (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) st m b
-> m (b, Maybe bytes)
forall ps (st :: ps) (pr :: PeerRole) failure bytes (m :: * -> *)
       a.
(MonadThrow m, Show failure,
 forall (st' :: ps). Show (ClientHasAgency st'),
 forall (st' :: ps). Show (ServerHasAgency st'), ShowProxy ps) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Channel m bytes
-> Peer ps pr 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) 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 (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> 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 (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap ((,) Role
Server) Tracer m (Role, TraceSendRecv ps)
tracer