{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DeriveTraversable     #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE NamedFieldPuns        #-}
{-# LANGUAGE PatternSynonyms       #-}
{-# LANGUAGE PolyKinds             #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE StandaloneDeriving    #-}
{-# LANGUAGE TypeOperators         #-}

module Ouroboros.Network.Mux
  ( -- * Basic notions
    ProtocolTemperature (..)
  , SingProtocolTemperature (..)
  , SomeTokProtocolTemperature (..)
  , WithProtocolTemperature (..)
  , withoutProtocolTemperature
  , WithSomeProtocolTemperature (..)
  , withoutSomeProtocolTemperature
  , TemperatureBundle (..)
  , projectBundle
    -- * Mux mini-protocol callback
  , MiniProtocolCb (..)
  , mkMiniProtocolCbFromPeer
  , mkMiniProtocolCbFromPeerPipelined
  , mkMiniProtocolCbFromPeerSt
    -- * Mux mini-protocol callback in MuxMode
  , RunMiniProtocol (..)
  , RunMiniProtocolWithExpandedCtx
  , RunMiniProtocolWithMinimalCtx
    -- * MiniProtocol description
  , MiniProtocol (..)
  , MiniProtocolWithExpandedCtx
  , MiniProtocolWithMinimalCtx
  , MiniProtocolNum (..)
  , MiniProtocolLimits (..)
    -- * MiniProtocol bundle
  , OuroborosBundle
  , OuroborosBundleWithExpandedCtx
  , OuroborosBundleWithMinimalCtx
    -- * Non-P2P API
  , OuroborosApplication (..)
  , OuroborosApplicationWithMinimalCtx
  , mkMiniProtocolInfos
  , fromOuroborosBundle
  , toMiniProtocolInfos
  , contramapInitiatorCtx
    -- * Re-exports
    -- | from "Network.Mux"
  , Mux.HasInitiator
  , Mux.HasResponder
  ) where

import Control.Monad.Class.MonadAsync
import Control.Monad.Class.MonadThrow
import Control.Tracer (Tracer)

import Data.Foldable (fold)
import Data.Kind (Type)
import Data.Void (Void)

import Network.TypedProtocol.Codec
import Network.TypedProtocol.Core
import Network.TypedProtocol.Peer
import Network.TypedProtocol.Stateful.Codec qualified as Stateful
import Network.TypedProtocol.Stateful.Peer qualified as Stateful

import Network.Mux qualified as Mux
import Network.Mux.Types (MiniProtocolInfo, MiniProtocolLimits,
           MiniProtocolNum (..))

import Ouroboros.Network.Channel
import Ouroboros.Network.Context (ExpandedInitiatorContext,
           MinimalInitiatorContext, ResponderContext)
import Ouroboros.Network.Driver
import Ouroboros.Network.Driver.Stateful qualified as Stateful
import Ouroboros.Network.Util.ShowProxy (ShowProxy)


-- |  There are three kinds of applications: warm, hot and established (ones
-- that run in both warm and hot states).
--
data ProtocolTemperature = Established | Warm | Hot
  deriving (ProtocolTemperature -> ProtocolTemperature -> Bool
(ProtocolTemperature -> ProtocolTemperature -> Bool)
-> (ProtocolTemperature -> ProtocolTemperature -> Bool)
-> Eq ProtocolTemperature
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ProtocolTemperature -> ProtocolTemperature -> Bool
== :: ProtocolTemperature -> ProtocolTemperature -> Bool
$c/= :: ProtocolTemperature -> ProtocolTemperature -> Bool
/= :: ProtocolTemperature -> ProtocolTemperature -> Bool
Eq, Eq ProtocolTemperature
Eq ProtocolTemperature =>
(ProtocolTemperature -> ProtocolTemperature -> Ordering)
-> (ProtocolTemperature -> ProtocolTemperature -> Bool)
-> (ProtocolTemperature -> ProtocolTemperature -> Bool)
-> (ProtocolTemperature -> ProtocolTemperature -> Bool)
-> (ProtocolTemperature -> ProtocolTemperature -> Bool)
-> (ProtocolTemperature
    -> ProtocolTemperature -> ProtocolTemperature)
-> (ProtocolTemperature
    -> ProtocolTemperature -> ProtocolTemperature)
-> Ord ProtocolTemperature
ProtocolTemperature -> ProtocolTemperature -> Bool
ProtocolTemperature -> ProtocolTemperature -> Ordering
ProtocolTemperature -> ProtocolTemperature -> ProtocolTemperature
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ProtocolTemperature -> ProtocolTemperature -> Ordering
compare :: ProtocolTemperature -> ProtocolTemperature -> Ordering
$c< :: ProtocolTemperature -> ProtocolTemperature -> Bool
< :: ProtocolTemperature -> ProtocolTemperature -> Bool
$c<= :: ProtocolTemperature -> ProtocolTemperature -> Bool
<= :: ProtocolTemperature -> ProtocolTemperature -> Bool
$c> :: ProtocolTemperature -> ProtocolTemperature -> Bool
> :: ProtocolTemperature -> ProtocolTemperature -> Bool
$c>= :: ProtocolTemperature -> ProtocolTemperature -> Bool
>= :: ProtocolTemperature -> ProtocolTemperature -> Bool
$cmax :: ProtocolTemperature -> ProtocolTemperature -> ProtocolTemperature
max :: ProtocolTemperature -> ProtocolTemperature -> ProtocolTemperature
$cmin :: ProtocolTemperature -> ProtocolTemperature -> ProtocolTemperature
min :: ProtocolTemperature -> ProtocolTemperature -> ProtocolTemperature
Ord, Int -> ProtocolTemperature -> ShowS
[ProtocolTemperature] -> ShowS
ProtocolTemperature -> String
(Int -> ProtocolTemperature -> ShowS)
-> (ProtocolTemperature -> String)
-> ([ProtocolTemperature] -> ShowS)
-> Show ProtocolTemperature
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ProtocolTemperature -> ShowS
showsPrec :: Int -> ProtocolTemperature -> ShowS
$cshow :: ProtocolTemperature -> String
show :: ProtocolTemperature -> String
$cshowList :: [ProtocolTemperature] -> ShowS
showList :: [ProtocolTemperature] -> ShowS
Show)

-- | Singletons for 'ProtocolTemperature'.
--
data SingProtocolTemperature (pt :: ProtocolTemperature) where
    SingHot         :: SingProtocolTemperature Hot
    SingWarm        :: SingProtocolTemperature Warm
    SingEstablished :: SingProtocolTemperature Established

data SomeTokProtocolTemperature where
    SomeTokProtocolTemperature :: SingProtocolTemperature pt
                               -> SomeTokProtocolTemperature


-- | We keep hot, warm and established application (or their context) distinct.
-- It's only needed for a handy 'projectBundle' map.
--
data WithProtocolTemperature (pt :: ProtocolTemperature) a where
    WithHot         :: !a -> WithProtocolTemperature Hot  a
    WithWarm        :: !a -> WithProtocolTemperature Warm a
    WithEstablished :: !a -> WithProtocolTemperature Established a

deriving instance Eq a => Eq (WithProtocolTemperature pt a)
deriving instance Show a => Show (WithProtocolTemperature pt a)
deriving instance Functor     (WithProtocolTemperature pt)
deriving instance Foldable    (WithProtocolTemperature pt)
deriving instance Traversable (WithProtocolTemperature pt)

instance Applicative (WithProtocolTemperature Hot) where
    pure :: forall a. a -> WithProtocolTemperature 'Hot a
pure = a -> WithProtocolTemperature 'Hot a
forall a. a -> WithProtocolTemperature 'Hot a
WithHot
    <*> :: forall a b.
WithProtocolTemperature 'Hot (a -> b)
-> WithProtocolTemperature 'Hot a -> WithProtocolTemperature 'Hot b
(<*>) (WithHot a -> b
f) = (a -> b)
-> WithProtocolTemperature 'Hot a -> WithProtocolTemperature 'Hot b
forall a b.
(a -> b)
-> WithProtocolTemperature 'Hot a -> WithProtocolTemperature 'Hot b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f
instance Applicative (WithProtocolTemperature Warm) where
    pure :: forall a. a -> WithProtocolTemperature 'Warm a
pure = a -> WithProtocolTemperature 'Warm a
forall a. a -> WithProtocolTemperature 'Warm a
WithWarm
    <*> :: forall a b.
WithProtocolTemperature 'Warm (a -> b)
-> WithProtocolTemperature 'Warm a
-> WithProtocolTemperature 'Warm b
(<*>) (WithWarm a -> b
f) = (a -> b)
-> WithProtocolTemperature 'Warm a
-> WithProtocolTemperature 'Warm b
forall a b.
(a -> b)
-> WithProtocolTemperature 'Warm a
-> WithProtocolTemperature 'Warm b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f
instance Applicative (WithProtocolTemperature Established) where
    pure :: forall a. a -> WithProtocolTemperature 'Established a
pure = a -> WithProtocolTemperature 'Established a
forall a. a -> WithProtocolTemperature 'Established a
WithEstablished
    <*> :: forall a b.
WithProtocolTemperature 'Established (a -> b)
-> WithProtocolTemperature 'Established a
-> WithProtocolTemperature 'Established b
(<*>) (WithEstablished a -> b
f) = (a -> b)
-> WithProtocolTemperature 'Established a
-> WithProtocolTemperature 'Established b
forall a b.
(a -> b)
-> WithProtocolTemperature 'Established a
-> WithProtocolTemperature 'Established b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f

instance Semigroup a => Semigroup (WithProtocolTemperature Hot a) where
    WithHot a
a <> :: WithProtocolTemperature 'Hot a
-> WithProtocolTemperature 'Hot a -> WithProtocolTemperature 'Hot a
<> WithHot a
b                 = a -> WithProtocolTemperature 'Hot a
forall a. a -> WithProtocolTemperature 'Hot a
WithHot (a
a a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
b)
instance Semigroup a => Semigroup (WithProtocolTemperature Warm a) where
    WithWarm a
a <> :: WithProtocolTemperature 'Warm a
-> WithProtocolTemperature 'Warm a
-> WithProtocolTemperature 'Warm a
<> WithWarm a
b               = a -> WithProtocolTemperature 'Warm a
forall a. a -> WithProtocolTemperature 'Warm a
WithWarm (a
a a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
b)
instance Semigroup a => Semigroup (WithProtocolTemperature Established a) where
    WithEstablished a
a <> :: WithProtocolTemperature 'Established a
-> WithProtocolTemperature 'Established a
-> WithProtocolTemperature 'Established a
<> WithEstablished a
b = a -> WithProtocolTemperature 'Established a
forall a. a -> WithProtocolTemperature 'Established a
WithEstablished (a
a a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
b)

instance Monoid a => Monoid (WithProtocolTemperature Hot a) where
    mempty :: WithProtocolTemperature 'Hot a
mempty = a -> WithProtocolTemperature 'Hot a
forall a. a -> WithProtocolTemperature 'Hot a
WithHot a
forall a. Monoid a => a
mempty

instance Monoid a => Monoid (WithProtocolTemperature Warm a) where
    mempty :: WithProtocolTemperature 'Warm a
mempty = a -> WithProtocolTemperature 'Warm a
forall a. a -> WithProtocolTemperature 'Warm a
WithWarm a
forall a. Monoid a => a
mempty

instance Monoid a => Monoid (WithProtocolTemperature Established a) where
    mempty :: WithProtocolTemperature 'Established a
mempty = a -> WithProtocolTemperature 'Established a
forall a. a -> WithProtocolTemperature 'Established a
WithEstablished a
forall a. Monoid a => a
mempty


withoutProtocolTemperature :: WithProtocolTemperature pt a -> a
withoutProtocolTemperature :: forall (pt :: ProtocolTemperature) a.
WithProtocolTemperature pt a -> a
withoutProtocolTemperature (WithHot a
a)         = a
a
withoutProtocolTemperature (WithWarm a
a)        = a
a
withoutProtocolTemperature (WithEstablished a
a) = a
a


data WithSomeProtocolTemperature a where
    WithSomeProtocolTemperature :: WithProtocolTemperature pt a -> WithSomeProtocolTemperature a

deriving instance Show a => Show (WithSomeProtocolTemperature a)
deriving instance Functor WithSomeProtocolTemperature

withoutSomeProtocolTemperature :: WithSomeProtocolTemperature a -> a
withoutSomeProtocolTemperature :: forall a. WithSomeProtocolTemperature a -> a
withoutSomeProtocolTemperature (WithSomeProtocolTemperature WithProtocolTemperature pt a
a) = WithProtocolTemperature pt a -> a
forall (pt :: ProtocolTemperature) a.
WithProtocolTemperature pt a -> a
withoutProtocolTemperature WithProtocolTemperature pt a
a

-- | A bundle of 'HotApp', 'WarmApp' and 'EstablishedApp'.
--

data TemperatureBundle a =
      TemperatureBundle {
          -- | hot mini-protocols
          --
          forall a. TemperatureBundle a -> WithProtocolTemperature 'Hot a
withHot
            :: !(WithProtocolTemperature Hot a),

          -- | warm mini-protocols
          --
          forall a. TemperatureBundle a -> WithProtocolTemperature 'Warm a
withWarm
            :: !(WithProtocolTemperature Warm a),

          -- | established mini-protocols
          --
          forall a.
TemperatureBundle a -> WithProtocolTemperature 'Established a
withEstablished
            :: !(WithProtocolTemperature Established a)
        }
  deriving (TemperatureBundle a -> TemperatureBundle a -> Bool
(TemperatureBundle a -> TemperatureBundle a -> Bool)
-> (TemperatureBundle a -> TemperatureBundle a -> Bool)
-> Eq (TemperatureBundle a)
forall a.
Eq a =>
TemperatureBundle a -> TemperatureBundle a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a.
Eq a =>
TemperatureBundle a -> TemperatureBundle a -> Bool
== :: TemperatureBundle a -> TemperatureBundle a -> Bool
$c/= :: forall a.
Eq a =>
TemperatureBundle a -> TemperatureBundle a -> Bool
/= :: TemperatureBundle a -> TemperatureBundle a -> Bool
Eq, Int -> TemperatureBundle a -> ShowS
[TemperatureBundle a] -> ShowS
TemperatureBundle a -> String
(Int -> TemperatureBundle a -> ShowS)
-> (TemperatureBundle a -> String)
-> ([TemperatureBundle a] -> ShowS)
-> Show (TemperatureBundle a)
forall a. Show a => Int -> TemperatureBundle a -> ShowS
forall a. Show a => [TemperatureBundle a] -> ShowS
forall a. Show a => TemperatureBundle a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> TemperatureBundle a -> ShowS
showsPrec :: Int -> TemperatureBundle a -> ShowS
$cshow :: forall a. Show a => TemperatureBundle a -> String
show :: TemperatureBundle a -> String
$cshowList :: forall a. Show a => [TemperatureBundle a] -> ShowS
showList :: [TemperatureBundle a] -> ShowS
Show, (forall a b.
 (a -> b) -> TemperatureBundle a -> TemperatureBundle b)
-> (forall a b. a -> TemperatureBundle b -> TemperatureBundle a)
-> Functor TemperatureBundle
forall a b. a -> TemperatureBundle b -> TemperatureBundle a
forall a b. (a -> b) -> TemperatureBundle a -> TemperatureBundle b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> TemperatureBundle a -> TemperatureBundle b
fmap :: forall a b. (a -> b) -> TemperatureBundle a -> TemperatureBundle b
$c<$ :: forall a b. a -> TemperatureBundle b -> TemperatureBundle a
<$ :: forall a b. a -> TemperatureBundle b -> TemperatureBundle a
Functor, (forall m. Monoid m => TemperatureBundle m -> m)
-> (forall m a. Monoid m => (a -> m) -> TemperatureBundle a -> m)
-> (forall m a. Monoid m => (a -> m) -> TemperatureBundle a -> m)
-> (forall a b. (a -> b -> b) -> b -> TemperatureBundle a -> b)
-> (forall a b. (a -> b -> b) -> b -> TemperatureBundle a -> b)
-> (forall b a. (b -> a -> b) -> b -> TemperatureBundle a -> b)
-> (forall b a. (b -> a -> b) -> b -> TemperatureBundle a -> b)
-> (forall a. (a -> a -> a) -> TemperatureBundle a -> a)
-> (forall a. (a -> a -> a) -> TemperatureBundle a -> a)
-> (forall a. TemperatureBundle a -> [a])
-> (forall a. TemperatureBundle a -> Bool)
-> (forall a. TemperatureBundle a -> Int)
-> (forall a. Eq a => a -> TemperatureBundle a -> Bool)
-> (forall a. Ord a => TemperatureBundle a -> a)
-> (forall a. Ord a => TemperatureBundle a -> a)
-> (forall a. Num a => TemperatureBundle a -> a)
-> (forall a. Num a => TemperatureBundle a -> a)
-> Foldable TemperatureBundle
forall a. Eq a => a -> TemperatureBundle a -> Bool
forall a. Num a => TemperatureBundle a -> a
forall a. Ord a => TemperatureBundle a -> a
forall m. Monoid m => TemperatureBundle m -> m
forall a. TemperatureBundle a -> Bool
forall a. TemperatureBundle a -> Int
forall a. TemperatureBundle a -> [a]
forall a. (a -> a -> a) -> TemperatureBundle a -> a
forall m a. Monoid m => (a -> m) -> TemperatureBundle a -> m
forall b a. (b -> a -> b) -> b -> TemperatureBundle a -> b
forall a b. (a -> b -> b) -> b -> TemperatureBundle a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => TemperatureBundle m -> m
fold :: forall m. Monoid m => TemperatureBundle m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> TemperatureBundle a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> TemperatureBundle a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> TemperatureBundle a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> TemperatureBundle a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> TemperatureBundle a -> b
foldr :: forall a b. (a -> b -> b) -> b -> TemperatureBundle a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> TemperatureBundle a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> TemperatureBundle a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> TemperatureBundle a -> b
foldl :: forall b a. (b -> a -> b) -> b -> TemperatureBundle a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> TemperatureBundle a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> TemperatureBundle a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> TemperatureBundle a -> a
foldr1 :: forall a. (a -> a -> a) -> TemperatureBundle a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> TemperatureBundle a -> a
foldl1 :: forall a. (a -> a -> a) -> TemperatureBundle a -> a
$ctoList :: forall a. TemperatureBundle a -> [a]
toList :: forall a. TemperatureBundle a -> [a]
$cnull :: forall a. TemperatureBundle a -> Bool
null :: forall a. TemperatureBundle a -> Bool
$clength :: forall a. TemperatureBundle a -> Int
length :: forall a. TemperatureBundle a -> Int
$celem :: forall a. Eq a => a -> TemperatureBundle a -> Bool
elem :: forall a. Eq a => a -> TemperatureBundle a -> Bool
$cmaximum :: forall a. Ord a => TemperatureBundle a -> a
maximum :: forall a. Ord a => TemperatureBundle a -> a
$cminimum :: forall a. Ord a => TemperatureBundle a -> a
minimum :: forall a. Ord a => TemperatureBundle a -> a
$csum :: forall a. Num a => TemperatureBundle a -> a
sum :: forall a. Num a => TemperatureBundle a -> a
$cproduct :: forall a. Num a => TemperatureBundle a -> a
product :: forall a. Num a => TemperatureBundle a -> a
Foldable, Functor TemperatureBundle
Foldable TemperatureBundle
(Functor TemperatureBundle, Foldable TemperatureBundle) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> TemperatureBundle a -> f (TemperatureBundle b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    TemperatureBundle (f a) -> f (TemperatureBundle a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> TemperatureBundle a -> m (TemperatureBundle b))
-> (forall (m :: * -> *) a.
    Monad m =>
    TemperatureBundle (m a) -> m (TemperatureBundle a))
-> Traversable TemperatureBundle
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
TemperatureBundle (m a) -> m (TemperatureBundle a)
forall (f :: * -> *) a.
Applicative f =>
TemperatureBundle (f a) -> f (TemperatureBundle a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> TemperatureBundle a -> m (TemperatureBundle b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> TemperatureBundle a -> f (TemperatureBundle b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> TemperatureBundle a -> f (TemperatureBundle b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> TemperatureBundle a -> f (TemperatureBundle b)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
TemperatureBundle (f a) -> f (TemperatureBundle a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
TemperatureBundle (f a) -> f (TemperatureBundle a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> TemperatureBundle a -> m (TemperatureBundle b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> TemperatureBundle a -> m (TemperatureBundle b)
$csequence :: forall (m :: * -> *) a.
Monad m =>
TemperatureBundle (m a) -> m (TemperatureBundle a)
sequence :: forall (m :: * -> *) a.
Monad m =>
TemperatureBundle (m a) -> m (TemperatureBundle a)
Traversable)

instance Semigroup a => Semigroup (TemperatureBundle a) where
    TemperatureBundle WithProtocolTemperature 'Hot a
hot WithProtocolTemperature 'Warm a
warm WithProtocolTemperature 'Established a
established <> :: TemperatureBundle a -> TemperatureBundle a -> TemperatureBundle a
<> TemperatureBundle WithProtocolTemperature 'Hot a
hot' WithProtocolTemperature 'Warm a
warm' WithProtocolTemperature 'Established a
established' =
      WithProtocolTemperature 'Hot a
-> WithProtocolTemperature 'Warm a
-> WithProtocolTemperature 'Established a
-> TemperatureBundle a
forall a.
WithProtocolTemperature 'Hot a
-> WithProtocolTemperature 'Warm a
-> WithProtocolTemperature 'Established a
-> TemperatureBundle a
TemperatureBundle (WithProtocolTemperature 'Hot a
hot WithProtocolTemperature 'Hot a
-> WithProtocolTemperature 'Hot a -> WithProtocolTemperature 'Hot a
forall a. Semigroup a => a -> a -> a
<> WithProtocolTemperature 'Hot a
hot')
                        (WithProtocolTemperature 'Warm a
warm WithProtocolTemperature 'Warm a
-> WithProtocolTemperature 'Warm a
-> WithProtocolTemperature 'Warm a
forall a. Semigroup a => a -> a -> a
<> WithProtocolTemperature 'Warm a
warm')
                        (WithProtocolTemperature 'Established a
established WithProtocolTemperature 'Established a
-> WithProtocolTemperature 'Established a
-> WithProtocolTemperature 'Established a
forall a. Semigroup a => a -> a -> a
<> WithProtocolTemperature 'Established a
established')

instance Monoid a => Monoid (TemperatureBundle a) where
    mempty :: TemperatureBundle a
mempty = WithProtocolTemperature 'Hot a
-> WithProtocolTemperature 'Warm a
-> WithProtocolTemperature 'Established a
-> TemperatureBundle a
forall a.
WithProtocolTemperature 'Hot a
-> WithProtocolTemperature 'Warm a
-> WithProtocolTemperature 'Established a
-> TemperatureBundle a
TemperatureBundle WithProtocolTemperature 'Hot a
forall a. Monoid a => a
mempty WithProtocolTemperature 'Warm a
forall a. Monoid a => a
mempty WithProtocolTemperature 'Established a
forall a. Monoid a => a
mempty

projectBundle :: SingProtocolTemperature pt -> TemperatureBundle a -> a
projectBundle :: forall (pt :: ProtocolTemperature) a.
SingProtocolTemperature pt -> TemperatureBundle a -> a
projectBundle SingProtocolTemperature pt
SingHot         = WithProtocolTemperature 'Hot a -> a
forall (pt :: ProtocolTemperature) a.
WithProtocolTemperature pt a -> a
withoutProtocolTemperature (WithProtocolTemperature 'Hot a -> a)
-> (TemperatureBundle a -> WithProtocolTemperature 'Hot a)
-> TemperatureBundle a
-> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TemperatureBundle a -> WithProtocolTemperature 'Hot a
forall a. TemperatureBundle a -> WithProtocolTemperature 'Hot a
withHot
projectBundle SingProtocolTemperature pt
SingWarm        = WithProtocolTemperature 'Warm a -> a
forall (pt :: ProtocolTemperature) a.
WithProtocolTemperature pt a -> a
withoutProtocolTemperature (WithProtocolTemperature 'Warm a -> a)
-> (TemperatureBundle a -> WithProtocolTemperature 'Warm a)
-> TemperatureBundle a
-> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TemperatureBundle a -> WithProtocolTemperature 'Warm a
forall a. TemperatureBundle a -> WithProtocolTemperature 'Warm a
withWarm
projectBundle SingProtocolTemperature pt
SingEstablished = WithProtocolTemperature 'Established a -> a
forall (pt :: ProtocolTemperature) a.
WithProtocolTemperature pt a -> a
withoutProtocolTemperature (WithProtocolTemperature 'Established a -> a)
-> (TemperatureBundle a -> WithProtocolTemperature 'Established a)
-> TemperatureBundle a
-> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TemperatureBundle a -> WithProtocolTemperature 'Established a
forall a.
TemperatureBundle a -> WithProtocolTemperature 'Established a
withEstablished


instance Applicative TemperatureBundle where
    pure :: forall a. a -> TemperatureBundle a
pure a
a = WithProtocolTemperature 'Hot a
-> WithProtocolTemperature 'Warm a
-> WithProtocolTemperature 'Established a
-> TemperatureBundle a
forall a.
WithProtocolTemperature 'Hot a
-> WithProtocolTemperature 'Warm a
-> WithProtocolTemperature 'Established a
-> TemperatureBundle a
TemperatureBundle (a -> WithProtocolTemperature 'Hot a
forall a. a -> WithProtocolTemperature 'Hot a
WithHot a
a) (a -> WithProtocolTemperature 'Warm a
forall a. a -> WithProtocolTemperature 'Warm a
WithWarm a
a) (a -> WithProtocolTemperature 'Established a
forall a. a -> WithProtocolTemperature 'Established a
WithEstablished a
a)
    TemperatureBundle WithProtocolTemperature 'Hot (a -> b)
hotFn
                      WithProtocolTemperature 'Warm (a -> b)
warmFn
                      WithProtocolTemperature 'Established (a -> b)
establishedFn
      <*> :: forall a b.
TemperatureBundle (a -> b)
-> TemperatureBundle a -> TemperatureBundle b
<*> TemperatureBundle WithProtocolTemperature 'Hot a
hot
                            WithProtocolTemperature 'Warm a
warm
                            WithProtocolTemperature 'Established a
established =
          WithProtocolTemperature 'Hot b
-> WithProtocolTemperature 'Warm b
-> WithProtocolTemperature 'Established b
-> TemperatureBundle b
forall a.
WithProtocolTemperature 'Hot a
-> WithProtocolTemperature 'Warm a
-> WithProtocolTemperature 'Established a
-> TemperatureBundle a
TemperatureBundle (WithProtocolTemperature 'Hot (a -> b)
hotFn WithProtocolTemperature 'Hot (a -> b)
-> WithProtocolTemperature 'Hot a -> WithProtocolTemperature 'Hot b
forall a b.
WithProtocolTemperature 'Hot (a -> b)
-> WithProtocolTemperature 'Hot a -> WithProtocolTemperature 'Hot b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> WithProtocolTemperature 'Hot a
hot)
                            (WithProtocolTemperature 'Warm (a -> b)
warmFn WithProtocolTemperature 'Warm (a -> b)
-> WithProtocolTemperature 'Warm a
-> WithProtocolTemperature 'Warm b
forall a b.
WithProtocolTemperature 'Warm (a -> b)
-> WithProtocolTemperature 'Warm a
-> WithProtocolTemperature 'Warm b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> WithProtocolTemperature 'Warm a
warm)
                            (WithProtocolTemperature 'Established (a -> b)
establishedFn WithProtocolTemperature 'Established (a -> b)
-> WithProtocolTemperature 'Established a
-> WithProtocolTemperature 'Established b
forall a b.
WithProtocolTemperature 'Established (a -> b)
-> WithProtocolTemperature 'Established a
-> WithProtocolTemperature 'Established b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> WithProtocolTemperature 'Established a
established)

--
-- Useful type synonyms
--

type OuroborosBundle   (mode :: Mux.Mode) initiatorCtx responderCtx bytes m a b =
    TemperatureBundle [MiniProtocol mode initiatorCtx responderCtx bytes m a b]

-- | 'OuroborosBundle' used in P2P.
--
type OuroborosBundleWithExpandedCtx (mode :: Mux.Mode) peerAddr bytes m a b =
     OuroborosBundle mode
                     (ExpandedInitiatorContext peerAddr m)
                     (ResponderContext peerAddr)
                     bytes m a b

type OuroborosBundleWithMinimalCtx (mode :: Mux.Mode) peerAddr bytes m a b =
     OuroborosBundle mode
                     (MinimalInitiatorContext peerAddr)
                     (ResponderContext peerAddr)
                     bytes m a b


-- | Each mini-protocol is represented by its
--
-- * mini-protocol number,
-- * ingress size limit, and
-- * callbacks.
--
data MiniProtocol (mode :: Mux.Mode) initiatorCtx responderCtx bytes m a b =
     MiniProtocol {
       forall (mode :: Mode) initiatorCtx responderCtx bytes (m :: * -> *)
       a b.
MiniProtocol mode initiatorCtx responderCtx bytes m a b
-> MiniProtocolNum
miniProtocolNum    :: !MiniProtocolNum,
       forall (mode :: Mode) initiatorCtx responderCtx bytes (m :: * -> *)
       a b.
MiniProtocol mode initiatorCtx responderCtx bytes m a b
-> MiniProtocolLimits
miniProtocolLimits :: !MiniProtocolLimits,
       forall (mode :: Mode) initiatorCtx responderCtx bytes (m :: * -> *)
       a b.
MiniProtocol mode initiatorCtx responderCtx bytes m a b
-> RunMiniProtocol mode initiatorCtx responderCtx bytes m a b
miniProtocolRun    :: !(RunMiniProtocol mode initiatorCtx responderCtx bytes m a b)
     }

mkMiniProtocolInfo :: MiniProtocol mode initiatorCtx responderCtx bytes m a b -> [MiniProtocolInfo mode]
mkMiniProtocolInfo :: forall (mode :: Mode) initiatorCtx responderCtx bytes (m :: * -> *)
       a b.
MiniProtocol mode initiatorCtx responderCtx bytes m a b
-> [MiniProtocolInfo mode]
mkMiniProtocolInfo MiniProtocol {
     MiniProtocolNum
miniProtocolNum :: forall (mode :: Mode) initiatorCtx responderCtx bytes (m :: * -> *)
       a b.
MiniProtocol mode initiatorCtx responderCtx bytes m a b
-> MiniProtocolNum
miniProtocolNum :: MiniProtocolNum
miniProtocolNum,
     MiniProtocolLimits
miniProtocolLimits :: forall (mode :: Mode) initiatorCtx responderCtx bytes (m :: * -> *)
       a b.
MiniProtocol mode initiatorCtx responderCtx bytes m a b
-> MiniProtocolLimits
miniProtocolLimits :: MiniProtocolLimits
miniProtocolLimits,
     RunMiniProtocol mode initiatorCtx responderCtx bytes m a b
miniProtocolRun :: forall (mode :: Mode) initiatorCtx responderCtx bytes (m :: * -> *)
       a b.
MiniProtocol mode initiatorCtx responderCtx bytes m a b
-> RunMiniProtocol mode initiatorCtx responderCtx bytes m a b
miniProtocolRun :: RunMiniProtocol mode initiatorCtx responderCtx bytes m a b
miniProtocolRun
   }
  =
  [ Mux.MiniProtocolInfo {
      MiniProtocolNum
miniProtocolNum :: MiniProtocolNum
miniProtocolNum :: MiniProtocolNum
Mux.miniProtocolNum,
      miniProtocolDir :: MiniProtocolDirection mode
Mux.miniProtocolDir = MiniProtocolDirection mode
dir,
      MiniProtocolLimits
miniProtocolLimits :: MiniProtocolLimits
miniProtocolLimits :: MiniProtocolLimits
Mux.miniProtocolLimits
    }
  | MiniProtocolDirection mode
dir <- case RunMiniProtocol mode initiatorCtx responderCtx bytes m a b
miniProtocolRun of
             InitiatorProtocolOnly{}         -> [ MiniProtocolDirection mode
MiniProtocolDirection 'InitiatorMode
Mux.InitiatorDirectionOnly ]
             ResponderProtocolOnly{}         -> [ MiniProtocolDirection mode
MiniProtocolDirection 'ResponderMode
Mux.ResponderDirectionOnly ]
             InitiatorAndResponderProtocol{} -> [ MiniProtocolDirection mode
MiniProtocolDirection 'InitiatorResponderMode
Mux.InitiatorDirection
                                                , MiniProtocolDirection mode
MiniProtocolDirection 'InitiatorResponderMode
Mux.ResponderDirection ]
  ]


-- | 'MiniProtocol' type used in P2P.
--
type MiniProtocolWithExpandedCtx mode peerAddr bytes m a b =
     MiniProtocol mode (ExpandedInitiatorContext peerAddr m)
                       (ResponderContext peerAddr)
                       bytes m a b

-- | 'MiniProtocol' type used in non-P2P.
--
type MiniProtocolWithMinimalCtx mode peerAddr bytes m a b =
     MiniProtocol mode (MinimalInitiatorContext peerAddr)
                       (ResponderContext peerAddr)
                       bytes m a b


-- | 'RunMiniProtocol'.  It also capture context (the `IsBigLedgerPeer`) which
-- is passed to the mini-protocol when a mini-protocol is started.
--
data RunMiniProtocol (mode :: Mux.Mode) initiatorCtx responderCtx bytes m a b where
     InitiatorProtocolOnly
       :: (MiniProtocolCb initiatorCtx bytes m a)
       -> RunMiniProtocol Mux.InitiatorMode initiatorCtx responderCtx bytes m a Void

     ResponderProtocolOnly
       :: (MiniProtocolCb responderCtx bytes m b)
       -> RunMiniProtocol Mux.ResponderMode initiatorCtx responderCtx bytes m Void b

     InitiatorAndResponderProtocol
       :: (MiniProtocolCb initiatorCtx bytes m a)
       -> (MiniProtocolCb responderCtx bytes m b)
       -> RunMiniProtocol Mux.InitiatorResponderMode initiatorCtx responderCtx bytes m a b


-- | 'RunMiniProtocol' with 'ExpandedInitiatorContext' and 'ResponderContext'.
--
-- Used to run P2P node-to-node applications.
--
type RunMiniProtocolWithExpandedCtx mode peerAddr bytes m a b =
     RunMiniProtocol mode
                     (ExpandedInitiatorContext peerAddr m)
                     (ResponderContext peerAddr)
                     bytes m a b


-- | 'RunMiniProtocol' with 'MinimalInitiatorContext' and 'ResponderContext'.
--
-- Use to run node-to-client application as well as in some non p2p contexts.
--
type RunMiniProtocolWithMinimalCtx mode peerAddr bytes m a b =
     RunMiniProtocol mode
                     (MinimalInitiatorContext peerAddr)
                     (ResponderContext peerAddr)
                     bytes m a b


--
-- MiniProtocol callback
--

-- | A callback executed by each muxed mini-protocol.
--
newtype MiniProtocolCb ctx bytes m a =
    MiniProtocolCb {
      forall ctx bytes (m :: * -> *) a.
MiniProtocolCb ctx bytes m a
-> ctx -> Channel m bytes -> m (a, Maybe bytes)
runMiniProtocolCb ::
        ctx -> Channel m bytes -> m (a, Maybe bytes)
    }


-- | Create a 'MuxPeer' from a tracer, codec and 'Peer'.
--
mkMiniProtocolCbFromPeer
  :: forall (pr :: PeerRole) ps (st :: ps) failure bytes ctx m a.
     ( MonadThrow m
     , ShowProxy ps
     , forall (st' :: ps) stok. stok ~ StateToken st' => Show stok
     , Show failure
     )
  => (ctx -> ( Tracer m (TraceSendRecv ps)
             , Codec ps failure m bytes
             , Peer ps pr NonPipelined st m a
             )
     )
  -> MiniProtocolCb ctx bytes m a
mkMiniProtocolCbFromPeer :: forall (pr :: PeerRole) ps (st :: ps) failure bytes ctx
       (m :: * -> *) a.
(MonadThrow m, ShowProxy ps,
 forall (st' :: ps) stok. (stok ~ StateToken st') => Show stok,
 Show failure) =>
(ctx
 -> (Tracer m (TraceSendRecv ps), Codec ps failure m bytes,
     Peer ps pr 'NonPipelined st m a))
-> MiniProtocolCb ctx bytes m a
mkMiniProtocolCbFromPeer ctx
-> (Tracer m (TraceSendRecv ps), Codec ps failure m bytes,
    Peer ps pr 'NonPipelined st m a)
fn =
    (ctx -> Channel m bytes -> m (a, Maybe bytes))
-> MiniProtocolCb ctx bytes m a
forall ctx bytes (m :: * -> *) a.
(ctx -> Channel m bytes -> m (a, Maybe bytes))
-> MiniProtocolCb ctx bytes m a
MiniProtocolCb ((ctx -> Channel m bytes -> m (a, Maybe bytes))
 -> MiniProtocolCb ctx bytes m a)
-> (ctx -> Channel m bytes -> m (a, Maybe bytes))
-> MiniProtocolCb ctx bytes m a
forall a b. (a -> b) -> a -> b
$ \ctx
ctx Channel m bytes
channel ->
      case ctx
-> (Tracer m (TraceSendRecv ps), Codec ps failure m bytes,
    Peer ps pr 'NonPipelined st m a)
fn ctx
ctx of
        (Tracer m (TraceSendRecv ps)
tracer, Codec ps failure m bytes
codec, Peer ps pr 'NonPipelined st m a
peer) ->
          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)
tracer Codec ps failure m bytes
codec Channel m bytes
channel Peer ps pr 'NonPipelined st m a
peer

-- | Create a 'MuxPeer' from a tracer, codec and 'Stateful.Peer'.
--
mkMiniProtocolCbFromPeerSt
  :: forall (pr :: PeerRole) ps (f :: ps -> Type) (st :: ps) failure bytes ctx m a.
     ( MonadAsync m
     , MonadMask  m
     , ShowProxy ps
     , forall (st' :: ps) stok. stok ~ StateToken st' => Show stok
     , Show failure
     )
  => (ctx -> ( Tracer m (Stateful.TraceSendRecv ps f)
             , Stateful.Codec ps failure f m bytes
             , f st
             , Stateful.Peer ps pr st f m a
             )
     )
  -> MiniProtocolCb ctx bytes m a
mkMiniProtocolCbFromPeerSt :: forall (pr :: PeerRole) ps (f :: ps -> *) (st :: ps) failure bytes
       ctx (m :: * -> *) a.
(MonadAsync m, MonadMask m, ShowProxy ps,
 forall (st' :: ps) stok. (stok ~ StateToken st') => Show stok,
 Show failure) =>
(ctx
 -> (Tracer m (TraceSendRecv ps f), Codec ps failure f m bytes,
     f st, Peer ps pr st f m a))
-> MiniProtocolCb ctx bytes m a
mkMiniProtocolCbFromPeerSt ctx
-> (Tracer m (TraceSendRecv ps f), Codec ps failure f m bytes,
    f st, Peer ps pr st f m a)
fn =
    (ctx -> Channel m bytes -> m (a, Maybe bytes))
-> MiniProtocolCb ctx bytes m a
forall ctx bytes (m :: * -> *) a.
(ctx -> Channel m bytes -> m (a, Maybe bytes))
-> MiniProtocolCb ctx bytes m a
MiniProtocolCb ((ctx -> Channel m bytes -> m (a, Maybe bytes))
 -> MiniProtocolCb ctx bytes m a)
-> (ctx -> Channel m bytes -> m (a, Maybe bytes))
-> MiniProtocolCb ctx bytes m a
forall a b. (a -> b) -> a -> b
$ \ctx
ctx Channel m bytes
channel ->
      case ctx
-> (Tracer m (TraceSendRecv ps f), Codec ps failure f m bytes,
    f st, Peer ps pr st f m a)
fn ctx
ctx of
        (Tracer m (TraceSendRecv ps f)
tracer, Codec ps failure f m bytes
codec, f st
f, Peer ps pr st f m a
peer) ->
          Tracer m (TraceSendRecv ps f)
-> Codec ps failure f m bytes
-> Channel m bytes
-> f st
-> Peer ps pr st f m a
-> m (a, Maybe bytes)
forall ps (st :: ps) (pr :: PeerRole) failure bytes (f :: ps -> *)
       (m :: * -> *) a.
(MonadAsync m, MonadMask m, Show failure,
 forall (st' :: ps) stok. (stok ~ StateToken st') => Show stok,
 ShowProxy ps) =>
Tracer m (TraceSendRecv ps f)
-> Codec ps failure f m bytes
-> Channel m bytes
-> f st
-> Peer ps pr st f m a
-> m (a, Maybe bytes)
Stateful.runPeer Tracer m (TraceSendRecv ps f)
tracer Codec ps failure f m bytes
codec Channel m bytes
channel f st
f Peer ps pr st f m a
peer


-- | Create a 'MuxPeer' from a tracer, codec and 'PeerPipelined'.
--
mkMiniProtocolCbFromPeerPipelined
  :: forall (pr :: PeerRole) ps (st :: ps) failure ctx bytes m a.
     ( MonadAsync m
     , MonadThrow m
     , ShowProxy ps
     , forall (st' :: ps) stok. stok ~ StateToken st' => Show stok
     , Show failure
     )
  => (ctx -> ( Tracer m (TraceSendRecv ps)
             , Codec ps failure m bytes
             , PeerPipelined ps pr st m a
             )
     )
  -> MiniProtocolCb ctx bytes m a
mkMiniProtocolCbFromPeerPipelined :: forall (pr :: PeerRole) ps (st :: ps) failure ctx bytes
       (m :: * -> *) a.
(MonadAsync m, MonadThrow m, ShowProxy ps,
 forall (st' :: ps) stok. (stok ~ StateToken st') => Show stok,
 Show failure) =>
(ctx
 -> (Tracer m (TraceSendRecv ps), Codec ps failure m bytes,
     PeerPipelined ps pr st m a))
-> MiniProtocolCb ctx bytes m a
mkMiniProtocolCbFromPeerPipelined ctx
-> (Tracer m (TraceSendRecv ps), Codec ps failure m bytes,
    PeerPipelined ps pr st m a)
fn =
    (ctx -> Channel m bytes -> m (a, Maybe bytes))
-> MiniProtocolCb ctx bytes m a
forall ctx bytes (m :: * -> *) a.
(ctx -> Channel m bytes -> m (a, Maybe bytes))
-> MiniProtocolCb ctx bytes m a
MiniProtocolCb ((ctx -> Channel m bytes -> m (a, Maybe bytes))
 -> MiniProtocolCb ctx bytes m a)
-> (ctx -> Channel m bytes -> m (a, Maybe bytes))
-> MiniProtocolCb ctx bytes m a
forall a b. (a -> b) -> a -> b
$ \ctx
ctx Channel m bytes
channel ->
      case ctx
-> (Tracer m (TraceSendRecv ps), Codec ps failure m bytes,
    PeerPipelined ps pr st m a)
fn ctx
ctx of
        (Tracer m (TraceSendRecv ps)
tracer, Codec ps failure m bytes
codec, PeerPipelined ps pr st m a
peer) ->
          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)
tracer Codec ps failure m bytes
codec Channel m bytes
channel PeerPipelined ps pr st m a
peer


contramapMiniProtocolCbCtx :: (ctx -> ctx')
                           -> MiniProtocolCb ctx' bytes m a
                           -> MiniProtocolCb ctx  bytes m a
contramapMiniProtocolCbCtx :: forall ctx ctx' bytes (m :: * -> *) a.
(ctx -> ctx')
-> MiniProtocolCb ctx' bytes m a -> MiniProtocolCb ctx bytes m a
contramapMiniProtocolCbCtx ctx -> ctx'
f (MiniProtocolCb ctx' -> Channel m bytes -> m (a, Maybe bytes)
cb) = (ctx -> Channel m bytes -> m (a, Maybe bytes))
-> MiniProtocolCb ctx bytes m a
forall ctx bytes (m :: * -> *) a.
(ctx -> Channel m bytes -> m (a, Maybe bytes))
-> MiniProtocolCb ctx bytes m a
MiniProtocolCb (ctx' -> Channel m bytes -> m (a, Maybe bytes)
cb (ctx' -> Channel m bytes -> m (a, Maybe bytes))
-> (ctx -> ctx') -> ctx -> Channel m bytes -> m (a, Maybe bytes)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ctx -> ctx'
f)


-- |  Like 'MuxApplication' but using a 'MuxPeer' rather than a raw
-- @Channel -> m a@ action.
--
-- Note: Only used in some non-P2P contexts.
newtype OuroborosApplication  (mode :: Mux.Mode) initiatorCtx responderCtx bytes m a b =
  OuroborosApplication {
    forall (mode :: Mode) initiatorCtx responderCtx bytes (m :: * -> *)
       a b.
OuroborosApplication mode initiatorCtx responderCtx bytes m a b
-> [MiniProtocol mode initiatorCtx responderCtx bytes m a b]
getOuroborosApplication
      :: [MiniProtocol mode initiatorCtx responderCtx bytes m a b]
  }

-- | 'OuroborosApplication' used in NonP2P mode.
--
type OuroborosApplicationWithMinimalCtx mode peerAddr bytes m a b =
     OuroborosApplication mode
                          (MinimalInitiatorContext peerAddr)
                          (ResponderContext peerAddr)
                          bytes m a b

fromOuroborosBundle :: OuroborosBundle      mode initiatorCtx responderCtx bytes m a b
                    -> OuroborosApplication mode initiatorCtx responderCtx bytes m a b
fromOuroborosBundle :: forall (mode :: Mode) initiatorCtx responderCtx bytes (m :: * -> *)
       a b.
OuroborosBundle mode initiatorCtx responderCtx bytes m a b
-> OuroborosApplication mode initiatorCtx responderCtx bytes m a b
fromOuroborosBundle = [MiniProtocol mode initiatorCtx responderCtx bytes m a b]
-> OuroborosApplication mode initiatorCtx responderCtx bytes m a b
forall (mode :: Mode) initiatorCtx responderCtx bytes (m :: * -> *)
       a b.
[MiniProtocol mode initiatorCtx responderCtx bytes m a b]
-> OuroborosApplication mode initiatorCtx responderCtx bytes m a b
OuroborosApplication ([MiniProtocol mode initiatorCtx responderCtx bytes m a b]
 -> OuroborosApplication mode initiatorCtx responderCtx bytes m a b)
-> (OuroborosBundle mode initiatorCtx responderCtx bytes m a b
    -> [MiniProtocol mode initiatorCtx responderCtx bytes m a b])
-> OuroborosBundle mode initiatorCtx responderCtx bytes m a b
-> OuroborosApplication mode initiatorCtx responderCtx bytes m a b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OuroborosBundle mode initiatorCtx responderCtx bytes m a b
-> [MiniProtocol mode initiatorCtx responderCtx bytes m a b]
forall m. Monoid m => TemperatureBundle m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold


toMiniProtocolInfos :: OuroborosApplication mode initiatorCtx responderCtx bytes m a b
                    -> [MiniProtocolInfo mode]
toMiniProtocolInfos :: forall (mode :: Mode) initiatorCtx responderCtx bytes (m :: * -> *)
       a b.
OuroborosApplication mode initiatorCtx responderCtx bytes m a b
-> [MiniProtocolInfo mode]
toMiniProtocolInfos =
    (MiniProtocol mode initiatorCtx responderCtx bytes m a b
 -> [MiniProtocolInfo mode])
-> [MiniProtocol mode initiatorCtx responderCtx bytes m a b]
-> [MiniProtocolInfo mode]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap MiniProtocol mode initiatorCtx responderCtx bytes m a b
-> [MiniProtocolInfo mode]
forall (mode :: Mode) initiatorCtx responderCtx bytes (m :: * -> *)
       a b.
MiniProtocol mode initiatorCtx responderCtx bytes m a b
-> [MiniProtocolInfo mode]
mkMiniProtocolInfo ([MiniProtocol mode initiatorCtx responderCtx bytes m a b]
 -> [MiniProtocolInfo mode])
-> (OuroborosApplication mode initiatorCtx responderCtx bytes m a b
    -> [MiniProtocol mode initiatorCtx responderCtx bytes m a b])
-> OuroborosApplication mode initiatorCtx responderCtx bytes m a b
-> [MiniProtocolInfo mode]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OuroborosApplication mode initiatorCtx responderCtx bytes m a b
-> [MiniProtocol mode initiatorCtx responderCtx bytes m a b]
forall (mode :: Mode) initiatorCtx responderCtx bytes (m :: * -> *)
       a b.
OuroborosApplication mode initiatorCtx responderCtx bytes m a b
-> [MiniProtocol mode initiatorCtx responderCtx bytes m a b]
getOuroborosApplication


contramapInitiatorCtx :: (initiatorCtx' -> initiatorCtx)
                      -> OuroborosApplication mode initiatorCtx  responderCtx bytes m a b
                      -> OuroborosApplication mode initiatorCtx' responderCtx bytes m a b
contramapInitiatorCtx :: forall initiatorCtx' initiatorCtx (mode :: Mode) responderCtx bytes
       (m :: * -> *) a b.
(initiatorCtx' -> initiatorCtx)
-> OuroborosApplication mode initiatorCtx responderCtx bytes m a b
-> OuroborosApplication mode initiatorCtx' responderCtx bytes m a b
contramapInitiatorCtx initiatorCtx' -> initiatorCtx
f (OuroborosApplication [MiniProtocol mode initiatorCtx responderCtx bytes m a b]
ptcls) = [MiniProtocol mode initiatorCtx' responderCtx bytes m a b]
-> OuroborosApplication mode initiatorCtx' responderCtx bytes m a b
forall (mode :: Mode) initiatorCtx responderCtx bytes (m :: * -> *)
       a b.
[MiniProtocol mode initiatorCtx responderCtx bytes m a b]
-> OuroborosApplication mode initiatorCtx responderCtx bytes m a b
OuroborosApplication
  [ MiniProtocol mode initiatorCtx responderCtx bytes m a b
ptcl { miniProtocolRun =
             case miniProtocolRun ptcl of
               InitiatorProtocolOnly MiniProtocolCb initiatorCtx bytes m a
initiator ->
                 MiniProtocolCb initiatorCtx' bytes m a
-> RunMiniProtocol
     'InitiatorMode initiatorCtx' responderCtx bytes m a Void
forall initiatorCtx bytes (m :: * -> *) a responderCtx.
MiniProtocolCb initiatorCtx bytes m a
-> RunMiniProtocol
     'InitiatorMode initiatorCtx responderCtx bytes m a Void
InitiatorProtocolOnly ((initiatorCtx' -> initiatorCtx)
-> MiniProtocolCb initiatorCtx bytes m a
-> MiniProtocolCb initiatorCtx' bytes m a
forall ctx ctx' bytes (m :: * -> *) a.
(ctx -> ctx')
-> MiniProtocolCb ctx' bytes m a -> MiniProtocolCb ctx bytes m a
contramapMiniProtocolCbCtx initiatorCtx' -> initiatorCtx
f MiniProtocolCb initiatorCtx bytes m a
initiator)
               ResponderProtocolOnly MiniProtocolCb responderCtx bytes m b
responder ->
                 MiniProtocolCb responderCtx bytes m b
-> RunMiniProtocol
     'ResponderMode initiatorCtx' responderCtx bytes m Void b
forall responderCtx bytes (m :: * -> *) b initiatorCtx.
MiniProtocolCb responderCtx bytes m b
-> RunMiniProtocol
     'ResponderMode initiatorCtx responderCtx bytes m Void b
ResponderProtocolOnly MiniProtocolCb responderCtx bytes m b
responder
               InitiatorAndResponderProtocol MiniProtocolCb initiatorCtx bytes m a
initiator MiniProtocolCb responderCtx bytes m b
responder ->
                 MiniProtocolCb initiatorCtx' bytes m a
-> MiniProtocolCb responderCtx bytes m b
-> RunMiniProtocol
     'InitiatorResponderMode initiatorCtx' responderCtx bytes m a b
forall initiatorCtx bytes (m :: * -> *) a responderCtx b.
MiniProtocolCb initiatorCtx bytes m a
-> MiniProtocolCb responderCtx bytes m b
-> RunMiniProtocol
     'InitiatorResponderMode initiatorCtx responderCtx bytes m a b
InitiatorAndResponderProtocol ((initiatorCtx' -> initiatorCtx)
-> MiniProtocolCb initiatorCtx bytes m a
-> MiniProtocolCb initiatorCtx' bytes m a
forall ctx ctx' bytes (m :: * -> *) a.
(ctx -> ctx')
-> MiniProtocolCb ctx' bytes m a -> MiniProtocolCb ctx bytes m a
contramapMiniProtocolCbCtx initiatorCtx' -> initiatorCtx
f MiniProtocolCb initiatorCtx bytes m a
initiator) MiniProtocolCb responderCtx bytes m b
responder
         }
  | MiniProtocol mode initiatorCtx responderCtx bytes m a b
ptcl <- [MiniProtocol mode initiatorCtx responderCtx bytes m a b]
ptcls
  ]


-- | Make 'MiniProtocolBundle', which is used to create a mux interface with
-- 'newMux'.
--
mkMiniProtocolInfos :: OuroborosBundle mode initiatorCtx responderCtx bytes m a b
                    -> [MiniProtocolInfo mode]
mkMiniProtocolInfos :: forall (mode :: Mode) initiatorCtx responderCtx bytes (m :: * -> *)
       a b.
OuroborosBundle mode initiatorCtx responderCtx bytes m a b
-> [MiniProtocolInfo mode]
mkMiniProtocolInfos = ([MiniProtocol mode initiatorCtx responderCtx bytes m a b]
 -> [MiniProtocolInfo mode])
-> TemperatureBundle
     [MiniProtocol mode initiatorCtx responderCtx bytes m a b]
-> [MiniProtocolInfo mode]
forall m a. Monoid m => (a -> m) -> TemperatureBundle a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((MiniProtocol mode initiatorCtx responderCtx bytes m a b
 -> [MiniProtocolInfo mode])
-> [MiniProtocol mode initiatorCtx responderCtx bytes m a b]
-> [MiniProtocolInfo mode]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap MiniProtocol mode initiatorCtx responderCtx bytes m a b
-> [MiniProtocolInfo mode]
forall (mode :: Mode) initiatorCtx responderCtx bytes (m :: * -> *)
       a b.
MiniProtocol mode initiatorCtx responderCtx bytes m a b
-> [MiniProtocolInfo mode]
mkMiniProtocolInfo)