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

module Ouroboros.Network.Mux
  ( -- * Basic notions
    MuxMode (..)
  , ProtocolTemperature (..)
  , SingProtocolTemperature (..)
  , SomeTokProtocolTemperature (..)
  , WithProtocolTemperature (..)
  , withoutProtocolTemperature
  , WithSomeProtocolTemperature (..)
  , withoutSomeProtocolTemperature
  , TemperatureBundle (..)
  , projectBundle
    -- * Mux mini-protocol callback
  , MiniProtocolCb (.., MuxPeerRaw)
  , runMiniProtocolCb
  , mkMiniProtocolCbFromPeer
  , mkMiniProtocolCbFromPeerPipelined
    -- * Mux mini-protocol callback in MuxMode
  , RunMiniProtocol (..)
  , RunMiniProtocolWithExpandedCtx
  , RunMiniProtocolWithMinimalCtx
    -- * MiniProtocol description
  , MiniProtocol (..)
  , MiniProtocolWithExpandedCtx
  , MiniProtocolWithMinimalCtx
  , MiniProtocolNum (..)
  , MiniProtocolLimits (..)
    -- * MiniProtocol bundle
  , OuroborosBundle
  , OuroborosBundleWithExpandedCtx
    -- * Non-P2P API
  , OuroborosApplication (..)
  , OuroborosApplicationWithMinimalCtx
  , toApplication
  , mkMiniProtocolBundle
  , fromOuroborosBundle
  , contramapInitiatorCtx
    -- * Re-exports
    -- | from "Network.Mux"
  , MuxError (..)
  , MuxErrorType (..)
  , HasInitiator
  , HasResponder
    -- * Deprecated APIs
  , type MuxPeer
  , runMuxPeer
  ) where

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

import Data.ByteString.Lazy qualified as LBS
import Data.Foldable (fold)
import Data.Void (Void)

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

import Network.Mux (HasInitiator, HasResponder, MiniProtocolBundle (..),
           MiniProtocolInfo, MiniProtocolLimits (..), MiniProtocolNum,
           MuxError (..), MuxErrorType (..), MuxMode (..))
import Network.Mux.Channel qualified as Mux
import Network.Mux.Compat qualified as Mux.Compat
import Network.Mux.Types qualified as Mux

import Ouroboros.Network.Channel
import Ouroboros.Network.Context (ExpandedInitiatorContext,
           MinimalInitiatorContext, ResponderContext)
import Ouroboros.Network.Driver
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 :: MuxMode) initiatorCtx responderCtx bytes m a b =
    TemperatureBundle [MiniProtocol mode initiatorCtx responderCtx bytes m a b]

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


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


-- | '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 :: MuxMode) initiatorCtx responderCtx bytes m a b where
     InitiatorProtocolOnly
       :: (MiniProtocolCb initiatorCtx bytes m a)
       -> RunMiniProtocol InitiatorMode initiatorCtx responderCtx bytes m a Void

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

     InitiatorAndResponderProtocol
       :: (MiniProtocolCb initiatorCtx bytes m a)
       -> (MiniProtocolCb responderCtx bytes m b)
       -> RunMiniProtocol 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.
--
data MiniProtocolCb ctx bytes m a where
    MiniProtocolCb
      :: (ctx -> Channel m bytes -> m (a, Maybe bytes))
      -> MiniProtocolCb ctx bytes m a

    MuxPeer
      :: forall (pr :: PeerRole) ps (st :: ps) failure ctx bytes m a.
         ( Show failure
         , forall (st' :: ps). Show (ClientHasAgency st')
         , forall (st' :: ps). Show (ServerHasAgency st')
         , ShowProxy ps
         )
      => (ctx -> ( Tracer m (TraceSendRecv ps)
                 , Codec ps failure m bytes
                 , Peer ps pr st m a
                 ))
      -> MiniProtocolCb ctx bytes m a

    MuxPeerPipelined
      :: forall (pr :: PeerRole) ps (st :: ps) failure ctx bytes m a.
         ( Show failure
         , forall (st' :: ps). Show (ClientHasAgency st')
         , forall (st' :: ps). Show (ServerHasAgency st')
         , ShowProxy ps
         )
      => (ctx -> ( Tracer m (TraceSendRecv ps)
                 , Codec ps failure m bytes
                 , PeerPipelined ps pr st m a
                 ))
      -> MiniProtocolCb ctx bytes m a

type MuxPeer = MiniProtocolCb
{-# DEPRECATED MuxPeer
    [ "Use either `MiniProtocolCb` type instead of `MuxPeer` type, or"
    , "`mkMiniProtocolCbFromPeer` instead the `MuxPeer` constructor."
    ]
#-}
{-# DEPRECATED MuxPeerPipelined "Use mkMiniProtocolCbFromPeer instead" #-}

pattern MuxPeerRaw :: forall ctx bytes m a.
                      (ctx -> Channel m bytes -> m (a, Maybe bytes))
                   -> MiniProtocolCb ctx bytes m a
pattern $mMuxPeerRaw :: forall {r} {ctx} {bytes} {m :: * -> *} {a}.
MiniProtocolCb ctx bytes m a
-> ((ctx -> Channel m bytes -> m (a, Maybe bytes)) -> r)
-> ((# #) -> r)
-> r
$bMuxPeerRaw :: forall ctx bytes (m :: * -> *) a.
(ctx -> Channel m bytes -> m (a, Maybe bytes))
-> MiniProtocolCb ctx bytes m a
MuxPeerRaw { forall ctx bytes (m :: * -> *) a.
MiniProtocolCb ctx bytes m a
-> ctx -> Channel m bytes -> m (a, Maybe bytes)
runMuxPeer } = MiniProtocolCb runMuxPeer
{-# DEPRECATED MuxPeerRaw "Use MiniProtocolCb instead" #-}
{-# DEPRECATED runMuxPeer
    [ "Use runMiniProtocolCb instead"
    , "Note that with runMiniProtocolCb there's no need to use Ouroboros.Network.Channel.fromChannel"
    ]
#-}


-- | Create a 'MuxPeer' from a tracer, codec and 'Peer'.
--
mkMiniProtocolCbFromPeer
  :: forall (pr :: PeerRole) ps (st :: ps) failure bytes ctx m a.
     ( MonadThrow m
     , Show failure
     , forall (st' :: ps). Show (ClientHasAgency st')
     , forall (st' :: ps). Show (ServerHasAgency st')
     , ShowProxy ps
     )
  => (ctx -> ( Tracer m (TraceSendRecv ps)
             , Codec ps failure m bytes
             , Peer ps pr st m a
             )
     )
  -> MiniProtocolCb ctx bytes m a
mkMiniProtocolCbFromPeer :: forall (pr :: PeerRole) ps (st :: ps) failure bytes ctx
       (m :: * -> *) a.
(MonadThrow m, Show failure,
 forall (st' :: ps). Show (ClientHasAgency st'),
 forall (st' :: ps). Show (ServerHasAgency st'), ShowProxy ps) =>
(ctx
 -> (Tracer m (TraceSendRecv ps), Codec ps failure m bytes,
     Peer ps pr st m a))
-> MiniProtocolCb ctx bytes m a
mkMiniProtocolCbFromPeer ctx
-> (Tracer m (TraceSendRecv ps), Codec ps failure m bytes,
    Peer ps pr st m a)
fn =
    (ctx -> Channel m bytes -> m (a, Maybe bytes))
-> MiniProtocolCb ctx bytes m a
forall ctx (m :: * -> *) bytes 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 st m a)
fn ctx
ctx of
        (Tracer m (TraceSendRecv ps)
tracer, Codec ps failure m bytes
codec, Peer ps pr st m a
peer) ->
          Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Channel m bytes
-> Peer ps pr st m a
-> m (a, Maybe bytes)
forall ps (st :: ps) (pr :: PeerRole) failure bytes (m :: * -> *)
       a.
(MonadThrow m, Show failure,
 forall (st' :: ps). Show (ClientHasAgency st'),
 forall (st' :: ps). Show (ServerHasAgency st'), ShowProxy ps) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Channel m bytes
-> Peer ps pr st m a
-> m (a, Maybe bytes)
runPeer Tracer m (TraceSendRecv ps)
tracer Codec ps failure m bytes
codec Channel m bytes
channel Peer ps pr st 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
     , Show failure
     , forall (st' :: ps). Show (ClientHasAgency st')
     , forall (st' :: ps). Show (ServerHasAgency st')
     , ShowProxy ps
     )
  => (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, Show failure,
 forall (st' :: ps). Show (ClientHasAgency st'),
 forall (st' :: ps). Show (ServerHasAgency st'), ShowProxy ps) =>
(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 (m :: * -> *) bytes 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, Show failure,
 forall (st' :: ps). Show (ClientHasAgency st'),
 forall (st' :: ps). Show (ServerHasAgency st'), ShowProxy ps) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Channel m bytes
-> PeerPipelined ps pr st m a
-> m (a, Maybe bytes)
runPipelinedPeer Tracer m (TraceSendRecv ps)
tracer Codec ps failure m bytes
codec Channel m bytes
channel PeerPipelined ps pr st m a
peer


-- | Run a 'MuxPeer' using supplied 'ctx' and 'Mux.Channel'
--
runMiniProtocolCb :: ( MonadAsync m
                     , MonadThrow m
                     )
                  => MiniProtocolCb ctx LBS.ByteString m a
                  -> ctx
                  -> Mux.Channel m
                  -> m (a, Maybe LBS.ByteString)
runMiniProtocolCb :: forall (m :: * -> *) ctx a.
(MonadAsync m, MonadThrow m) =>
MiniProtocolCb ctx ByteString m a
-> ctx -> Channel m -> m (a, Maybe ByteString)
runMiniProtocolCb (MiniProtocolCb ctx -> Channel m ByteString -> m (a, Maybe ByteString)
run)  !ctx
ctx = ctx -> Channel m ByteString -> m (a, Maybe ByteString)
run ctx
ctx (Channel m ByteString -> m (a, Maybe ByteString))
-> (Channel m -> Channel m ByteString)
-> Channel m
-> m (a, Maybe ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Channel m -> Channel m ByteString
forall (m :: * -> *). Channel m -> Channel m ByteString
fromChannel
runMiniProtocolCb (MuxPeer ctx
-> (Tracer m (TraceSendRecv ps), Codec ps failure m ByteString,
    Peer ps pr st m a)
fn)          !ctx
ctx = MiniProtocolCb ctx ByteString m a
-> ctx -> Channel m -> m (a, Maybe ByteString)
forall (m :: * -> *) ctx a.
(MonadAsync m, MonadThrow m) =>
MiniProtocolCb ctx ByteString m a
-> ctx -> Channel m -> m (a, Maybe ByteString)
runMiniProtocolCb ((ctx
 -> (Tracer m (TraceSendRecv ps), Codec ps failure m ByteString,
     Peer ps pr st m a))
-> MiniProtocolCb ctx ByteString m a
forall (pr :: PeerRole) ps (st :: ps) failure bytes ctx
       (m :: * -> *) a.
(MonadThrow m, Show failure,
 forall (st' :: ps). Show (ClientHasAgency st'),
 forall (st' :: ps). Show (ServerHasAgency st'), ShowProxy ps) =>
(ctx
 -> (Tracer m (TraceSendRecv ps), Codec ps failure m bytes,
     Peer ps pr st m a))
-> MiniProtocolCb ctx bytes m a
mkMiniProtocolCbFromPeer ctx
-> (Tracer m (TraceSendRecv ps), Codec ps failure m ByteString,
    Peer ps pr st m a)
fn) ctx
ctx
runMiniProtocolCb (MuxPeerPipelined ctx
-> (Tracer m (TraceSendRecv ps), Codec ps failure m ByteString,
    PeerPipelined ps pr st m a)
fn) !ctx
ctx = MiniProtocolCb ctx ByteString m a
-> ctx -> Channel m -> m (a, Maybe ByteString)
forall (m :: * -> *) ctx a.
(MonadAsync m, MonadThrow m) =>
MiniProtocolCb ctx ByteString m a
-> ctx -> Channel m -> m (a, Maybe ByteString)
runMiniProtocolCb ((ctx
 -> (Tracer m (TraceSendRecv ps), Codec ps failure m ByteString,
     PeerPipelined ps pr st m a))
-> MiniProtocolCb ctx ByteString m a
forall (pr :: PeerRole) ps (st :: ps) failure ctx bytes
       (m :: * -> *) a.
(MonadAsync m, MonadThrow m, Show failure,
 forall (st' :: ps). Show (ClientHasAgency st'),
 forall (st' :: ps). Show (ServerHasAgency st'), ShowProxy ps) =>
(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 ByteString,
    PeerPipelined ps pr st m a)
fn) ctx
ctx

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 (m :: * -> *) bytes 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)
contramapMiniProtocolCbCtx ctx -> ctx'
f (MuxPeer ctx'
-> (Tracer m (TraceSendRecv ps), Codec ps failure m bytes,
    Peer ps pr st m a)
cb)          = (ctx
 -> (Tracer m (TraceSendRecv ps), Codec ps failure m bytes,
     Peer ps pr st m a))
-> MiniProtocolCb ctx bytes m a
forall (pr :: PeerRole) ps (st :: ps) failure ctx bytes
       (m :: * -> *) a.
(Show failure, forall (st' :: ps). Show (ClientHasAgency st'),
 forall (st' :: ps). Show (ServerHasAgency st'), ShowProxy ps) =>
(ctx
 -> (Tracer m (TraceSendRecv ps), Codec ps failure m bytes,
     Peer ps pr st m a))
-> MiniProtocolCb ctx bytes m a
MuxPeer (ctx'
-> (Tracer m (TraceSendRecv ps), Codec ps failure m bytes,
    Peer ps pr st m a)
cb (ctx'
 -> (Tracer m (TraceSendRecv ps), Codec ps failure m bytes,
     Peer ps pr st m a))
-> (ctx -> ctx')
-> ctx
-> (Tracer m (TraceSendRecv ps), Codec ps failure m bytes,
    Peer ps pr st m a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ctx -> ctx'
f)
contramapMiniProtocolCbCtx ctx -> ctx'
f (MuxPeerPipelined ctx'
-> (Tracer m (TraceSendRecv ps), Codec ps failure m bytes,
    PeerPipelined ps pr st m a)
cb) = (ctx
 -> (Tracer m (TraceSendRecv ps), Codec ps failure m bytes,
     PeerPipelined ps pr st m a))
-> MiniProtocolCb ctx bytes m a
forall (pr :: PeerRole) ps (st :: ps) failure ctx bytes
       (m :: * -> *) a.
(Show failure, forall (st' :: ps). Show (ClientHasAgency st'),
 forall (st' :: ps). Show (ServerHasAgency st'), ShowProxy ps) =>
(ctx
 -> (Tracer m (TraceSendRecv ps), Codec ps failure m bytes,
     PeerPipelined ps pr st m a))
-> MiniProtocolCb ctx bytes m a
MuxPeerPipelined (ctx'
-> (Tracer m (TraceSendRecv ps), Codec ps failure m bytes,
    PeerPipelined ps pr st m a)
cb (ctx'
 -> (Tracer m (TraceSendRecv ps), Codec ps failure m bytes,
     PeerPipelined ps pr st m a))
-> (ctx -> ctx')
-> ctx
-> (Tracer m (TraceSendRecv ps), Codec ps failure m bytes,
    PeerPipelined ps pr st m a)
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 :: MuxMode) initiatorCtx responderCtx bytes m a b =
        OuroborosApplication [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 :: MuxMode) 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 :: MuxMode) 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


contramapInitiatorCtx :: (initiatorCtx' -> initiatorCtx)
                      -> OuroborosApplication mode initiatorCtx  responderCtx bytes m a b
                      -> OuroborosApplication mode initiatorCtx' responderCtx bytes m a b
contramapInitiatorCtx :: forall initiatorCtx' initiatorCtx (mode :: MuxMode) 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 :: MuxMode) 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
  ]


-- | Create non p2p mux application.
--
-- Note that callbacks will always receive `IsNotBigLedgerPeer`.
toApplication :: forall mode initiatorCtx responderCtx m a b.
                 (MonadAsync m, MonadThrow m)
              => initiatorCtx
              -> responderCtx
              -> OuroborosApplication mode initiatorCtx responderCtx LBS.ByteString m a b
              -> Mux.Compat.MuxApplication mode m a b
toApplication :: forall (mode :: MuxMode) initiatorCtx responderCtx (m :: * -> *) a
       b.
(MonadAsync m, MonadThrow m) =>
initiatorCtx
-> responderCtx
-> OuroborosApplication
     mode initiatorCtx responderCtx ByteString m a b
-> MuxApplication mode m a b
toApplication initiatorCtx
initiatorContext responderCtx
responderContext (OuroborosApplication [MiniProtocol mode initiatorCtx responderCtx ByteString m a b]
ptcls) =
    [MuxMiniProtocol mode m a b] -> MuxApplication mode m a b
forall (mode :: MuxMode) (m :: * -> *) a b.
[MuxMiniProtocol mode m a b] -> MuxApplication mode m a b
Mux.Compat.MuxApplication
      [ Mux.Compat.MuxMiniProtocol {
          miniProtocolNum :: MiniProtocolNum
Mux.Compat.miniProtocolNum    = MiniProtocol mode initiatorCtx responderCtx ByteString m a b
-> MiniProtocolNum
forall (mode :: MuxMode) initiatorCtx responderCtx bytes
       (m :: * -> *) a b.
MiniProtocol mode initiatorCtx responderCtx bytes m a b
-> MiniProtocolNum
miniProtocolNum MiniProtocol mode initiatorCtx responderCtx ByteString m a b
ptcl,
          miniProtocolLimits :: MiniProtocolLimits
Mux.Compat.miniProtocolLimits = MiniProtocol mode initiatorCtx responderCtx ByteString m a b
-> MiniProtocolLimits
forall (mode :: MuxMode) initiatorCtx responderCtx bytes
       (m :: * -> *) a b.
MiniProtocol mode initiatorCtx responderCtx bytes m a b
-> MiniProtocolLimits
miniProtocolLimits MiniProtocol mode initiatorCtx responderCtx ByteString m a b
ptcl,
          miniProtocolRun :: RunMiniProtocol mode m a b
Mux.Compat.miniProtocolRun    = RunMiniProtocol mode initiatorCtx responderCtx ByteString m a b
-> RunMiniProtocol mode m a b
toMuxRunMiniProtocol (MiniProtocol mode initiatorCtx responderCtx ByteString m a b
-> RunMiniProtocol mode initiatorCtx responderCtx ByteString m a b
forall (mode :: MuxMode) initiatorCtx responderCtx bytes
       (m :: * -> *) a b.
MiniProtocol mode initiatorCtx responderCtx bytes m a b
-> RunMiniProtocol mode initiatorCtx responderCtx bytes m a b
miniProtocolRun MiniProtocol mode initiatorCtx responderCtx ByteString m a b
ptcl)
        }
      | MiniProtocol mode initiatorCtx responderCtx ByteString m a b
ptcl <- [MiniProtocol mode initiatorCtx responderCtx ByteString m a b]
ptcls ]
  where
    toMuxRunMiniProtocol :: RunMiniProtocol mode initiatorCtx responderCtx LBS.ByteString m a b
                         -> Mux.Compat.RunMiniProtocol mode m a b
    toMuxRunMiniProtocol :: RunMiniProtocol mode initiatorCtx responderCtx ByteString m a b
-> RunMiniProtocol mode m a b
toMuxRunMiniProtocol (InitiatorProtocolOnly MiniProtocolCb initiatorCtx ByteString m a
i) =
      (Channel m -> m (a, Maybe ByteString))
-> RunMiniProtocol 'InitiatorMode m a Void
forall (m :: * -> *) a.
(Channel m -> m (a, Maybe ByteString))
-> RunMiniProtocol 'InitiatorMode m a Void
Mux.Compat.InitiatorProtocolOnly
        (MiniProtocolCb initiatorCtx ByteString m a
-> initiatorCtx -> Channel m -> m (a, Maybe ByteString)
forall (m :: * -> *) ctx a.
(MonadAsync m, MonadThrow m) =>
MiniProtocolCb ctx ByteString m a
-> ctx -> Channel m -> m (a, Maybe ByteString)
runMiniProtocolCb MiniProtocolCb initiatorCtx ByteString m a
i initiatorCtx
initiatorContext)
    toMuxRunMiniProtocol (ResponderProtocolOnly MiniProtocolCb responderCtx ByteString m b
r) =
      (Channel m -> m (b, Maybe ByteString))
-> RunMiniProtocol 'ResponderMode m Void b
forall (m :: * -> *) b.
(Channel m -> m (b, Maybe ByteString))
-> RunMiniProtocol 'ResponderMode m Void b
Mux.Compat.ResponderProtocolOnly
        (MiniProtocolCb responderCtx ByteString m b
-> responderCtx -> Channel m -> m (b, Maybe ByteString)
forall (m :: * -> *) ctx a.
(MonadAsync m, MonadThrow m) =>
MiniProtocolCb ctx ByteString m a
-> ctx -> Channel m -> m (a, Maybe ByteString)
runMiniProtocolCb MiniProtocolCb responderCtx ByteString m b
r responderCtx
responderContext)
    toMuxRunMiniProtocol (InitiatorAndResponderProtocol MiniProtocolCb initiatorCtx ByteString m a
i MiniProtocolCb responderCtx ByteString m b
r) =
      (Channel m -> m (a, Maybe ByteString))
-> (Channel m -> m (b, Maybe ByteString))
-> RunMiniProtocol 'InitiatorResponderMode m a b
forall (m :: * -> *) a b.
(Channel m -> m (a, Maybe ByteString))
-> (Channel m -> m (b, Maybe ByteString))
-> RunMiniProtocol 'InitiatorResponderMode m a b
Mux.Compat.InitiatorAndResponderProtocol
        (MiniProtocolCb initiatorCtx ByteString m a
-> initiatorCtx -> Channel m -> m (a, Maybe ByteString)
forall (m :: * -> *) ctx a.
(MonadAsync m, MonadThrow m) =>
MiniProtocolCb ctx ByteString m a
-> ctx -> Channel m -> m (a, Maybe ByteString)
runMiniProtocolCb MiniProtocolCb initiatorCtx ByteString m a
i initiatorCtx
initiatorContext)
        (MiniProtocolCb responderCtx ByteString m b
-> responderCtx -> Channel m -> m (b, Maybe ByteString)
forall (m :: * -> *) ctx a.
(MonadAsync m, MonadThrow m) =>
MiniProtocolCb ctx ByteString m a
-> ctx -> Channel m -> m (a, Maybe ByteString)
runMiniProtocolCb MiniProtocolCb responderCtx ByteString m b
r responderCtx
responderContext)


-- | Make 'MiniProtocolBundle', which is used to create a mux interface with
-- 'newMux'.
--
mkMiniProtocolBundle :: OuroborosBundle mode initiatorCtx responderCtx bytes m a b
                     -> MiniProtocolBundle mode
mkMiniProtocolBundle :: forall (mode :: MuxMode) initiatorCtx responderCtx bytes
       (m :: * -> *) a b.
OuroborosBundle mode initiatorCtx responderCtx bytes m a b
-> MiniProtocolBundle mode
mkMiniProtocolBundle = [MiniProtocolInfo mode] -> MiniProtocolBundle mode
forall (mode :: MuxMode).
[MiniProtocolInfo mode] -> MiniProtocolBundle mode
MiniProtocolBundle ([MiniProtocolInfo mode] -> MiniProtocolBundle mode)
-> (OuroborosBundle mode initiatorCtx responderCtx bytes m a b
    -> [MiniProtocolInfo mode])
-> OuroborosBundle mode initiatorCtx responderCtx bytes m a b
-> MiniProtocolBundle mode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([MiniProtocol mode initiatorCtx responderCtx bytes m a b]
 -> [MiniProtocolInfo mode])
-> OuroborosBundle 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]
forall (mode :: MuxMode) initiatorCtx responderCtx bytes
       (m :: * -> *) a b.
[MiniProtocol mode initiatorCtx responderCtx bytes m a b]
-> [MiniProtocolInfo mode]
fn
  where
    fn :: [MiniProtocol mode initiatorCtx responderCtx bytes m a b] -> [MiniProtocolInfo mode]
    fn :: forall (mode :: MuxMode) initiatorCtx responderCtx bytes
       (m :: * -> *) a b.
[MiniProtocol mode initiatorCtx responderCtx bytes m a b]
-> [MiniProtocolInfo mode]
fn [MiniProtocol mode initiatorCtx responderCtx bytes m a b]
ptcls = [ Mux.MiniProtocolInfo
                   { MiniProtocolNum
miniProtocolNum :: MiniProtocolNum
miniProtocolNum :: MiniProtocolNum
Mux.miniProtocolNum
                   , miniProtocolDir :: MiniProtocolDirection mode
Mux.miniProtocolDir = MiniProtocolDirection mode
dir
                   , MiniProtocolLimits
miniProtocolLimits :: MiniProtocolLimits
miniProtocolLimits :: MiniProtocolLimits
Mux.miniProtocolLimits
                   }
               | MiniProtocol { MiniProtocolNum
miniProtocolNum :: forall (mode :: MuxMode) initiatorCtx responderCtx bytes
       (m :: * -> *) a b.
MiniProtocol mode initiatorCtx responderCtx bytes m a b
-> MiniProtocolNum
miniProtocolNum :: MiniProtocolNum
miniProtocolNum
                              , MiniProtocolLimits
miniProtocolLimits :: forall (mode :: MuxMode) 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 :: MuxMode) 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
                              }
                   <- [MiniProtocol mode initiatorCtx responderCtx bytes m a b]
ptcls
               , 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 ]
               ]