{-# LANGUAGE BangPatterns          #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE NamedFieldPuns        #-}
{-# LANGUAGE PolyKinds             #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}
-- @UndecidableInstances@ extensions is required for defining @Show@ instance
-- of @'TraceSendRecv'@.
{-# LANGUAGE UndecidableInstances  #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# HLINT ignore "Redundant bracket" #-}

-- | Drivers for running 'Peer's with a 'Codec' and a 'Channel'.
--
module Ouroboros.Network.Driver.Simple
  ( -- * Introduction
    -- $intro
    -- * Normal peers
    runPeer
  , runAnnotatedPeer
  , TraceSendRecv (..)
  , DecoderFailure (..)
    -- * Pipelined peers
  , runPipelinedPeer
  , runPipelinedAnnotatedPeer
    -- * 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.Peer

import Ouroboros.Network.Channel
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)
import Data.Functor.Identity (Identity (..))
import Data.Maybe (maybeToList)


-- $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


data DecoderFailure where
    DecoderFailure :: forall ps (st :: ps) failure.
                      ( Show failure
                      , Show (StateToken st)
                      , ShowProxy ps
                      , ActiveState st
                      )
                   => StateToken st
                   -> failure
                   -> DecoderFailure

instance Show DecoderFailure where
    show :: DecoderFailure -> String
show (DecoderFailure (StateToken st
tok :: StateToken (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
") "
        , ActiveAgency' st (StateAgency st) -> String
forall a. Show a => a -> String
show (ActiveAgency' st (StateAgency st)
forall {ps} (st :: ps) (agency :: Agency).
IsActiveState st agency =>
ActiveAgency' st agency
activeAgency :: ActiveAgency st)
        , String
" ("
        , StateToken st -> String
forall a. Show a => a -> String
show StateToken st
tok
        , String
") ("
        , failure -> String
forall a. Show a => a -> String
show failure
failure
        , String
")"
        ]

instance Exception DecoderFailure where


mkSimpleDriver :: forall ps (pr :: PeerRole) failure bytes m f annotator.
                 ( MonadThrow m
                 , ShowProxy ps
                 , forall (st :: ps) stok. stok ~ StateToken st => Show stok
                 , Show failure
                 )
              => (forall a.
                      Channel m bytes
                   -> Maybe bytes
                   -> DecodeStep bytes failure m (f a)
                   -> m (Either failure (a, Maybe bytes))
                 )
              -- ^ run incremental decoder against a channel

              -> (forall (st :: ps). annotator st -> f (SomeMessage st))
              -- ^ transform annotator to a container holding the decoded
              -- message

              -> Tracer m (TraceSendRecv ps)
              -> CodecF ps failure m annotator bytes
              -> Channel m bytes
              -> Driver ps pr (Maybe bytes) m

mkSimpleDriver :: forall ps (pr :: PeerRole) failure bytes (m :: * -> *)
       (f :: * -> *) (annotator :: ps -> *).
(MonadThrow m, ShowProxy ps,
 forall (st :: ps) stok. (stok ~ StateToken st) => Show stok,
 Show failure) =>
(forall a.
 Channel m bytes
 -> Maybe bytes
 -> DecodeStep bytes failure m (f a)
 -> m (Either failure (a, Maybe bytes)))
-> (forall (st :: ps). annotator st -> f (SomeMessage st))
-> Tracer m (TraceSendRecv ps)
-> CodecF ps failure m annotator bytes
-> Channel m bytes
-> Driver ps pr (Maybe bytes) m
mkSimpleDriver forall a.
Channel m bytes
-> Maybe bytes
-> DecodeStep bytes failure m (f a)
-> m (Either failure (a, Maybe bytes))
runDecodeSteps forall (st :: ps). annotator st -> f (SomeMessage st)
nat 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 :: * -> *) (f :: ps -> *) bytes.
CodecF ps failure m f 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 (annotator st))
decode :: forall (st :: ps).
ActiveState st =>
StateToken st -> m (DecodeStep bytes failure m (annotator st))
decode :: forall ps failure (m :: * -> *) (f :: ps -> *) bytes.
CodecF ps failure m f bytes
-> forall (st :: ps).
   ActiveState st =>
   StateToken st -> m (DecodeStep bytes failure m (f st))
decode} channel :: Channel m bytes
channel@Channel{bytes -> m ()
send :: bytes -> m ()
send :: forall (m :: * -> *) a. Channel m a -> a -> m ()
send} =
    Driver { WeHaveAgencyProof pr st -> Message ps st st' -> m ()
forall (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
WeHaveAgencyProof pr 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) =>
WeHaveAgencyProof pr 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, TheyHaveAgencyProof pr 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
                => WeHaveAgencyProof pr st
                -> Message ps st st'
                -> m ()
    sendMessage :: forall (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
WeHaveAgencyProof pr st -> Message ps st st' -> m ()
sendMessage !WeHaveAgencyProof pr st
_ 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. 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
                => 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 !TheyHaveAgencyProof pr st
_ Maybe bytes
trailing = do
      let tok :: StateToken st
tok = StateToken st
forall {ps} (st :: ps). StateTokenI st => StateToken st
stateToken
      decoder <- StateToken st -> m (DecodeStep bytes failure m (annotator st))
forall (st :: ps).
ActiveState st =>
StateToken st -> m (DecodeStep bytes failure m (annotator st))
decode StateToken st
tok
      result  <- runDecodeSteps channel trailing (nat <$> 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. 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 ->
          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)


simpleDriver :: forall ps (pr :: PeerRole) failure bytes m.
                ( MonadThrow m
                , ShowProxy ps
                , forall (st :: ps) stok. stok ~ StateToken st => Show stok
                , Show failure
                )
             => Tracer m (TraceSendRecv ps)
             -> Codec ps failure m bytes
             -> Channel m bytes
             -> Driver ps pr (Maybe bytes) m
simpleDriver :: forall ps (pr :: PeerRole) failure bytes (m :: * -> *).
(MonadThrow m, ShowProxy ps,
 forall (st :: ps) stok. (stok ~ StateToken st) => Show stok,
 Show failure) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Channel m bytes
-> Driver ps pr (Maybe bytes) m
simpleDriver = (forall a.
 Channel m bytes
 -> Maybe bytes
 -> DecodeStep bytes failure m (Identity a)
 -> m (Either failure (a, Maybe bytes)))
-> (forall (st :: ps). SomeMessage st -> Identity (SomeMessage st))
-> Tracer m (TraceSendRecv ps)
-> CodecF ps failure m SomeMessage bytes
-> Channel m bytes
-> Driver ps pr (Maybe bytes) m
forall ps (pr :: PeerRole) failure bytes (m :: * -> *)
       (f :: * -> *) (annotator :: ps -> *).
(MonadThrow m, ShowProxy ps,
 forall (st :: ps) stok. (stok ~ StateToken st) => Show stok,
 Show failure) =>
(forall a.
 Channel m bytes
 -> Maybe bytes
 -> DecodeStep bytes failure m (f a)
 -> m (Either failure (a, Maybe bytes)))
-> (forall (st :: ps). annotator st -> f (SomeMessage st))
-> Tracer m (TraceSendRecv ps)
-> CodecF ps failure m annotator bytes
-> Channel m bytes
-> Driver ps pr (Maybe bytes) m
mkSimpleDriver Channel m bytes
-> Maybe bytes
-> DecodeStep bytes failure m (Identity a)
-> m (Either failure (a, Maybe bytes))
forall a.
Channel m bytes
-> Maybe bytes
-> DecodeStep bytes failure m (Identity a)
-> m (Either failure (a, Maybe bytes))
forall (m :: * -> *) bytes failure a.
Monad m =>
Channel m bytes
-> Maybe bytes
-> DecodeStep bytes failure m (Identity a)
-> m (Either failure (a, Maybe bytes))
runDecoderWithChannel SomeMessage st -> Identity (SomeMessage st)
forall (st :: ps). SomeMessage st -> Identity (SomeMessage st)
forall a. a -> Identity a
Identity


annotatedSimpleDriver
             :: forall ps (pr :: PeerRole) failure bytes m.
                ( MonadThrow m
                , Monoid bytes
                , ShowProxy ps
                , forall (st :: ps) stok. stok ~ StateToken st => Show stok
                , Show failure
                )
             => Tracer m (TraceSendRecv ps)
             -> AnnotatedCodec ps failure m bytes
             -> Channel m bytes
             -> Driver ps pr (Maybe bytes) m
annotatedSimpleDriver :: forall ps (pr :: PeerRole) failure bytes (m :: * -> *).
(MonadThrow m, Monoid bytes, ShowProxy ps,
 forall (st :: ps) stok. (stok ~ StateToken st) => Show stok,
 Show failure) =>
Tracer m (TraceSendRecv ps)
-> AnnotatedCodec ps failure m bytes
-> Channel m bytes
-> Driver ps pr (Maybe bytes) m
annotatedSimpleDriver = (forall a.
 Channel m bytes
 -> Maybe bytes
 -> DecodeStep bytes failure m (bytes -> a)
 -> m (Either failure (a, Maybe bytes)))
-> (forall (st :: ps).
    Annotator bytes st -> bytes -> SomeMessage st)
-> Tracer m (TraceSendRecv ps)
-> CodecF ps failure m (Annotator bytes) bytes
-> Channel m bytes
-> Driver ps pr (Maybe bytes) m
forall ps (pr :: PeerRole) failure bytes (m :: * -> *)
       (f :: * -> *) (annotator :: ps -> *).
(MonadThrow m, ShowProxy ps,
 forall (st :: ps) stok. (stok ~ StateToken st) => Show stok,
 Show failure) =>
(forall a.
 Channel m bytes
 -> Maybe bytes
 -> DecodeStep bytes failure m (f a)
 -> m (Either failure (a, Maybe bytes)))
-> (forall (st :: ps). annotator st -> f (SomeMessage st))
-> Tracer m (TraceSendRecv ps)
-> CodecF ps failure m annotator bytes
-> Channel m bytes
-> Driver ps pr (Maybe bytes) m
mkSimpleDriver Channel m bytes
-> Maybe bytes
-> DecodeStep bytes failure m (bytes -> a)
-> m (Either failure (a, Maybe bytes))
forall a.
Channel m bytes
-> Maybe bytes
-> DecodeStep bytes failure m (bytes -> a)
-> m (Either failure (a, Maybe bytes))
forall (m :: * -> *) bytes failure a.
(Monad m, Monoid bytes) =>
Channel m bytes
-> Maybe bytes
-> DecodeStep bytes failure m (bytes -> a)
-> m (Either failure (a, Maybe bytes))
runAnnotatedDecoderWithChannel Annotator bytes st -> bytes -> SomeMessage st
forall (st :: ps). Annotator bytes st -> bytes -> SomeMessage st
forall {ps} bytes (st :: ps).
Annotator bytes st -> bytes -> SomeMessage st
runAnnotator


-- | 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
     , ShowProxy ps
     , forall (st' :: ps) stok. stok ~ StateToken st' => Show stok
     , Show 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, ShowProxy ps,
 forall (st' :: ps) stok. (stok ~ StateToken st') => Show stok,
 Show 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, ShowProxy ps,
 forall (st :: ps) stok. (stok ~ StateToken st) => Show stok,
 Show failure) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Channel m bytes
-> Driver ps pr (Maybe bytes) m
simpleDriver Tracer m (TraceSendRecv ps)
tracer Codec ps failure m bytes
codec Channel m bytes
channel


-- | Run a peer with the given channel via the given annotated codec.
--
-- This runs the peer to completion (if the protocol allows for termination).
--
runAnnotatedPeer
  :: forall ps (st :: ps) pr failure bytes m a .
     ( MonadThrow m
     , Monoid bytes
     , ShowProxy ps
     , forall (st' :: ps) stok. stok ~ StateToken st' => Show stok
     , Show failure
     )
  => Tracer m (TraceSendRecv ps)
  -> AnnotatedCodec ps failure m bytes
  -> Channel m bytes
  -> Peer ps pr NonPipelined st m a
  -> m (a, Maybe bytes)
runAnnotatedPeer :: forall ps (st :: ps) (pr :: PeerRole) failure bytes (m :: * -> *)
       a.
(MonadThrow m, Monoid bytes, ShowProxy ps,
 forall (st' :: ps) stok. (stok ~ StateToken st') => Show stok,
 Show failure) =>
Tracer m (TraceSendRecv ps)
-> AnnotatedCodec ps failure m bytes
-> Channel m bytes
-> Peer ps pr 'NonPipelined st m a
-> m (a, Maybe bytes)
runAnnotatedPeer Tracer m (TraceSendRecv ps)
tracer AnnotatedCodec 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)
-> AnnotatedCodec ps failure m bytes
-> Channel m bytes
-> Driver ps pr (Maybe bytes) m
forall ps (pr :: PeerRole) failure bytes (m :: * -> *).
(MonadThrow m, Monoid bytes, ShowProxy ps,
 forall (st :: ps) stok. (stok ~ StateToken st) => Show stok,
 Show failure) =>
Tracer m (TraceSendRecv ps)
-> AnnotatedCodec ps failure m bytes
-> Channel m bytes
-> Driver ps pr (Maybe bytes) m
annotatedSimpleDriver Tracer m (TraceSendRecv ps)
tracer AnnotatedCodec 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
-- 'MonadAsync' constraint.
--
runPipelinedPeer
  :: forall ps (st :: ps) pr failure bytes m a.
     ( MonadAsync m
     , MonadThrow m
     , ShowProxy ps
     , forall (st' :: ps) stok. stok ~ StateToken st' => Show stok
     , Show 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, ShowProxy ps,
 forall (st' :: ps) stok. (stok ~ StateToken st') => Show stok,
 Show 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, ShowProxy ps,
 forall (st :: ps) stok. (stok ~ StateToken st) => Show stok,
 Show failure) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Channel m bytes
-> Driver ps pr (Maybe bytes) m
simpleDriver 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 annotated codec.
--
-- This runs the peer to completion (if the protocol allows for termination).
--
-- Unlike normal peers, running pipelined peers rely on concurrency, hence the
-- 'MonadAsync' constraint.
--
runPipelinedAnnotatedPeer
  :: forall ps (st :: ps) pr failure bytes m a.
     ( MonadAsync m
     , MonadThrow m
     , Monoid bytes
     , ShowProxy ps
     , forall (st' :: ps) stok. stok ~ StateToken st' => Show stok
     , Show failure
     )
  => Tracer m (TraceSendRecv ps)
  -> AnnotatedCodec ps failure m bytes
  -> Channel m bytes
  -> PeerPipelined ps pr st m a
  -> m (a, Maybe bytes)
runPipelinedAnnotatedPeer :: forall ps (st :: ps) (pr :: PeerRole) failure bytes (m :: * -> *)
       a.
(MonadAsync m, MonadThrow m, Monoid bytes, ShowProxy ps,
 forall (st' :: ps) stok. (stok ~ StateToken st') => Show stok,
 Show failure) =>
Tracer m (TraceSendRecv ps)
-> AnnotatedCodec ps failure m bytes
-> Channel m bytes
-> PeerPipelined ps pr st m a
-> m (a, Maybe bytes)
runPipelinedAnnotatedPeer Tracer m (TraceSendRecv ps)
tracer AnnotatedCodec 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)
-> AnnotatedCodec ps failure m bytes
-> Channel m bytes
-> Driver ps pr (Maybe bytes) m
forall ps (pr :: PeerRole) failure bytes (m :: * -> *).
(MonadThrow m, Monoid bytes, ShowProxy ps,
 forall (st :: ps) stok. (stok ~ StateToken st) => Show stok,
 Show failure) =>
Tracer m (TraceSendRecv ps)
-> AnnotatedCodec ps failure m bytes
-> Channel m bytes
-> Driver ps pr (Maybe bytes) m
annotatedSimpleDriver Tracer m (TraceSendRecv ps)
tracer AnnotatedCodec 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 (Identity a)
                      -> m (Either failure (a, Maybe bytes))

runDecoderWithChannel :: forall (m :: * -> *) bytes failure a.
Monad m =>
Channel m bytes
-> Maybe bytes
-> DecodeStep bytes failure m (Identity 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 (Identity a)
-> m (Either failure (a, Maybe bytes))
go
  where
    go :: Maybe bytes
-> DecodeStep bytes failure m (Identity a)
-> m (Either failure (a, Maybe bytes))
go Maybe bytes
_ (DecodeDone (Identity 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 (Identity a))
k)    = m (Maybe bytes)
recv m (Maybe bytes)
-> (Maybe bytes -> m (DecodeStep bytes failure m (Identity a)))
-> m (DecodeStep bytes failure m (Identity 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 (Identity a))
k        m (DecodeStep bytes failure m (Identity a))
-> (DecodeStep bytes failure m (Identity 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 (Identity 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 (Identity a))
k)    = Maybe bytes -> m (DecodeStep bytes failure m (Identity a))
k (bytes -> Maybe bytes
forall a. a -> Maybe a
Just bytes
trailing) m (DecodeStep bytes failure m (Identity a))
-> (DecodeStep bytes failure m (Identity 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 (Identity a)
-> m (Either failure (a, Maybe bytes))
go Maybe bytes
forall a. Maybe a
Nothing


runAnnotatedDecoderWithChannel
  :: forall m bytes failure a.
     ( Monad m
     , Monoid bytes
     )
  => Channel m bytes
  -> Maybe bytes
  -> DecodeStep bytes failure m (bytes -> a)
  -> m (Either failure (a, Maybe bytes))

runAnnotatedDecoderWithChannel :: forall (m :: * -> *) bytes failure a.
(Monad m, Monoid bytes) =>
Channel m bytes
-> Maybe bytes
-> DecodeStep bytes failure m (bytes -> a)
-> m (Either failure (a, Maybe bytes))
runAnnotatedDecoderWithChannel Channel{m (Maybe bytes)
recv :: forall (m :: * -> *) a. Channel m a -> m (Maybe a)
recv :: m (Maybe bytes)
recv} Maybe bytes
bs0 = [bytes]
-> Maybe bytes
-> DecodeStep bytes failure m (bytes -> a)
-> m (Either failure (a, Maybe bytes))
go (Maybe bytes -> [bytes]
forall a. Maybe a -> [a]
maybeToList Maybe bytes
bs0) Maybe bytes
bs0
  where
    go :: [bytes]
       -> Maybe bytes
       -> DecodeStep bytes failure m (bytes -> a)
       -> m (Either failure (a, Maybe bytes))
    go :: [bytes]
-> Maybe bytes
-> DecodeStep bytes failure m (bytes -> a)
-> m (Either failure (a, Maybe bytes))
go ![bytes]
bytes (Just bytes
trailing) (DecodePartial Maybe bytes -> m (DecodeStep bytes failure m (bytes -> a))
k) = Maybe bytes -> m (DecodeStep bytes failure m (bytes -> a))
k (bytes -> Maybe bytes
forall a. a -> Maybe a
Just bytes
trailing) m (DecodeStep bytes failure m (bytes -> a))
-> (DecodeStep bytes failure m (bytes -> 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
>>= [bytes]
-> Maybe bytes
-> DecodeStep bytes failure m (bytes -> a)
-> m (Either failure (a, Maybe bytes))
go (bytes
trailing bytes -> [bytes] -> [bytes]
forall a. a -> [a] -> [a]
: [bytes]
bytes) Maybe bytes
forall a. Maybe a
Nothing
    go ![bytes]
bytes Maybe bytes
Nothing         (DecodePartial Maybe bytes -> m (DecodeStep bytes failure m (bytes -> a))
k) = m (Maybe bytes)
recv m (Maybe bytes)
-> (Maybe bytes -> 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
bs -> Maybe bytes -> m (DecodeStep bytes failure m (bytes -> a))
k Maybe bytes
bs m (DecodeStep bytes failure m (bytes -> a))
-> (DecodeStep bytes failure m (bytes -> 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
>>= [bytes]
-> Maybe bytes
-> DecodeStep bytes failure m (bytes -> a)
-> m (Either failure (a, Maybe bytes))
go ([bytes] -> (bytes -> [bytes]) -> Maybe bytes -> [bytes]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [bytes]
bytes (bytes -> [bytes] -> [bytes]
forall a. a -> [a] -> [a]
: [bytes]
bytes) Maybe bytes
bs) Maybe bytes
forall a. Maybe a
Nothing
    go ![bytes]
bytes Maybe bytes
_ (DecodeDone bytes -> a
f 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 (Either failure (a, Maybe bytes)
 -> m (Either failure (a, Maybe bytes)))
-> Either failure (a, Maybe bytes)
-> m (Either failure (a, Maybe bytes))
forall a b. (a -> b) -> a -> b
$ (a, Maybe bytes) -> Either failure (a, Maybe bytes)
forall a b. b -> Either a b
Right (bytes -> a
f (bytes -> a) -> bytes -> a
forall a b. (a -> b) -> a -> b
$ [bytes] -> bytes
forall a. Monoid a => [a] -> a
mconcat ([bytes] -> [bytes]
forall a. [a] -> [a]
reverse [bytes]
bytes), Maybe bytes
trailing)
    go [bytes]
_bytes 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)


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 :: forall ps pr st failure bytes m a b.
                     ( MonadAsync m
                     , MonadThrow m
                     , ShowProxy ps
                     , forall (st' :: ps) stok. stok ~ StateToken st' => Show stok
                     , Show 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 ps (pr :: PeerRole) (st :: ps) failure bytes (m :: * -> *) a
       b.
(MonadAsync m, MonadThrow m, ShowProxy ps,
 forall (st' :: ps) stok. (stok ~ StateToken st') => Show stok,
 Show 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) ->

    (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)
-> 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, ShowProxy ps,
 forall (st' :: ps) stok. (stok ~ StateToken st') => Show stok,
 Show 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`
    (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)
-> 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, ShowProxy ps,
 forall (st' :: ps) stok. (stok ~ StateToken st') => Show stok,
 Show 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
                              , ShowProxy ps
                              , forall (st' :: ps) stok. stok ~ StateToken st' => Show stok
                              , Show failure
                              )
                           => 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) NonPipelined st m b
                           -> m (a, b)
runConnectedPeersPipelined :: forall (m :: * -> *) ps failure bytes (pr :: PeerRole) (st :: ps) a
       b.
(MonadAsync m, MonadCatch m, ShowProxy ps,
 forall (st' :: ps) stok. (stok ~ StateToken st') => Show stok,
 Show failure) =>
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) 'NonPipelined 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) '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, ShowProxy ps,
 forall (st' :: ps) stok. (stok ~ StateToken st') => Show stok,
 Show 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, ShowProxy ps,
 forall (st' :: ps) stok. (stok ~ StateToken st') => Show stok,
 Show 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


-- | Run the same protocol with different codecs.  This is useful for testing
-- 'Handshake' protocol which knows how to decode different versions.
--
runConnectedPeersAsymmetric
    :: ( MonadAsync m
       , MonadMask  m
       , ShowProxy ps
       , forall (st' :: ps) stok. stok ~ StateToken st' => Show stok
       , Show failure
       )
    => 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  NonPipelined st m a
    -> Peer ps (FlipAgency pr) NonPipelined st m b
    -> m (a, b)
runConnectedPeersAsymmetric :: forall (m :: * -> *) ps failure bytes (pr :: PeerRole) (st :: ps) a
       b.
(MonadAsync m, MonadMask m, ShowProxy ps,
 forall (st' :: ps) stok. (stok ~ StateToken st') => Show stok,
 Show failure) =>
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 'NonPipelined 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' 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, ShowProxy ps,
 forall (st' :: ps) stok. (stok ~ StateToken st') => Show stok,
 Show 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, ShowProxy ps,
 forall (st' :: ps) stok. (stok ~ StateToken st') => Show stok,
 Show 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