{-# LANGUAGE BangPatterns          #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE NamedFieldPuns        #-}
{-# LANGUAGE PolyKinds             #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TupleSections         #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}

{-# LANGUAGE UndecidableInstances  #-}

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

import Data.Kind (Type)

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

import Ouroboros.Network.Channel
import Ouroboros.Network.Driver.Simple (DecoderFailure (..), Role (..))
import Ouroboros.Network.Util.ShowProxy

import Control.Monad.Class.MonadAsync
import Control.Monad.Class.MonadFork
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 actually 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.
--


driverStateful :: forall ps (pr :: PeerRole) failure bytes (f :: ps -> Type) m.
                ( MonadAsync       m
                , MonadMask        m
                , Show failure
                , forall (st' :: ps) tok. tok ~ StateToken st' => Show tok
                , ShowProxy ps
                )
             => Tracer m (TraceSendRecv ps f)
             -> Codec ps failure f m bytes
             -> Channel m bytes
             -> Driver ps pr bytes failure (Maybe bytes) f m
driverStateful :: forall ps (pr :: PeerRole) failure bytes (f :: ps -> *)
       (m :: * -> *).
(MonadAsync m, MonadMask m, Show failure,
 forall (st' :: ps) tok. (tok ~ StateToken st') => Show tok,
 ShowProxy ps) =>
Tracer m (TraceSendRecv ps f)
-> Codec ps failure f m bytes
-> Channel m bytes
-> Driver ps pr bytes failure (Maybe bytes) f m
driverStateful Tracer m (TraceSendRecv ps f)
tracer Codec{forall (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
f st -> Message ps st st' -> bytes
encode :: forall (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
f st -> Message ps st st' -> bytes
encode :: forall ps failure (f :: ps -> *) (m :: * -> *) bytes.
Codec ps failure f m bytes
-> forall (st :: ps) (st' :: ps).
   (StateTokenI st, ActiveState st) =>
   f st -> Message ps st st' -> bytes
encode, forall (st :: ps).
ActiveState st =>
StateToken st
-> f st -> m (DecodeStep bytes failure m (SomeMessage st))
decode :: forall (st :: ps).
ActiveState st =>
StateToken st
-> f st -> m (DecodeStep bytes failure m (SomeMessage st))
decode :: forall ps failure (f :: ps -> *) (m :: * -> *) bytes.
Codec ps failure f m bytes
-> forall (st :: ps).
   ActiveState st =>
   StateToken st
   -> f 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} = do
    Driver { ReflRelativeAgency
  (StateAgency st) 'WeHaveAgency (Relative pr (StateAgency st))
-> f st -> Message ps st st' -> m ()
forall (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
ReflRelativeAgency
  (StateAgency st) 'WeHaveAgency (Relative pr (StateAgency st))
-> f st -> Message ps st st' -> m ()
forall (st :: ps) (st' :: ps).
(StateTokenI st, StateTokenI st', ActiveState st) =>
ReflRelativeAgency
  (StateAgency st) 'WeHaveAgency (Relative pr (StateAgency st))
-> f st -> Message ps st st' -> m ()
sendMessage :: forall (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
ReflRelativeAgency
  (StateAgency st) 'WeHaveAgency (Relative pr (StateAgency st))
-> f st -> Message ps st st' -> m ()
sendMessage :: forall (st :: ps) (st' :: ps).
(StateTokenI st, StateTokenI st', ActiveState st) =>
ReflRelativeAgency
  (StateAgency st) 'WeHaveAgency (Relative pr (StateAgency st))
-> f st -> Message ps st st' -> m ()
sendMessage
           , ReflRelativeAgency
  (StateAgency st) 'TheyHaveAgency (Relative pr (StateAgency st))
-> f st -> Maybe bytes -> m (SomeMessage st, Maybe bytes)
forall (st :: ps).
(StateTokenI st, ActiveState st) =>
ReflRelativeAgency
  (StateAgency st) 'TheyHaveAgency (Relative pr (StateAgency st))
-> f st -> Maybe bytes -> m (SomeMessage st, Maybe bytes)
recvMessage :: forall (st :: ps).
(StateTokenI st, ActiveState st) =>
ReflRelativeAgency
  (StateAgency st) 'TheyHaveAgency (Relative pr (StateAgency st))
-> f st -> Maybe bytes -> m (SomeMessage st, Maybe bytes)
recvMessage :: forall (st :: ps).
(StateTokenI st, ActiveState st) =>
ReflRelativeAgency
  (StateAgency st) 'TheyHaveAgency (Relative pr (StateAgency st))
-> f 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))
                -> f st
                -> Message ps st st'
                -> m ()
    sendMessage :: forall (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
ReflRelativeAgency
  (StateAgency st) 'WeHaveAgency (Relative pr (StateAgency st))
-> f st -> Message ps st st' -> m ()
sendMessage !ReflRelativeAgency
  (StateAgency st) 'WeHaveAgency (Relative pr (StateAgency st))
_ f st
f Message ps st st'
msg = do
      bytes -> m ()
send (f st -> Message ps st st' -> bytes
forall (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
f st -> Message ps st st' -> bytes
encode f st
f Message ps st st'
msg)
      Tracer m (TraceSendRecv ps f) -> TraceSendRecv ps f -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceSendRecv ps f)
tracer (AnyMessage ps f -> TraceSendRecv ps f
forall ps (f :: ps -> *). AnyMessage ps f -> TraceSendRecv ps f
TraceSendMsg (f st -> Message ps st st' -> AnyMessage ps f
forall ps (f :: ps -> *) (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
f st -> Message ps st st' -> AnyMessage ps f
AnyMessage f st
f Message ps st st'
msg))

    recvMessage :: forall (st :: ps).
                   StateTokenI st
                => ActiveState st
                => ReflRelativeAgency (StateAgency st)
                                        TheyHaveAgency
                                       (Relative pr (StateAgency st))
                -> f st
                -> Maybe bytes
                -> m (SomeMessage st, Maybe bytes)
    recvMessage :: forall (st :: ps).
(StateTokenI st, ActiveState st) =>
ReflRelativeAgency
  (StateAgency st) 'TheyHaveAgency (Relative pr (StateAgency st))
-> f st -> Maybe bytes -> m (SomeMessage st, Maybe bytes)
recvMessage !ReflRelativeAgency
  (StateAgency st) 'TheyHaveAgency (Relative pr (StateAgency st))
_ f st
f Maybe bytes
trailing = do
      let tok :: StateToken st
tok = StateToken st
forall {ps} (st :: ps). StateTokenI st => StateToken st
stateToken
      decoder <- StateToken st
-> f st -> m (DecodeStep bytes failure m (SomeMessage st))
forall (st :: ps).
ActiveState st =>
StateToken st
-> f st -> m (DecodeStep bytes failure m (SomeMessage st))
decode StateToken st
tok f st
f
      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 f) -> TraceSendRecv ps f -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceSendRecv ps f)
tracer (AnyMessage ps f -> TraceSendRecv ps f
forall ps (f :: ps -> *). AnyMessage ps f -> TraceSendRecv ps f
TraceRecvMsg (f st -> Message ps st st' -> AnyMessage ps f
forall ps (f :: ps -> *) (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
f st -> Message ps st st' -> AnyMessage ps f
AnyMessage f st
f 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 ->
          DecoderFailure -> 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 (StateToken st -> failure -> DecoderFailure
forall ps (st :: ps) failure.
(Show failure, Show (StateToken st), ShowProxy ps,
 ActiveState st) =>
StateToken st -> failure -> DecoderFailure
DecoderFailure StateToken st
tok 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 f m a .
     ( MonadAsync       m
     , MonadMask        m
     , Show failure
     , forall (st' :: ps) stok. stok ~ StateToken st' => Show stok
     , ShowProxy ps
     )
  => Tracer m (TraceSendRecv ps f)
  -> Codec ps failure f m bytes
  -> Channel m bytes
  -> f st
  -> Peer ps pr st f m a
  -> m (a, Maybe bytes)
runPeer :: forall ps (st :: ps) (pr :: PeerRole) failure bytes (f :: ps -> *)
       (m :: * -> *) a.
(MonadAsync m, MonadMask m, Show failure,
 forall (st' :: ps) stok. (stok ~ StateToken st') => Show stok,
 ShowProxy ps) =>
Tracer m (TraceSendRecv ps f)
-> Codec ps failure f m bytes
-> Channel m bytes
-> f st
-> Peer ps pr st f m a
-> m (a, Maybe bytes)
runPeer Tracer m (TraceSendRecv ps f)
tracer Codec ps failure f m bytes
codec Channel m bytes
channel f st
f Peer ps pr st f m a
peer =
    Driver ps pr bytes failure (Maybe bytes) f m
-> f st -> Peer ps pr st f m a -> m (a, Maybe bytes)
forall {k1} {k2} ps (st :: ps) (pr :: PeerRole) (bytes :: k1)
       (failure :: k2) dstate (f :: ps -> *) (m :: * -> *) a.
MonadSTM m =>
Driver ps pr bytes failure dstate f m
-> f st -> Peer ps pr st f m a -> m (a, dstate)
runPeerWithDriver Driver ps pr bytes failure (Maybe bytes) f m
driver f st
f Peer ps pr st f m a
peer
  where
    driver :: Driver ps pr bytes failure (Maybe bytes) f m
driver = Tracer m (TraceSendRecv ps f)
-> Codec ps failure f m bytes
-> Channel m bytes
-> Driver ps pr bytes failure (Maybe bytes) f m
forall ps (pr :: PeerRole) failure bytes (f :: ps -> *)
       (m :: * -> *).
(MonadAsync m, MonadMask m, Show failure,
 forall (st' :: ps) tok. (tok ~ StateToken st') => Show tok,
 ShowProxy ps) =>
Tracer m (TraceSendRecv ps f)
-> Codec ps failure f m bytes
-> Channel m bytes
-> Driver ps pr bytes failure (Maybe bytes) f m
driverStateful Tracer m (TraceSendRecv ps f)
tracer Codec ps failure f 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


-- | 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 :: forall ps pr st failure bytes f m a b.
                     ( MonadAsync       m
                     , MonadMask        m
                     , Show failure
                     , forall (st' :: ps) tok. tok ~ StateToken st' => Show tok
                     , ShowProxy ps
                     )
                  => m (Channel m bytes, Channel m bytes)
                  -> Tracer m (Role, TraceSendRecv ps f)
                  -> Codec ps failure f m bytes
                  -> f st
                  -> Peer ps             pr  st f m a
                  -> Peer ps (FlipAgency pr) st f m b
                  -> m (a, b)
runConnectedPeers :: forall ps (pr :: PeerRole) (st :: ps) failure bytes (f :: ps -> *)
       (m :: * -> *) a b.
(MonadAsync m, MonadMask m, Show failure,
 forall (st' :: ps) tok. (tok ~ StateToken st') => Show tok,
 ShowProxy ps) =>
m (Channel m bytes, Channel m bytes)
-> Tracer m (Role, TraceSendRecv ps f)
-> Codec ps failure f m bytes
-> f st
-> Peer ps pr st f m a
-> Peer ps (FlipAgency pr) st f m b
-> m (a, b)
runConnectedPeers m (Channel m bytes, Channel m bytes)
createChannels Tracer m (Role, TraceSendRecv ps f)
tracer Codec ps failure f m bytes
codec f st
f Peer ps pr st f m a
client Peer ps (FlipAgency pr) st f 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) ->

    (do String -> m ()
forall (m :: * -> *). MonadThread m => String -> m ()
labelThisThread String
"client"
        (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 f)
-> Codec ps failure f m bytes
-> Channel m bytes
-> f st
-> Peer ps pr st f m a
-> m (a, Maybe bytes)
forall ps (st :: ps) (pr :: PeerRole) failure bytes (f :: ps -> *)
       (m :: * -> *) a.
(MonadAsync m, MonadMask m, Show failure,
 forall (st' :: ps) stok. (stok ~ StateToken st') => Show stok,
 ShowProxy ps) =>
Tracer m (TraceSendRecv ps f)
-> Codec ps failure f m bytes
-> Channel m bytes
-> f st
-> Peer ps pr st f m a
-> m (a, Maybe bytes)
runPeer Tracer m (TraceSendRecv ps f)
tracerClient Codec ps failure f m bytes
codec Channel m bytes
clientChannel f st
f Peer ps pr st f 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`
    (do String -> m ()
forall (m :: * -> *). MonadThread m => String -> m ()
labelThisThread String
"server"
        (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 f)
-> Codec ps failure f m bytes
-> Channel m bytes
-> f st
-> Peer ps (FlipAgency pr) st f m b
-> m (b, Maybe bytes)
forall ps (st :: ps) (pr :: PeerRole) failure bytes (f :: ps -> *)
       (m :: * -> *) a.
(MonadAsync m, MonadMask m, Show failure,
 forall (st' :: ps) stok. (stok ~ StateToken st') => Show stok,
 ShowProxy ps) =>
Tracer m (TraceSendRecv ps f)
-> Codec ps failure f m bytes
-> Channel m bytes
-> f st
-> Peer ps pr st f m a
-> m (a, Maybe bytes)
runPeer Tracer m (TraceSendRecv ps f)
tracerServer Codec ps failure f m bytes
codec Channel m bytes
serverChannel f st
f Peer ps (FlipAgency pr) st f m b
server
    )
  where
    tracerClient :: Tracer m (TraceSendRecv ps f)
tracerClient = (TraceSendRecv ps f -> (Role, TraceSendRecv ps f))
-> Tracer m (Role, TraceSendRecv ps f)
-> Tracer m (TraceSendRecv ps f)
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 f)
tracer
    tracerServer :: Tracer m (TraceSendRecv ps f)
tracerServer = (TraceSendRecv ps f -> (Role, TraceSendRecv ps f))
-> Tracer m (Role, TraceSendRecv ps f)
-> Tracer m (TraceSendRecv ps f)
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 f)
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
       , Show failure
       , forall (st' :: ps) tok. tok ~ StateToken st' => Show tok
       , ShowProxy ps
       )
    => m (Channel m bytes, Channel m bytes)
    -> Tracer m (Role, TraceSendRecv ps f)
    -> Codec ps failure f m bytes
    -> Codec ps failure f m bytes
    -> f st
    -> Peer ps             pr  st f m a
    -> Peer ps (FlipAgency pr) st f m b
    -> m (a, b)
runConnectedPeersAsymmetric :: forall (m :: * -> *) failure ps bytes (f :: ps -> *) (st :: ps)
       (pr :: PeerRole) a b.
(MonadAsync m, MonadMask m, Show failure,
 forall (st' :: ps) tok. (tok ~ StateToken st') => Show tok,
 ShowProxy ps) =>
m (Channel m bytes, Channel m bytes)
-> Tracer m (Role, TraceSendRecv ps f)
-> Codec ps failure f m bytes
-> Codec ps failure f m bytes
-> f st
-> Peer ps pr st f m a
-> Peer ps (FlipAgency pr) st f m b
-> m (a, b)
runConnectedPeersAsymmetric m (Channel m bytes, Channel m bytes)
createChannels Tracer m (Role, TraceSendRecv ps f)
tracer Codec ps failure f m bytes
codec Codec ps failure f m bytes
codec' f st
f Peer ps pr st f m a
client Peer ps (FlipAgency pr) st f 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 f)
-> Codec ps failure f m bytes
-> Channel m bytes
-> f st
-> Peer ps pr st f m a
-> m (a, Maybe bytes)
forall ps (st :: ps) (pr :: PeerRole) failure bytes (f :: ps -> *)
       (m :: * -> *) a.
(MonadAsync m, MonadMask m, Show failure,
 forall (st' :: ps) stok. (stok ~ StateToken st') => Show stok,
 ShowProxy ps) =>
Tracer m (TraceSendRecv ps f)
-> Codec ps failure f m bytes
-> Channel m bytes
-> f st
-> Peer ps pr st f m a
-> m (a, Maybe bytes)
runPeer Tracer m (TraceSendRecv ps f)
tracerClient Codec ps failure f m bytes
codec  Channel m bytes
clientChannel f st
f Peer ps pr st f 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 f)
-> Codec ps failure f m bytes
-> Channel m bytes
-> f st
-> Peer ps (FlipAgency pr) st f m b
-> m (b, Maybe bytes)
forall ps (st :: ps) (pr :: PeerRole) failure bytes (f :: ps -> *)
       (m :: * -> *) a.
(MonadAsync m, MonadMask m, Show failure,
 forall (st' :: ps) stok. (stok ~ StateToken st') => Show stok,
 ShowProxy ps) =>
Tracer m (TraceSendRecv ps f)
-> Codec ps failure f m bytes
-> Channel m bytes
-> f st
-> Peer ps pr st f m a
-> m (a, Maybe bytes)
runPeer Tracer m (TraceSendRecv ps f)
tracerServer Codec ps failure f m bytes
codec' Channel m bytes
serverChannel f st
f Peer ps (FlipAgency pr) st f m b
server)
  where
    tracerClient :: Tracer m (TraceSendRecv ps f)
tracerClient = (TraceSendRecv ps f -> (Role, TraceSendRecv ps f))
-> Tracer m (Role, TraceSendRecv ps f)
-> Tracer m (TraceSendRecv ps f)
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 f)
tracer
    tracerServer :: Tracer m (TraceSendRecv ps f)
tracerServer = (TraceSendRecv ps f -> (Role, TraceSendRecv ps f))
-> Tracer m (Role, TraceSendRecv ps f)
-> Tracer m (TraceSendRecv ps f)
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 f)
tracer


data TraceSendRecv ps (f :: ps -> Type) where
  TraceSendMsg :: AnyMessage ps f -> TraceSendRecv ps f
  TraceRecvMsg :: AnyMessage ps f -> TraceSendRecv ps f

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