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

-- | Drivers for running 'Peer's.
--
module Ouroboros.Network.Driver.Limits
  ( -- * Limits
    ProtocolSizeLimits (..)
  , ProtocolTimeLimits (..)
  , ProtocolTimeLimitsWithRnd (..)
  , ProtocolLimitFailure (..)
    -- * Normal peers
  , runPeerWithLimits
  , runPipelinedPeerWithLimits
  , runPeerWithLimitsRnd
  , runPipelinedPeerWithLimitsRnd
  , runAnnotatedPeerWithLimits
  , runPipelinedAnnotatedPeerWithLimits
    -- TODO:
    -- runAnnotatedPeerWithLimitsRnd
    -- runPipelinedAnnotatedPeerWithLimitsRnd
  , TraceSendRecv (..)
    -- * Driver utilities
  , driverWithLimits
  , driverWithLimitsRnd
  , annotatedDriverWithLimits
    -- TODO:
    -- annotedDriverWithLimitsRnd
  , runConnectedPeersWithLimits
  , runConnectedPipelinedPeersWithLimits
  , runConnectedPeersWithLimitsRnd
  , runConnectedPipelinedPeersWithLimitsRnd
  ) where

import Data.Bifunctor (first)
import Data.Functor.Identity
import Data.Maybe (fromMaybe)
import System.Random

import Control.Monad.Class.MonadAsync
import Control.Monad.Class.MonadFork
import Control.Monad.Class.MonadSTM
import Control.Monad.Class.MonadThrow
import Control.Monad.Class.MonadTimer.SI
import Control.Tracer (Tracer (..), contramap, traceWith)

import Network.Mux.Timeout
import Network.TypedProtocol.Codec
import Network.TypedProtocol.Core
import Network.TypedProtocol.Driver
import Network.TypedProtocol.Peer

import Ouroboros.Network.Channel
import Ouroboros.Network.Driver.Simple
import Ouroboros.Network.Protocol.Limits
import Ouroboros.Network.Util.ShowProxy


mkDriverWithLimits
  :: forall ps (pr :: PeerRole) failure bytes m f annotator.
     ( MonadThrow m
     , ShowProxy ps
     , forall (st' :: ps) tok. tok ~ StateToken st' => Show tok
     , Show failure
     )
  => (forall a.
           Word
        -> (bytes -> Word)
        -> Channel m bytes
        -> Maybe bytes
        -> DecodeStep bytes failure m (f a)
        -> m (Either (Maybe 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)
  -> TimeoutFn m
  -> CodecF ps failure m annotator bytes
  -> ProtocolSizeLimits ps bytes
  -> ProtocolTimeLimits ps
  -> Channel m bytes
  -> Driver ps pr (Maybe bytes) m
mkDriverWithLimits :: forall ps (pr :: PeerRole) failure bytes (m :: * -> *)
       (f :: * -> *) (annotator :: ps -> *).
(MonadThrow m, ShowProxy ps,
 forall (st' :: ps) tok. (tok ~ StateToken st') => Show tok,
 Show failure) =>
(forall a.
 Word
 -> (bytes -> Word)
 -> Channel m bytes
 -> Maybe bytes
 -> DecodeStep bytes failure m (f a)
 -> m (Either (Maybe failure) (a, Maybe bytes)))
-> (forall (st :: ps). annotator st -> f (SomeMessage st))
-> Tracer m (TraceSendRecv ps)
-> TimeoutFn m
-> CodecF ps failure m annotator bytes
-> ProtocolSizeLimits ps bytes
-> ProtocolTimeLimits ps
-> Channel m bytes
-> Driver ps pr (Maybe bytes) m
mkDriverWithLimits forall a.
Word
-> (bytes -> Word)
-> Channel m bytes
-> Maybe bytes
-> DecodeStep bytes failure m (f a)
-> m (Either (Maybe failure) (a, Maybe bytes))
runDecodeStep forall (st :: ps). annotator st -> f (SomeMessage st)
nat Tracer m (TraceSendRecv ps)
tracer
                   TimeoutFn m
timeoutFn
                   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}
                   ProtocolSizeLimits{forall (st :: ps). ActiveState st => StateToken st -> Word
sizeLimitForState :: forall (st :: ps). ActiveState st => StateToken st -> Word
sizeLimitForState :: forall ps bytes.
ProtocolSizeLimits ps bytes
-> forall (st :: ps). ActiveState st => StateToken st -> Word
sizeLimitForState, bytes -> Word
dataSize :: bytes -> Word
dataSize :: forall ps bytes. ProtocolSizeLimits ps bytes -> bytes -> Word
dataSize}
                   ProtocolTimeLimits{forall (st :: ps).
ActiveState st =>
StateToken st -> Maybe DiffTime
timeLimitForState :: forall (st :: ps).
ActiveState st =>
StateToken st -> Maybe DiffTime
timeLimitForState :: forall ps.
ProtocolTimeLimits ps
-> forall (st :: ps).
   ActiveState st =>
   StateToken st -> Maybe DiffTime
timeLimitForState}
                   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
      let sizeLimit = forall (st :: ps). ActiveState st => StateToken st -> Word
sizeLimitForState @st StateToken st
forall {ps} (st :: ps). StateTokenI st => StateToken st
stateToken
          timeLimit = DiffTime -> Maybe DiffTime -> DiffTime
forall a. a -> Maybe a -> a
fromMaybe (-DiffTime
1) (forall (st :: ps).
ActiveState st =>
StateToken st -> Maybe DiffTime
timeLimitForState @st StateToken st
forall {ps} (st :: ps). StateTokenI st => StateToken st
stateToken)
      result  <- timeoutFn timeLimit $
                   runDecodeStep sizeLimit dataSize
                                 channel trailing (nat <$> decoder)

      case result of
        Just (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
        Just (Left (Just 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)
        Just (Left Maybe failure
Nothing)        -> ProtocolLimitFailure -> 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 -> ProtocolLimitFailure
forall ps (st :: ps).
(Show (StateToken st), ShowProxy ps, ActiveState st) =>
StateToken st -> ProtocolLimitFailure
ExceededSizeLimit StateToken st
tok)
        Maybe (Either (Maybe failure) (SomeMessage st, Maybe bytes))
Nothing                    -> ProtocolLimitFailure -> 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 -> ProtocolLimitFailure
forall ps (st :: ps).
(Show (StateToken st), ShowProxy ps, ActiveState st) =>
StateToken st -> ProtocolLimitFailure
ExceededTimeLimit StateToken st
tok)


driverWithLimits
  :: forall ps (pr :: PeerRole) failure bytes m.
     ( MonadThrow m
     , ShowProxy ps
     , forall (st' :: ps) tok. tok ~ StateToken st' => Show tok
     , Show failure
     )
  => Tracer m (TraceSendRecv ps)
  -> TimeoutFn m
  -> Codec ps failure m bytes
  -> ProtocolSizeLimits ps bytes
  -> ProtocolTimeLimits ps
  -> Channel m bytes
  -> Driver ps pr (Maybe bytes) m
driverWithLimits :: forall ps (pr :: PeerRole) failure bytes (m :: * -> *).
(MonadThrow m, ShowProxy ps,
 forall (st' :: ps) tok. (tok ~ StateToken st') => Show tok,
 Show failure) =>
Tracer m (TraceSendRecv ps)
-> TimeoutFn m
-> Codec ps failure m bytes
-> ProtocolSizeLimits ps bytes
-> ProtocolTimeLimits ps
-> Channel m bytes
-> Driver ps pr (Maybe bytes) m
driverWithLimits = (forall a.
 Word
 -> (bytes -> Word)
 -> Channel m bytes
 -> Maybe bytes
 -> DecodeStep bytes failure m (Identity a)
 -> m (Either (Maybe failure) (a, Maybe bytes)))
-> (forall (st :: ps). SomeMessage st -> Identity (SomeMessage st))
-> Tracer m (TraceSendRecv ps)
-> TimeoutFn m
-> CodecF ps failure m SomeMessage bytes
-> ProtocolSizeLimits ps bytes
-> ProtocolTimeLimits ps
-> 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) tok. (tok ~ StateToken st') => Show tok,
 Show failure) =>
(forall a.
 Word
 -> (bytes -> Word)
 -> Channel m bytes
 -> Maybe bytes
 -> DecodeStep bytes failure m (f a)
 -> m (Either (Maybe failure) (a, Maybe bytes)))
-> (forall (st :: ps). annotator st -> f (SomeMessage st))
-> Tracer m (TraceSendRecv ps)
-> TimeoutFn m
-> CodecF ps failure m annotator bytes
-> ProtocolSizeLimits ps bytes
-> ProtocolTimeLimits ps
-> Channel m bytes
-> Driver ps pr (Maybe bytes) m
mkDriverWithLimits Word
-> (bytes -> Word)
-> Channel m bytes
-> Maybe bytes
-> DecodeStep bytes failure m (Identity a)
-> m (Either (Maybe failure) (a, Maybe bytes))
forall a.
Word
-> (bytes -> Word)
-> Channel m bytes
-> Maybe bytes
-> DecodeStep bytes failure m (Identity a)
-> m (Either (Maybe failure) (a, Maybe bytes))
forall (m :: * -> *) bytes failure a.
Monad m =>
Word
-> (bytes -> Word)
-> Channel m bytes
-> Maybe bytes
-> DecodeStep bytes failure m (Identity a)
-> m (Either (Maybe failure) (a, Maybe bytes))
runDecoderWithLimit SomeMessage st -> Identity (SomeMessage st)
forall (st :: ps). SomeMessage st -> Identity (SomeMessage st)
forall a. a -> Identity a
Identity


annotatedDriverWithLimits
  :: forall ps (pr :: PeerRole) failure bytes m.
     ( MonadThrow m
     , Monoid bytes
     , ShowProxy ps
     , forall (st' :: ps) tok. tok ~ StateToken st' => Show tok
     , Show failure
     )
  => Tracer m (TraceSendRecv ps)
  -> TimeoutFn m
  -> AnnotatedCodec ps failure m bytes
  -> ProtocolSizeLimits ps bytes
  -> ProtocolTimeLimits ps
  -> Channel m bytes
  -> Driver ps pr (Maybe bytes) m
annotatedDriverWithLimits :: forall ps (pr :: PeerRole) failure bytes (m :: * -> *).
(MonadThrow m, Monoid bytes, ShowProxy ps,
 forall (st' :: ps) tok. (tok ~ StateToken st') => Show tok,
 Show failure) =>
Tracer m (TraceSendRecv ps)
-> TimeoutFn m
-> AnnotatedCodec ps failure m bytes
-> ProtocolSizeLimits ps bytes
-> ProtocolTimeLimits ps
-> Channel m bytes
-> Driver ps pr (Maybe bytes) m
annotatedDriverWithLimits = (forall a.
 Word
 -> (bytes -> Word)
 -> Channel m bytes
 -> Maybe bytes
 -> DecodeStep bytes failure m (bytes -> a)
 -> m (Either (Maybe failure) (a, Maybe bytes)))
-> (forall (st :: ps).
    Annotator bytes st -> bytes -> SomeMessage st)
-> Tracer m (TraceSendRecv ps)
-> TimeoutFn m
-> CodecF ps failure m (Annotator bytes) bytes
-> ProtocolSizeLimits ps bytes
-> ProtocolTimeLimits ps
-> 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) tok. (tok ~ StateToken st') => Show tok,
 Show failure) =>
(forall a.
 Word
 -> (bytes -> Word)
 -> Channel m bytes
 -> Maybe bytes
 -> DecodeStep bytes failure m (f a)
 -> m (Either (Maybe failure) (a, Maybe bytes)))
-> (forall (st :: ps). annotator st -> f (SomeMessage st))
-> Tracer m (TraceSendRecv ps)
-> TimeoutFn m
-> CodecF ps failure m annotator bytes
-> ProtocolSizeLimits ps bytes
-> ProtocolTimeLimits ps
-> Channel m bytes
-> Driver ps pr (Maybe bytes) m
mkDriverWithLimits Word
-> (bytes -> Word)
-> Channel m bytes
-> Maybe bytes
-> DecodeStep bytes failure m (bytes -> a)
-> m (Either (Maybe failure) (a, Maybe bytes))
forall a.
Word
-> (bytes -> Word)
-> Channel m bytes
-> Maybe bytes
-> DecodeStep bytes failure m (bytes -> a)
-> m (Either (Maybe failure) (a, Maybe bytes))
forall (m :: * -> *) bytes failure a.
(Monad m, Monoid bytes) =>
Word
-> (bytes -> Word)
-> Channel m bytes
-> Maybe bytes
-> DecodeStep bytes failure m (bytes -> a)
-> m (Either (Maybe failure) (a, Maybe bytes))
runAnnotatedDecoderWithLimit 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


mkDriverWithLimitsRnd
  :: forall ps (pr :: PeerRole) failure bytes m f annotator.
     ( MonadThrow m
     , ShowProxy ps
     , forall (st' :: ps) tok. tok ~ StateToken st' => Show tok
     , Show failure
     )
  => (forall a.
           Word
        -> (bytes -> Word)
        -> Channel m bytes
        -> Maybe bytes
        -> DecodeStep bytes failure m (f a)
        -> m (Either (Maybe 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)
  -> TimeoutFn m
  -> StdGen
  -> CodecF ps failure m annotator bytes
  -> ProtocolSizeLimits ps bytes
  -> ProtocolTimeLimitsWithRnd ps
  -> Channel m bytes
  -> Driver ps pr (Maybe bytes, StdGen) m
mkDriverWithLimitsRnd :: forall ps (pr :: PeerRole) failure bytes (m :: * -> *)
       (f :: * -> *) (annotator :: ps -> *).
(MonadThrow m, ShowProxy ps,
 forall (st' :: ps) tok. (tok ~ StateToken st') => Show tok,
 Show failure) =>
(forall a.
 Word
 -> (bytes -> Word)
 -> Channel m bytes
 -> Maybe bytes
 -> DecodeStep bytes failure m (f a)
 -> m (Either (Maybe failure) (a, Maybe bytes)))
-> (forall (st :: ps). annotator st -> f (SomeMessage st))
-> Tracer m (TraceSendRecv ps)
-> TimeoutFn m
-> StdGen
-> CodecF ps failure m annotator bytes
-> ProtocolSizeLimits ps bytes
-> ProtocolTimeLimitsWithRnd ps
-> Channel m bytes
-> Driver ps pr (Maybe bytes, StdGen) m
mkDriverWithLimitsRnd forall a.
Word
-> (bytes -> Word)
-> Channel m bytes
-> Maybe bytes
-> DecodeStep bytes failure m (f a)
-> m (Either (Maybe failure) (a, Maybe bytes))
runDecodeStep forall (st :: ps). annotator st -> f (SomeMessage st)
nat Tracer m (TraceSendRecv ps)
tracer TimeoutFn m
timeoutFn StdGen
rnd0
                      Codec{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) (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 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 :: forall (st :: ps).
ActiveState st =>
StateToken st -> m (DecodeStep bytes failure m (annotator st))
decode}
                      ProtocolSizeLimits{forall (st :: ps). ActiveState st => StateToken st -> Word
sizeLimitForState :: forall ps bytes.
ProtocolSizeLimits ps bytes
-> forall (st :: ps). ActiveState st => StateToken st -> Word
sizeLimitForState :: forall (st :: ps). ActiveState st => StateToken st -> Word
sizeLimitForState, bytes -> Word
dataSize :: forall ps bytes. ProtocolSizeLimits ps bytes -> bytes -> Word
dataSize :: bytes -> Word
dataSize}
                      ProtocolTimeLimitsWithRnd{forall (st :: ps).
ActiveState st =>
StateToken st -> StdGen -> (Maybe DiffTime, StdGen)
timeLimitForStateWithRnd :: forall (st :: ps).
ActiveState st =>
StateToken st -> StdGen -> (Maybe DiffTime, StdGen)
timeLimitForStateWithRnd :: forall ps.
ProtocolTimeLimitsWithRnd ps
-> forall (st :: ps).
   ActiveState st =>
   StateToken st -> StdGen -> (Maybe DiffTime, StdGen)
timeLimitForStateWithRnd}
                      channel :: Channel m bytes
channel@Channel{bytes -> m ()
send :: forall (m :: * -> *) a. Channel m a -> a -> m ()
send :: bytes -> 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, 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, TheyHaveAgencyProof pr st
-> (Maybe bytes, StdGen)
-> m (SomeMessage st, (Maybe bytes, StdGen))
forall (st :: ps).
(StateTokenI st, ActiveState st) =>
TheyHaveAgencyProof pr st
-> (Maybe bytes, StdGen)
-> m (SomeMessage st, (Maybe bytes, StdGen))
recvMessage :: forall (st :: ps).
(StateTokenI st, ActiveState st) =>
TheyHaveAgencyProof pr st
-> (Maybe bytes, StdGen)
-> m (SomeMessage st, (Maybe bytes, StdGen))
recvMessage :: forall (st :: ps).
(StateTokenI st, ActiveState st) =>
TheyHaveAgencyProof pr st
-> (Maybe bytes, StdGen)
-> m (SomeMessage st, (Maybe bytes, StdGen))
recvMessage, initialDState :: (Maybe bytes, StdGen)
initialDState = (Maybe bytes
forall a. Maybe a
Nothing, StdGen
rnd0) }
  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, StdGen)
                -> m (SomeMessage st, (Maybe bytes, StdGen))
    recvMessage :: forall (st :: ps).
(StateTokenI st, ActiveState st) =>
TheyHaveAgencyProof pr st
-> (Maybe bytes, StdGen)
-> m (SomeMessage st, (Maybe bytes, StdGen))
recvMessage !TheyHaveAgencyProof pr st
_ (Maybe bytes
trailing, !StdGen
rnd) = 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
      let sizeLimit = forall (st :: ps). ActiveState st => StateToken st -> Word
sizeLimitForState @st StateToken st
forall {ps} (st :: ps). StateTokenI st => StateToken st
stateToken
          (timeLimit, rnd') = first (fromMaybe (-1))
                            $ timeLimitForStateWithRnd @st stateToken rnd
      result  <- timeoutFn timeLimit $
                   runDecodeStep sizeLimit dataSize
                                 channel trailing (nat <$> decoder)

      case result of
        Just (Right (x :: SomeMessage st
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, StdGen))
-> m (SomeMessage st, (Maybe bytes, StdGen))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (SomeMessage st
x, (Maybe bytes
trailing', StdGen
rnd'))
        Just (Left (Just failure
failure)) -> DecoderFailure -> m (SomeMessage st, (Maybe bytes, StdGen))
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)
        Just (Left Maybe failure
Nothing)        -> ProtocolLimitFailure -> m (SomeMessage st, (Maybe bytes, StdGen))
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (StateToken st -> ProtocolLimitFailure
forall ps (st :: ps).
(Show (StateToken st), ShowProxy ps, ActiveState st) =>
StateToken st -> ProtocolLimitFailure
ExceededSizeLimit StateToken st
tok)
        Maybe (Either (Maybe failure) (SomeMessage st, Maybe bytes))
Nothing                    -> ProtocolLimitFailure -> m (SomeMessage st, (Maybe bytes, StdGen))
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (StateToken st -> ProtocolLimitFailure
forall ps (st :: ps).
(Show (StateToken st), ShowProxy ps, ActiveState st) =>
StateToken st -> ProtocolLimitFailure
ExceededTimeLimit StateToken st
tok)


-- | Like 'driverWithLimits' but gives access to `StdGen` to generate
-- `ProtocolTimeouts` for the next state.
--
driverWithLimitsRnd :: forall ps (pr :: PeerRole) failure bytes m.
                       ( MonadThrow m
                       , ShowProxy ps
                       , forall (st' :: ps) tok. tok ~ StateToken st' => Show tok
                       , Show failure
                       )
                    => Tracer m (TraceSendRecv ps)
                    -> TimeoutFn m
                    -> StdGen
                    -> Codec ps failure m bytes
                    -> ProtocolSizeLimits ps bytes
                    -> ProtocolTimeLimitsWithRnd ps
                    -> Channel m bytes
                    -> Driver ps pr (Maybe bytes, StdGen) m
driverWithLimitsRnd :: forall ps (pr :: PeerRole) failure bytes (m :: * -> *).
(MonadThrow m, ShowProxy ps,
 forall (st' :: ps) tok. (tok ~ StateToken st') => Show tok,
 Show failure) =>
Tracer m (TraceSendRecv ps)
-> TimeoutFn m
-> StdGen
-> Codec ps failure m bytes
-> ProtocolSizeLimits ps bytes
-> ProtocolTimeLimitsWithRnd ps
-> Channel m bytes
-> Driver ps pr (Maybe bytes, StdGen) m
driverWithLimitsRnd = (forall a.
 Word
 -> (bytes -> Word)
 -> Channel m bytes
 -> Maybe bytes
 -> DecodeStep bytes failure m (Identity a)
 -> m (Either (Maybe failure) (a, Maybe bytes)))
-> (forall (st :: ps). SomeMessage st -> Identity (SomeMessage st))
-> Tracer m (TraceSendRecv ps)
-> TimeoutFn m
-> StdGen
-> CodecF ps failure m SomeMessage bytes
-> ProtocolSizeLimits ps bytes
-> ProtocolTimeLimitsWithRnd ps
-> Channel m bytes
-> Driver ps pr (Maybe bytes, StdGen) m
forall ps (pr :: PeerRole) failure bytes (m :: * -> *)
       (f :: * -> *) (annotator :: ps -> *).
(MonadThrow m, ShowProxy ps,
 forall (st' :: ps) tok. (tok ~ StateToken st') => Show tok,
 Show failure) =>
(forall a.
 Word
 -> (bytes -> Word)
 -> Channel m bytes
 -> Maybe bytes
 -> DecodeStep bytes failure m (f a)
 -> m (Either (Maybe failure) (a, Maybe bytes)))
-> (forall (st :: ps). annotator st -> f (SomeMessage st))
-> Tracer m (TraceSendRecv ps)
-> TimeoutFn m
-> StdGen
-> CodecF ps failure m annotator bytes
-> ProtocolSizeLimits ps bytes
-> ProtocolTimeLimitsWithRnd ps
-> Channel m bytes
-> Driver ps pr (Maybe bytes, StdGen) m
mkDriverWithLimitsRnd Word
-> (bytes -> Word)
-> Channel m bytes
-> Maybe bytes
-> DecodeStep bytes failure m (Identity a)
-> m (Either (Maybe failure) (a, Maybe bytes))
forall a.
Word
-> (bytes -> Word)
-> Channel m bytes
-> Maybe bytes
-> DecodeStep bytes failure m (Identity a)
-> m (Either (Maybe failure) (a, Maybe bytes))
forall (m :: * -> *) bytes failure a.
Monad m =>
Word
-> (bytes -> Word)
-> Channel m bytes
-> Maybe bytes
-> DecodeStep bytes failure m (Identity a)
-> m (Either (Maybe failure) (a, Maybe bytes))
runDecoderWithLimit SomeMessage st -> Identity (SomeMessage st)
forall (st :: ps). SomeMessage st -> Identity (SomeMessage st)
forall a. a -> Identity a
Identity


runDecoderWithLimit
    :: forall m bytes failure a. Monad m
    => Word
    -- ^ message size limit
    -> (bytes -> Word)
    -- ^ byte size
    -> Channel m bytes
    -> Maybe bytes
    -> DecodeStep bytes failure m (Identity a)
    -> m (Either (Maybe failure) (a, Maybe bytes))
runDecoderWithLimit :: forall (m :: * -> *) bytes failure a.
Monad m =>
Word
-> (bytes -> Word)
-> Channel m bytes
-> Maybe bytes
-> DecodeStep bytes failure m (Identity a)
-> m (Either (Maybe failure) (a, Maybe bytes))
runDecoderWithLimit Word
limit bytes -> Word
size Channel{m (Maybe bytes)
recv :: m (Maybe bytes)
recv :: forall (m :: * -> *) a. Channel m a -> m (Maybe a)
recv} =
    Word
-> Maybe bytes
-> DecodeStep bytes failure m (Identity a)
-> m (Either (Maybe failure) (a, Maybe bytes))
go Word
0
  where
    -- Our strategy here is as follows...
    --
    -- We of course want to enforce the maximum data limit, but we also want to
    -- detect and report when we exceed the limit rather than having it be
    -- misclassified as a generic decode error. For example if we simply limited
    -- the decoder input to the maximum size then the failure would be reported
    -- as an unexpected end of input, rather than that the size limit was
    -- exceeded.
    --
    -- So our strategy is to allow the last chunk of input to exceed the limit.
    -- This leaves just one special case: if the decoder finishes with that
    -- final chunk, we must check if it consumed too much of the final chunk.
    --
    go :: Word        -- ^ size of consumed input so far
       -> Maybe bytes -- ^ any trailing data
       -> DecodeStep bytes failure m (Identity a)
       -> m (Either (Maybe failure) (a, Maybe bytes))

    go :: Word
-> Maybe bytes
-> DecodeStep bytes failure m (Identity a)
-> m (Either (Maybe failure) (a, Maybe bytes))
go !Word
sz Maybe bytes
trailing (DecodePartial Maybe bytes -> m (DecodeStep bytes failure m (Identity a))
k)
      | Word
sz Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
> Word
limit = Either (Maybe failure) (a, Maybe bytes)
-> m (Either (Maybe failure) (a, Maybe bytes))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe failure -> Either (Maybe failure) (a, Maybe bytes)
forall a b. a -> Either a b
Left Maybe failure
forall a. Maybe a
Nothing)
      | Bool
otherwise  = case Maybe bytes
trailing of
                       Maybe bytes
Nothing -> do mbs <- m (Maybe bytes)
recv
                                     let !sz' = Word
sz Word -> Word -> Word
forall a. Num a => a -> a -> a
+ Word -> (bytes -> Word) -> Maybe bytes -> Word
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Word
0 bytes -> Word
size Maybe bytes
mbs
                                     go sz' Nothing =<< k mbs
                       Just bytes
bs -> do let sz' :: Word
sz' = Word
sz Word -> Word -> Word
forall a. Num a => a -> a -> a
+ bytes -> Word
size bytes
bs
                                     Word
-> Maybe bytes
-> DecodeStep bytes failure m (Identity a)
-> m (Either (Maybe failure) (a, Maybe bytes))
go Word
sz' Maybe bytes
forall a. Maybe a
Nothing (DecodeStep bytes failure m (Identity a)
 -> m (Either (Maybe failure) (a, Maybe bytes)))
-> m (DecodeStep bytes failure m (Identity a))
-> m (Either (Maybe failure) (a, Maybe bytes))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe bytes -> m (DecodeStep bytes failure m (Identity a))
k (bytes -> Maybe bytes
forall a. a -> Maybe a
Just bytes
bs)

    go !Word
sz !Maybe bytes
_ (DecodeDone (Identity a
x) Maybe bytes
trailing)
      | let sz' :: Word
sz' = Word
sz Word -> Word -> Word
forall a. Num a => a -> a -> a
- Word -> (bytes -> Word) -> Maybe bytes -> Word
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Word
0 bytes -> Word
size Maybe bytes
trailing
      , Word
sz' Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
> Word
limit = Either (Maybe failure) (a, Maybe bytes)
-> m (Either (Maybe failure) (a, Maybe bytes))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe failure -> Either (Maybe failure) (a, Maybe bytes)
forall a b. a -> Either a b
Left Maybe failure
forall a. Maybe a
Nothing)
      | Bool
otherwise   = Either (Maybe failure) (a, Maybe bytes)
-> m (Either (Maybe failure) (a, Maybe bytes))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((a, Maybe bytes) -> Either (Maybe failure) (a, Maybe bytes)
forall a b. b -> Either a b
Right (a
x, Maybe bytes
trailing))

    go !Word
_ !Maybe bytes
_ (DecodeFail failure
failure) = Either (Maybe failure) (a, Maybe bytes)
-> m (Either (Maybe failure) (a, Maybe bytes))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe failure -> Either (Maybe failure) (a, Maybe bytes)
forall a b. a -> Either a b
Left (failure -> Maybe failure
forall a. a -> Maybe a
Just failure
failure))


runAnnotatedDecoderWithLimit
    :: forall m bytes failure a.
       ( Monad m
       , Monoid bytes
       )
    => Word
    -- ^ message size limit
    -> (bytes -> Word)
    -- ^ byte size
    -> Channel m bytes
    -> Maybe bytes
    -> DecodeStep bytes failure m (bytes -> a)
    -> m (Either (Maybe failure) (a, Maybe bytes))
runAnnotatedDecoderWithLimit :: forall (m :: * -> *) bytes failure a.
(Monad m, Monoid bytes) =>
Word
-> (bytes -> Word)
-> Channel m bytes
-> Maybe bytes
-> DecodeStep bytes failure m (bytes -> a)
-> m (Either (Maybe failure) (a, Maybe bytes))
runAnnotatedDecoderWithLimit Word
limit bytes -> Word
size Channel{m (Maybe bytes)
recv :: forall (m :: * -> *) a. Channel m a -> m (Maybe a)
recv :: m (Maybe bytes)
recv} =
    [bytes]
-> Word
-> Maybe bytes
-> DecodeStep bytes failure m (bytes -> a)
-> m (Either (Maybe failure) (a, Maybe bytes))
go [bytes]
forall a. Monoid a => a
mempty Word
0
  where
    -- Our strategy here is as follows...
    --
    -- We of course want to enforce the maximum data limit, but we also want to
    -- detect and report when we exceed the limit rather than having it be
    -- misclassified as a generic decode error. For example if we simply limited
    -- the decoder input to the maximum size then the failure would be reported
    -- as an unexpected end of input, rather than that the size limit was
    -- exceeded.
    --
    -- So our strategy is to allow the last chunk of input to exceed the limit.
    -- This leaves just one special case: if the decoder finishes with that
    -- final chunk, we must check if it consumed too much of the final chunk.
    --
    go :: [bytes]     -- ^ accumulation of chunks received from the network
       -> Word        -- ^ size of consumed input so far
       -> Maybe bytes -- ^ any trailing data
       -> DecodeStep bytes failure m (bytes -> a)
       -> m (Either (Maybe failure) (a, Maybe bytes))


    go :: [bytes]
-> Word
-> Maybe bytes
-> DecodeStep bytes failure m (bytes -> a)
-> m (Either (Maybe failure) (a, Maybe bytes))
go ![bytes]
_ !Word
sz !Maybe bytes
_ DecodePartial {} | Word
sz Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
> Word
limit =
      Either (Maybe failure) (a, Maybe bytes)
-> m (Either (Maybe failure) (a, Maybe bytes))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe failure -> Either (Maybe failure) (a, Maybe bytes)
forall a b. a -> Either a b
Left Maybe failure
forall a. Maybe a
Nothing)

    go ![bytes]
bytes !Word
sz (Just bytes
trailing) (DecodePartial Maybe bytes -> m (DecodeStep bytes failure m (bytes -> a))
k) = do
      let sz' :: Word
sz' = Word
sz Word -> Word -> Word
forall a. Num a => a -> a -> a
+ bytes -> Word
size bytes
trailing
      step <- Maybe bytes -> m (DecodeStep bytes failure m (bytes -> a))
k (bytes -> Maybe bytes
forall a. a -> Maybe a
Just bytes
trailing)
      go (trailing : bytes) sz' Nothing step

    go ![bytes]
bytes !Word
sz Maybe bytes
Nothing (DecodePartial Maybe bytes -> m (DecodeStep bytes failure m (bytes -> a))
k) = do
      mbs <- m (Maybe bytes)
recv
      let !sz' = Word
sz Word -> Word -> Word
forall a. Num a => a -> a -> a
+ Word -> (bytes -> Word) -> Maybe bytes -> Word
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Word
0 bytes -> Word
size Maybe bytes
mbs
      step <- k mbs
      go (case mbs of
            Maybe bytes
Nothing -> [bytes]
bytes
            Just bytes
bs -> bytes
bs bytes -> [bytes] -> [bytes]
forall a. a -> [a] -> [a]
: [bytes]
bytes)
         sz' Nothing step

    go ![bytes]
bytes !Word
sz !Maybe bytes
_ (DecodeDone bytes -> a
f Maybe bytes
trailing)
      | let sz' :: Word
sz' = Word
sz Word -> Word -> Word
forall a. Num a => a -> a -> a
- Word -> (bytes -> Word) -> Maybe bytes -> Word
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Word
0 bytes -> Word
size Maybe bytes
trailing
      , Word
sz' Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
> Word
limit = Either (Maybe failure) (a, Maybe bytes)
-> m (Either (Maybe failure) (a, Maybe bytes))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe failure -> Either (Maybe failure) (a, Maybe bytes)
forall a b. a -> Either a b
Left Maybe failure
forall a. Maybe a
Nothing)
      | Bool
otherwise   = Either (Maybe failure) (a, Maybe bytes)
-> m (Either (Maybe failure) (a, Maybe bytes))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((a, Maybe bytes) -> Either (Maybe failure) (a, Maybe bytes)
forall a b. b -> Either a b
Right (bytes -> a
f ([bytes] -> bytes
forall a. Monoid a => [a] -> a
mconcat ([bytes] -> bytes) -> [bytes] -> bytes
forall a b. (a -> b) -> a -> b
$ [bytes] -> [bytes]
forall a. [a] -> [a]
reverse [bytes]
bytes), Maybe bytes
trailing))

    go ![bytes]
_ !Word
_ !Maybe bytes
_ (DecodeFail failure
failure) = Either (Maybe failure) (a, Maybe bytes)
-> m (Either (Maybe failure) (a, Maybe bytes))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe failure -> Either (Maybe failure) (a, Maybe bytes)
forall a b. a -> Either a b
Left (failure -> Maybe failure
forall a. a -> Maybe a
Just failure
failure))


-- | Run a peer with limits.
--
runPeerWithLimits
  :: forall ps (st :: ps) pr failure bytes m a .
     ( MonadAsync m
     , MonadFork m
     , MonadMask m
     , MonadThrow (STM m)
     , MonadTimer m
     , ShowProxy ps
     , forall (st' :: ps) stok. stok ~ StateToken st' => Show stok
     , Show failure
     )
  => Tracer m (TraceSendRecv ps)
  -> Codec ps failure m bytes
  -> ProtocolSizeLimits ps bytes
  -> ProtocolTimeLimits ps
  -> Channel m bytes
  -> Peer ps pr NonPipelined st m a
  -> m (a, Maybe bytes)
runPeerWithLimits :: forall ps (st :: ps) (pr :: PeerRole) failure bytes (m :: * -> *)
       a.
(MonadAsync m, MonadFork m, MonadMask m, MonadThrow (STM m),
 MonadTimer m, ShowProxy ps,
 forall (st' :: ps) stok. (stok ~ StateToken st') => Show stok,
 Show failure) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> ProtocolSizeLimits ps bytes
-> ProtocolTimeLimits ps
-> Channel m bytes
-> Peer ps pr 'NonPipelined st m a
-> m (a, Maybe bytes)
runPeerWithLimits Tracer m (TraceSendRecv ps)
tracer Codec ps failure m bytes
codec ProtocolSizeLimits ps bytes
slimits ProtocolTimeLimits ps
tlimits Channel m bytes
channel Peer ps pr 'NonPipelined st m a
peer =
    (TimeoutFn m -> m (a, Maybe bytes)) -> m (a, Maybe bytes)
forall (m :: * -> *) b.
(MonadAsync m, MonadFork m, MonadMonotonicTime m, MonadTimer m,
 MonadMask m, MonadThrow (STM m)) =>
(TimeoutFn m -> m b) -> m b
withTimeoutSerial ((TimeoutFn m -> m (a, Maybe bytes)) -> m (a, Maybe bytes))
-> (TimeoutFn m -> m (a, Maybe bytes)) -> m (a, Maybe bytes)
forall a b. (a -> b) -> a -> b
$ \TimeoutFn m
timeoutFn ->
      let driver :: Driver ps pr (Maybe bytes) m
driver = Tracer m (TraceSendRecv ps)
-> TimeoutFn m
-> Codec ps failure m bytes
-> ProtocolSizeLimits ps bytes
-> ProtocolTimeLimits ps
-> Channel m bytes
-> Driver ps pr (Maybe bytes) m
forall ps (pr :: PeerRole) failure bytes (m :: * -> *).
(MonadThrow m, ShowProxy ps,
 forall (st' :: ps) tok. (tok ~ StateToken st') => Show tok,
 Show failure) =>
Tracer m (TraceSendRecv ps)
-> TimeoutFn m
-> Codec ps failure m bytes
-> ProtocolSizeLimits ps bytes
-> ProtocolTimeLimits ps
-> Channel m bytes
-> Driver ps pr (Maybe bytes) m
driverWithLimits Tracer m (TraceSendRecv ps)
tracer DiffTime -> m a -> m (Maybe a)
TimeoutFn m
timeoutFn Codec ps failure m bytes
codec ProtocolSizeLimits ps bytes
slimits ProtocolTimeLimits ps
tlimits Channel m bytes
channel
      in 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


-- | Run an peer with annotated codec & limits.
--
runAnnotatedPeerWithLimits
  :: forall ps (st :: ps) pr failure bytes m a .
     ( MonadAsync m
     , MonadFork m
     , MonadMask m
     , MonadThrow (STM m)
     , MonadTimer 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
  -> ProtocolSizeLimits ps bytes
  -> ProtocolTimeLimits ps
  -> Channel m bytes
  -> Peer ps pr NonPipelined st m a
  -> m (a, Maybe bytes)
runAnnotatedPeerWithLimits :: forall ps (st :: ps) (pr :: PeerRole) failure bytes (m :: * -> *)
       a.
(MonadAsync m, MonadFork m, MonadMask m, MonadThrow (STM m),
 MonadTimer 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
-> ProtocolSizeLimits ps bytes
-> ProtocolTimeLimits ps
-> Channel m bytes
-> Peer ps pr 'NonPipelined st m a
-> m (a, Maybe bytes)
runAnnotatedPeerWithLimits Tracer m (TraceSendRecv ps)
tracer AnnotatedCodec ps failure m bytes
codec ProtocolSizeLimits ps bytes
slimits ProtocolTimeLimits ps
tlimits Channel m bytes
channel Peer ps pr 'NonPipelined st m a
peer =
    (TimeoutFn m -> m (a, Maybe bytes)) -> m (a, Maybe bytes)
forall (m :: * -> *) b.
(MonadAsync m, MonadFork m, MonadMonotonicTime m, MonadTimer m,
 MonadMask m, MonadThrow (STM m)) =>
(TimeoutFn m -> m b) -> m b
withTimeoutSerial ((TimeoutFn m -> m (a, Maybe bytes)) -> m (a, Maybe bytes))
-> (TimeoutFn m -> m (a, Maybe bytes)) -> m (a, Maybe bytes)
forall a b. (a -> b) -> a -> b
$ \TimeoutFn m
timeoutFn ->
      let driver :: Driver ps pr (Maybe bytes) m
driver = Tracer m (TraceSendRecv ps)
-> TimeoutFn m
-> AnnotatedCodec ps failure m bytes
-> ProtocolSizeLimits ps bytes
-> ProtocolTimeLimits ps
-> 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) tok. (tok ~ StateToken st') => Show tok,
 Show failure) =>
Tracer m (TraceSendRecv ps)
-> TimeoutFn m
-> AnnotatedCodec ps failure m bytes
-> ProtocolSizeLimits ps bytes
-> ProtocolTimeLimits ps
-> Channel m bytes
-> Driver ps pr (Maybe bytes) m
annotatedDriverWithLimits Tracer m (TraceSendRecv ps)
tracer DiffTime -> m a -> m (Maybe a)
TimeoutFn m
timeoutFn AnnotatedCodec ps failure m bytes
codec ProtocolSizeLimits ps bytes
slimits ProtocolTimeLimits ps
tlimits Channel m bytes
channel
      in 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


-- | Run a peer with limits.  'ProtocolTimeLimits' have access to
-- a pseudorandom generator.
--
runPeerWithLimitsRnd
  :: forall ps (st :: ps) pr failure bytes m a .
     ( MonadAsync m
     , MonadFork m
     , MonadMask m
     , MonadThrow (STM m)
     , MonadTimer m
     , ShowProxy ps
     , forall (st' :: ps) stok. stok ~ StateToken st' => Show stok
     , Show failure
     )
  => Tracer m (TraceSendRecv ps)
  -> StdGen
  -> Codec ps failure m bytes
  -> ProtocolSizeLimits ps bytes
  -> ProtocolTimeLimitsWithRnd ps
  -> Channel m bytes
  -> Peer ps pr NonPipelined st m a
  -> m (a, Maybe bytes)
runPeerWithLimitsRnd :: forall ps (st :: ps) (pr :: PeerRole) failure bytes (m :: * -> *)
       a.
(MonadAsync m, MonadFork m, MonadMask m, MonadThrow (STM m),
 MonadTimer m, ShowProxy ps,
 forall (st' :: ps) stok. (stok ~ StateToken st') => Show stok,
 Show failure) =>
Tracer m (TraceSendRecv ps)
-> StdGen
-> Codec ps failure m bytes
-> ProtocolSizeLimits ps bytes
-> ProtocolTimeLimitsWithRnd ps
-> Channel m bytes
-> Peer ps pr 'NonPipelined st m a
-> m (a, Maybe bytes)
runPeerWithLimitsRnd Tracer m (TraceSendRecv ps)
tracer StdGen
rnd Codec ps failure m bytes
codec ProtocolSizeLimits ps bytes
slimits ProtocolTimeLimitsWithRnd ps
tlimits Channel m bytes
channel Peer ps pr 'NonPipelined st m a
peer =
    (TimeoutFn m -> m (a, Maybe bytes)) -> m (a, Maybe bytes)
forall (m :: * -> *) b.
(MonadAsync m, MonadFork m, MonadMonotonicTime m, MonadTimer m,
 MonadMask m, MonadThrow (STM m)) =>
(TimeoutFn m -> m b) -> m b
withTimeoutSerial ((TimeoutFn m -> m (a, Maybe bytes)) -> m (a, Maybe bytes))
-> (TimeoutFn m -> m (a, Maybe bytes)) -> m (a, Maybe bytes)
forall a b. (a -> b) -> a -> b
$ \TimeoutFn m
timeoutFn ->
      let driver :: Driver ps pr (Maybe bytes, StdGen) m
driver = Tracer m (TraceSendRecv ps)
-> TimeoutFn m
-> StdGen
-> Codec ps failure m bytes
-> ProtocolSizeLimits ps bytes
-> ProtocolTimeLimitsWithRnd ps
-> Channel m bytes
-> Driver ps pr (Maybe bytes, StdGen) m
forall ps (pr :: PeerRole) failure bytes (m :: * -> *).
(MonadThrow m, ShowProxy ps,
 forall (st' :: ps) tok. (tok ~ StateToken st') => Show tok,
 Show failure) =>
Tracer m (TraceSendRecv ps)
-> TimeoutFn m
-> StdGen
-> Codec ps failure m bytes
-> ProtocolSizeLimits ps bytes
-> ProtocolTimeLimitsWithRnd ps
-> Channel m bytes
-> Driver ps pr (Maybe bytes, StdGen) m
driverWithLimitsRnd Tracer m (TraceSendRecv ps)
tracer DiffTime -> m a -> m (Maybe a)
TimeoutFn m
timeoutFn StdGen
rnd Codec ps failure m bytes
codec ProtocolSizeLimits ps bytes
slimits ProtocolTimeLimitsWithRnd ps
tlimits Channel m bytes
channel
      in     (\(a
a, (Maybe bytes
trailing, StdGen
_)) -> (a
a, Maybe bytes
trailing))
         ((a, (Maybe bytes, StdGen)) -> (a, Maybe bytes))
-> m (a, (Maybe bytes, StdGen)) -> m (a, Maybe bytes)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Driver ps pr (Maybe bytes, StdGen) m
-> Peer ps pr 'NonPipelined st m a -> m (a, (Maybe bytes, StdGen))
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, StdGen) m
driver Peer ps pr 'NonPipelined st m a
peer


-- | 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.
--
runPipelinedPeerWithLimits
  :: forall ps (st :: ps) pr failure bytes m a.
     ( MonadAsync m
     , MonadFork m
     , MonadMask m
     , MonadTimer m
     , MonadThrow (STM m)
     , ShowProxy ps
     , forall (st' :: ps) stok. stok ~ StateToken st' => Show stok
     , Show failure
     )
  => Tracer m (TraceSendRecv ps)
  -> Codec ps failure m bytes
  -> ProtocolSizeLimits ps bytes
  -> ProtocolTimeLimits ps
  -> Channel m bytes
  -> PeerPipelined ps pr st m a
  -> m (a, Maybe bytes)
runPipelinedPeerWithLimits :: forall ps (st :: ps) (pr :: PeerRole) failure bytes (m :: * -> *)
       a.
(MonadAsync m, MonadFork m, MonadMask m, MonadTimer m,
 MonadThrow (STM m), ShowProxy ps,
 forall (st' :: ps) stok. (stok ~ StateToken st') => Show stok,
 Show failure) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> ProtocolSizeLimits ps bytes
-> ProtocolTimeLimits ps
-> Channel m bytes
-> PeerPipelined ps pr st m a
-> m (a, Maybe bytes)
runPipelinedPeerWithLimits Tracer m (TraceSendRecv ps)
tracer Codec ps failure m bytes
codec ProtocolSizeLimits ps bytes
slimits ProtocolTimeLimits ps
tlimits Channel m bytes
channel PeerPipelined ps pr st m a
peer =
    (TimeoutFn m -> m (a, Maybe bytes)) -> m (a, Maybe bytes)
forall (m :: * -> *) b.
(MonadAsync m, MonadFork m, MonadMonotonicTime m, MonadTimer m,
 MonadMask m, MonadThrow (STM m)) =>
(TimeoutFn m -> m b) -> m b
withTimeoutSerial ((TimeoutFn m -> m (a, Maybe bytes)) -> m (a, Maybe bytes))
-> (TimeoutFn m -> m (a, Maybe bytes)) -> m (a, Maybe bytes)
forall a b. (a -> b) -> a -> b
$ \TimeoutFn m
timeoutFn ->
      let driver :: Driver ps pr (Maybe bytes) m
driver = Tracer m (TraceSendRecv ps)
-> TimeoutFn m
-> Codec ps failure m bytes
-> ProtocolSizeLimits ps bytes
-> ProtocolTimeLimits ps
-> Channel m bytes
-> Driver ps pr (Maybe bytes) m
forall ps (pr :: PeerRole) failure bytes (m :: * -> *).
(MonadThrow m, ShowProxy ps,
 forall (st' :: ps) tok. (tok ~ StateToken st') => Show tok,
 Show failure) =>
Tracer m (TraceSendRecv ps)
-> TimeoutFn m
-> Codec ps failure m bytes
-> ProtocolSizeLimits ps bytes
-> ProtocolTimeLimits ps
-> Channel m bytes
-> Driver ps pr (Maybe bytes) m
driverWithLimits Tracer m (TraceSendRecv ps)
tracer DiffTime -> m a -> m (Maybe a)
TimeoutFn m
timeoutFn Codec ps failure m bytes
codec ProtocolSizeLimits ps bytes
slimits ProtocolTimeLimits ps
tlimits Channel m bytes
channel
      in 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


runPipelinedAnnotatedPeerWithLimits
  :: forall ps (st :: ps) pr failure bytes m a.
     ( MonadAsync m
     , MonadFork m
     , MonadMask m
     , MonadTimer m
     , MonadThrow (STM 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
  -> ProtocolSizeLimits ps bytes
  -> ProtocolTimeLimits ps
  -> Channel m bytes
  -> PeerPipelined ps pr st m a
  -> m (a, Maybe bytes)
runPipelinedAnnotatedPeerWithLimits :: forall ps (st :: ps) (pr :: PeerRole) failure bytes (m :: * -> *)
       a.
(MonadAsync m, MonadFork m, MonadMask m, MonadTimer m,
 MonadThrow (STM 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
-> ProtocolSizeLimits ps bytes
-> ProtocolTimeLimits ps
-> Channel m bytes
-> PeerPipelined ps pr st m a
-> m (a, Maybe bytes)
runPipelinedAnnotatedPeerWithLimits Tracer m (TraceSendRecv ps)
tracer AnnotatedCodec ps failure m bytes
codec ProtocolSizeLimits ps bytes
slimits ProtocolTimeLimits ps
tlimits Channel m bytes
channel PeerPipelined ps pr st m a
peer =
    (TimeoutFn m -> m (a, Maybe bytes)) -> m (a, Maybe bytes)
forall (m :: * -> *) b.
(MonadAsync m, MonadFork m, MonadMonotonicTime m, MonadTimer m,
 MonadMask m, MonadThrow (STM m)) =>
(TimeoutFn m -> m b) -> m b
withTimeoutSerial ((TimeoutFn m -> m (a, Maybe bytes)) -> m (a, Maybe bytes))
-> (TimeoutFn m -> m (a, Maybe bytes)) -> m (a, Maybe bytes)
forall a b. (a -> b) -> a -> b
$ \TimeoutFn m
timeoutFn ->
      let driver :: Driver ps pr (Maybe bytes) m
driver = Tracer m (TraceSendRecv ps)
-> TimeoutFn m
-> AnnotatedCodec ps failure m bytes
-> ProtocolSizeLimits ps bytes
-> ProtocolTimeLimits ps
-> 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) tok. (tok ~ StateToken st') => Show tok,
 Show failure) =>
Tracer m (TraceSendRecv ps)
-> TimeoutFn m
-> AnnotatedCodec ps failure m bytes
-> ProtocolSizeLimits ps bytes
-> ProtocolTimeLimits ps
-> Channel m bytes
-> Driver ps pr (Maybe bytes) m
annotatedDriverWithLimits Tracer m (TraceSendRecv ps)
tracer DiffTime -> m a -> m (Maybe a)
TimeoutFn m
timeoutFn AnnotatedCodec ps failure m bytes
codec ProtocolSizeLimits ps bytes
slimits ProtocolTimeLimits ps
tlimits Channel m bytes
channel
      in 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


-- | Like 'runPipelinedPeerWithLimits' but time limits have access to
-- a pseudorandom generator.
--
runPipelinedPeerWithLimitsRnd
  :: forall ps (st :: ps) pr failure bytes m a.
     ( MonadAsync m
     , MonadFork m
     , MonadMask m
     , MonadTimer m
     , MonadThrow (STM m)
     , ShowProxy ps
     , forall (st' :: ps) stok. stok ~ StateToken st' => Show stok
     , Show failure
     )
  => Tracer m (TraceSendRecv ps)
  -> StdGen
  -> Codec ps failure m bytes
  -> ProtocolSizeLimits ps bytes
  -> ProtocolTimeLimitsWithRnd ps
  -> Channel m bytes
  -> PeerPipelined ps pr st m a
  -> m (a, Maybe bytes)
runPipelinedPeerWithLimitsRnd :: forall ps (st :: ps) (pr :: PeerRole) failure bytes (m :: * -> *)
       a.
(MonadAsync m, MonadFork m, MonadMask m, MonadTimer m,
 MonadThrow (STM m), ShowProxy ps,
 forall (st' :: ps) stok. (stok ~ StateToken st') => Show stok,
 Show failure) =>
Tracer m (TraceSendRecv ps)
-> StdGen
-> Codec ps failure m bytes
-> ProtocolSizeLimits ps bytes
-> ProtocolTimeLimitsWithRnd ps
-> Channel m bytes
-> PeerPipelined ps pr st m a
-> m (a, Maybe bytes)
runPipelinedPeerWithLimitsRnd Tracer m (TraceSendRecv ps)
tracer StdGen
rnd Codec ps failure m bytes
codec ProtocolSizeLimits ps bytes
slimits ProtocolTimeLimitsWithRnd ps
tlimits Channel m bytes
channel PeerPipelined ps pr st m a
peer =
    (TimeoutFn m -> m (a, Maybe bytes)) -> m (a, Maybe bytes)
forall (m :: * -> *) b.
(MonadAsync m, MonadFork m, MonadMonotonicTime m, MonadTimer m,
 MonadMask m, MonadThrow (STM m)) =>
(TimeoutFn m -> m b) -> m b
withTimeoutSerial ((TimeoutFn m -> m (a, Maybe bytes)) -> m (a, Maybe bytes))
-> (TimeoutFn m -> m (a, Maybe bytes)) -> m (a, Maybe bytes)
forall a b. (a -> b) -> a -> b
$ \TimeoutFn m
timeoutFn ->
      let driver :: Driver ps pr (Maybe bytes, StdGen) m
driver = Tracer m (TraceSendRecv ps)
-> TimeoutFn m
-> StdGen
-> Codec ps failure m bytes
-> ProtocolSizeLimits ps bytes
-> ProtocolTimeLimitsWithRnd ps
-> Channel m bytes
-> Driver ps pr (Maybe bytes, StdGen) m
forall ps (pr :: PeerRole) failure bytes (m :: * -> *).
(MonadThrow m, ShowProxy ps,
 forall (st' :: ps) tok. (tok ~ StateToken st') => Show tok,
 Show failure) =>
Tracer m (TraceSendRecv ps)
-> TimeoutFn m
-> StdGen
-> Codec ps failure m bytes
-> ProtocolSizeLimits ps bytes
-> ProtocolTimeLimitsWithRnd ps
-> Channel m bytes
-> Driver ps pr (Maybe bytes, StdGen) m
driverWithLimitsRnd Tracer m (TraceSendRecv ps)
tracer DiffTime -> m a -> m (Maybe a)
TimeoutFn m
timeoutFn StdGen
rnd Codec ps failure m bytes
codec ProtocolSizeLimits ps bytes
slimits ProtocolTimeLimitsWithRnd ps
tlimits Channel m bytes
channel
      in     (\(a
a, (Maybe bytes
trailing, StdGen
_)) -> (a
a, Maybe bytes
trailing))
         ((a, (Maybe bytes, StdGen)) -> (a, Maybe bytes))
-> m (a, (Maybe bytes, StdGen)) -> m (a, Maybe bytes)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Driver ps pr (Maybe bytes, StdGen) m
-> PeerPipelined ps pr st m a -> m (a, (Maybe bytes, StdGen))
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, StdGen) m
driver PeerPipelined ps pr st m a
peer


-- | Run two 'Peer's via a pair of connected 'Channel's and a common 'Codec'.
-- The client side is using 'driverWithLimits'.
--
-- This is useful for tests and quick experiments.
--
-- The first argument is expected to create two channels that are connected,
-- for example 'createConnectedChannels'.
--
runConnectedPeersWithLimits
  :: forall ps pr st failure bytes m a b.
     ( MonadAsync       m
     , MonadFork        m
     , MonadMask        m
     , MonadTimer       m
     , MonadThrow  (STM m)
     , Exception failure
     , ShowProxy ps
     , forall (st' :: ps) sing. sing ~ StateToken st' => Show sing
     )
  => m (Channel m bytes, Channel m bytes)
  -> Tracer m (Role, TraceSendRecv ps)
  -> Codec ps failure m bytes
  -> ProtocolSizeLimits ps bytes
  -> ProtocolTimeLimits ps
  -> Peer ps             pr  NonPipelined st m a
  -> Peer ps (FlipAgency pr) NonPipelined st m b
  -> m (a, b)
runConnectedPeersWithLimits :: forall ps (pr :: PeerRole) (st :: ps) failure bytes (m :: * -> *) a
       b.
(MonadAsync m, MonadFork m, MonadMask m, MonadTimer m,
 MonadThrow (STM m), Exception failure, ShowProxy ps,
 forall (st' :: ps) sing. (sing ~ StateToken st') => Show sing) =>
m (Channel m bytes, Channel m bytes)
-> Tracer m (Role, TraceSendRecv ps)
-> Codec ps failure m bytes
-> ProtocolSizeLimits ps bytes
-> ProtocolTimeLimits ps
-> Peer ps pr 'NonPipelined st m a
-> Peer ps (FlipAgency pr) 'NonPipelined st m b
-> m (a, b)
runConnectedPeersWithLimits m (Channel m bytes, Channel m bytes)
createChannels Tracer m (Role, TraceSendRecv ps)
tracer Codec ps failure m bytes
codec ProtocolSizeLimits ps bytes
slimits ProtocolTimeLimits ps
tlimits 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
-> ProtocolSizeLimits ps bytes
-> ProtocolTimeLimits ps
-> Channel m bytes
-> Peer ps pr 'NonPipelined st m a
-> m (a, Maybe bytes)
forall ps (st :: ps) (pr :: PeerRole) failure bytes (m :: * -> *)
       a.
(MonadAsync m, MonadFork m, MonadMask m, MonadThrow (STM m),
 MonadTimer m, ShowProxy ps,
 forall (st' :: ps) stok. (stok ~ StateToken st') => Show stok,
 Show failure) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> ProtocolSizeLimits ps bytes
-> ProtocolTimeLimits ps
-> Channel m bytes
-> Peer ps pr 'NonPipelined st m a
-> m (a, Maybe bytes)
runPeerWithLimits
                        Tracer m (TraceSendRecv ps)
tracerClient Codec ps failure m bytes
codec ProtocolSizeLimits ps bytes
slimits ProtocolTimeLimits ps
tlimits
                                     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


runConnectedPeersWithLimitsRnd
  :: forall ps pr st failure bytes m a b.
     ( MonadAsync       m
     , MonadFork        m
     , MonadMask        m
     , MonadTimer       m
     , MonadThrow  (STM m)
     , Exception failure
     , ShowProxy ps
     , forall (st' :: ps) sing. sing ~ StateToken st' => Show sing
     )
  => m (Channel m bytes, Channel m bytes)
  -> Tracer m (Role, TraceSendRecv ps)
  -> StdGen
  -> Codec ps failure m bytes
  -> ProtocolSizeLimits ps bytes
  -> ProtocolTimeLimitsWithRnd ps
  -> Peer ps             pr  NonPipelined st m a
  -> Peer ps (FlipAgency pr) NonPipelined st m b
  -> m (a, b)
runConnectedPeersWithLimitsRnd :: forall ps (pr :: PeerRole) (st :: ps) failure bytes (m :: * -> *) a
       b.
(MonadAsync m, MonadFork m, MonadMask m, MonadTimer m,
 MonadThrow (STM m), Exception failure, ShowProxy ps,
 forall (st' :: ps) sing. (sing ~ StateToken st') => Show sing) =>
m (Channel m bytes, Channel m bytes)
-> Tracer m (Role, TraceSendRecv ps)
-> StdGen
-> Codec ps failure m bytes
-> ProtocolSizeLimits ps bytes
-> ProtocolTimeLimitsWithRnd ps
-> Peer ps pr 'NonPipelined st m a
-> Peer ps (FlipAgency pr) 'NonPipelined st m b
-> m (a, b)
runConnectedPeersWithLimitsRnd m (Channel m bytes, Channel m bytes)
createChannels Tracer m (Role, TraceSendRecv ps)
tracer StdGen
rnd Codec ps failure m bytes
codec ProtocolSizeLimits ps bytes
slimits ProtocolTimeLimitsWithRnd ps
tlimits 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)
-> StdGen
-> Codec ps failure m bytes
-> ProtocolSizeLimits ps bytes
-> ProtocolTimeLimitsWithRnd ps
-> Channel m bytes
-> Peer ps pr 'NonPipelined st m a
-> m (a, Maybe bytes)
forall ps (st :: ps) (pr :: PeerRole) failure bytes (m :: * -> *)
       a.
(MonadAsync m, MonadFork m, MonadMask m, MonadThrow (STM m),
 MonadTimer m, ShowProxy ps,
 forall (st' :: ps) stok. (stok ~ StateToken st') => Show stok,
 Show failure) =>
Tracer m (TraceSendRecv ps)
-> StdGen
-> Codec ps failure m bytes
-> ProtocolSizeLimits ps bytes
-> ProtocolTimeLimitsWithRnd ps
-> Channel m bytes
-> Peer ps pr 'NonPipelined st m a
-> m (a, Maybe bytes)
runPeerWithLimitsRnd
                        Tracer m (TraceSendRecv ps)
tracerClient StdGen
rnd Codec ps failure m bytes
codec ProtocolSizeLimits ps bytes
slimits ProtocolTimeLimitsWithRnd ps
tlimits
                                     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


-- | Run two 'Peer's via a pair of connected 'Channel's and a common 'Codec'.
-- The client side is using 'driverWithLimits'.
--
-- This is useful for tests and quick experiments.
--
-- The first argument is expected to create two channels that are connected,
-- for example 'createConnectedChannels'.
--
runConnectedPipelinedPeersWithLimits
  :: forall ps pr st failure bytes m a b.
     ( MonadAsync      m
     , MonadFork       m
     , MonadMask       m
     , MonadTimer      m
     , MonadThrow (STM m)
     , Exception failure
     , ShowProxy ps
     , forall (st' :: ps) sing. sing ~ StateToken st' => Show sing
     )
  => m (Channel m bytes, Channel m bytes)
  -> Tracer m (Role, TraceSendRecv ps)
  -> Codec ps failure m bytes
  -> ProtocolSizeLimits ps bytes
  -> ProtocolTimeLimits ps
  -> PeerPipelined ps    pr               st m a
  -> Peer ps (FlipAgency pr) NonPipelined st m b
  -> m (a, b)
runConnectedPipelinedPeersWithLimits :: forall ps (pr :: PeerRole) (st :: ps) failure bytes (m :: * -> *) a
       b.
(MonadAsync m, MonadFork m, MonadMask m, MonadTimer m,
 MonadThrow (STM m), Exception failure, ShowProxy ps,
 forall (st' :: ps) sing. (sing ~ StateToken st') => Show sing) =>
m (Channel m bytes, Channel m bytes)
-> Tracer m (Role, TraceSendRecv ps)
-> Codec ps failure m bytes
-> ProtocolSizeLimits ps bytes
-> ProtocolTimeLimits ps
-> PeerPipelined ps pr st m a
-> Peer ps (FlipAgency pr) 'NonPipelined st m b
-> m (a, b)
runConnectedPipelinedPeersWithLimits m (Channel m bytes, Channel m bytes)
createChannels Tracer m (Role, TraceSendRecv ps)
tracer Codec ps failure m bytes
codec ProtocolSizeLimits ps bytes
slimits ProtocolTimeLimits ps
tlimits 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
-> ProtocolSizeLimits ps bytes
-> ProtocolTimeLimits ps
-> 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, MonadFork m, MonadMask m, MonadTimer m,
 MonadThrow (STM m), ShowProxy ps,
 forall (st' :: ps) stok. (stok ~ StateToken st') => Show stok,
 Show failure) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> ProtocolSizeLimits ps bytes
-> ProtocolTimeLimits ps
-> Channel m bytes
-> PeerPipelined ps pr st m a
-> m (a, Maybe bytes)
runPipelinedPeerWithLimits
                     Tracer m (TraceSendRecv ps)
tracerClient Codec ps failure m bytes
codec ProtocolSizeLimits ps bytes
slimits ProtocolTimeLimits ps
tlimits
                                        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


runConnectedPipelinedPeersWithLimitsRnd
  :: forall ps pr st failure bytes m a b.
     ( MonadAsync      m
     , MonadFork       m
     , MonadMask       m
     , MonadTimer      m
     , MonadThrow (STM m)
     , Exception failure
     , ShowProxy ps
     , forall (st' :: ps) sing. sing ~ StateToken st' => Show sing
     )
  => m (Channel m bytes, Channel m bytes)
  -> Tracer m (Role, TraceSendRecv ps)
  -> StdGen
  -> Codec ps failure m bytes
  -> ProtocolSizeLimits ps bytes
  -> ProtocolTimeLimitsWithRnd ps
  -> PeerPipelined ps    pr               st m a
  -> Peer ps (FlipAgency pr) NonPipelined st m b
  -> m (a, b)
runConnectedPipelinedPeersWithLimitsRnd :: forall ps (pr :: PeerRole) (st :: ps) failure bytes (m :: * -> *) a
       b.
(MonadAsync m, MonadFork m, MonadMask m, MonadTimer m,
 MonadThrow (STM m), Exception failure, ShowProxy ps,
 forall (st' :: ps) sing. (sing ~ StateToken st') => Show sing) =>
m (Channel m bytes, Channel m bytes)
-> Tracer m (Role, TraceSendRecv ps)
-> StdGen
-> Codec ps failure m bytes
-> ProtocolSizeLimits ps bytes
-> ProtocolTimeLimitsWithRnd ps
-> PeerPipelined ps pr st m a
-> Peer ps (FlipAgency pr) 'NonPipelined st m b
-> m (a, b)
runConnectedPipelinedPeersWithLimitsRnd m (Channel m bytes, Channel m bytes)
createChannels Tracer m (Role, TraceSendRecv ps)
tracer StdGen
rnd Codec ps failure m bytes
codec ProtocolSizeLimits ps bytes
slimits ProtocolTimeLimitsWithRnd ps
tlimits 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)
-> StdGen
-> Codec ps failure m bytes
-> ProtocolSizeLimits ps bytes
-> ProtocolTimeLimitsWithRnd ps
-> 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, MonadFork m, MonadMask m, MonadTimer m,
 MonadThrow (STM m), ShowProxy ps,
 forall (st' :: ps) stok. (stok ~ StateToken st') => Show stok,
 Show failure) =>
Tracer m (TraceSendRecv ps)
-> StdGen
-> Codec ps failure m bytes
-> ProtocolSizeLimits ps bytes
-> ProtocolTimeLimitsWithRnd ps
-> Channel m bytes
-> PeerPipelined ps pr st m a
-> m (a, Maybe bytes)
runPipelinedPeerWithLimitsRnd
                     Tracer m (TraceSendRecv ps)
tracerClient StdGen
rnd Codec ps failure m bytes
codec ProtocolSizeLimits ps bytes
slimits ProtocolTimeLimitsWithRnd ps
tlimits
                                        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