{-# LANGUAGE BlockArguments      #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE KindSignatures      #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections       #-}
{-# LANGUAGE TypeApplications    #-}
{-# LANGUAGE TypeOperators       #-}

-- 'startProtocols' is using 'HasInitiator' constraint to limit pattern
-- matches.
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
module Ouroboros.Network.PeerSelection.PeerStateActions
  ( -- * Introduction
    -- $doc
    -- * Create PeerStateActions
    PeerStateActionsArguments (..)
  , PeerConnectionHandle
  , getPromotedHotTime
  , withPeerStateActions
  , pchPeerSharing
    -- * Exceptions
  , PeerSelectionActionException (..)
  , EstablishConnectionException (..)
  , PeerSelectionTimeoutException (..)
  , MonitorPeerConnectionBlocked (..)
    -- * Trace
  , PeerSelectionActionsTrace (..)
  , PeerStatusChangeType (..)
  , FailureType (..)
  ) where

import Control.Applicative (Alternative)
import Control.Concurrent.Class.MonadSTM.Strict
import Control.Exception (SomeAsyncException (..), assert)
import Control.Monad (join, when, (<=<))
import Control.Monad.Class.MonadAsync
import Control.Monad.Class.MonadFork
import Control.Monad.Class.MonadThrow
import Control.Monad.Class.MonadTime.SI
import Control.Monad.Class.MonadTimer.SI

import Control.Concurrent.JobPool (Job (..), JobPool)
import Control.Concurrent.JobPool qualified as JobPool
import Control.Tracer (Tracer, traceWith)

import Data.ByteString.Lazy (ByteString)
import Data.Functor (void, ($>))
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Maybe (isNothing)
import Data.Typeable (Typeable, cast)

import Network.Mux qualified as Mux

import Ouroboros.Network.Context
import Ouroboros.Network.ControlMessage (ControlMessage (..))
import Ouroboros.Network.DiffusionMode
import Ouroboros.Network.ExitPolicy
import Ouroboros.Network.Mux
import Ouroboros.Network.PeerSelection.Governor.Types (PeerStateActions (..))
import Ouroboros.Network.Protocol.Handshake (HandshakeException)
import Ouroboros.Network.RethrowPolicy

import Ouroboros.Network.ConnectionHandler (Handle (..), HandlerError (..),
           MuxConnectionManager)
import Ouroboros.Network.ConnectionManager.Types
import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing)
import Ouroboros.Network.PeerSelection.Types (PeerStatus (..))

-- $doc
--
-- This module implements 'withPeerStateActions', giving the user access to the
-- 'PeerStateActions' API, which provides the following capabilities:
--
--   [synchronous promotions / demotions]:
--        * 'establishPeerConnection'
--        * 'activatePeerConnection'
--        * 'deactivatePeerConnection'
--        * 'closePeerConnection'
--
--   [monitoring]: 'monitorPeerConnection' - returns the state of the connection.
--
--   [asynchronous demotions]: happens when a mini-protocol terminates or errors.
--
-- = Synchronous promotions / demotions
--
-- Synchronous promotions / demotions are used by
-- 'Ouroboros.Network.PeerSelection.Governor.peerSelectionGovernor'.
--
-- [synchronous /cold → warm/ transition]:
--    This transition starts with creating or reusing an inbound connection, do
--    handshake (functionality provided by connection manager), start
--    established and warm mini-protocols, start monitoring thread specified
--    below.
--
-- [synchronous /warm → hot/ transition]:
--    This transition quiesces warm protocols and starts hot protocols.  There
--    is no timeout to quiesce warm mini-protocols.  The tip-sample protocol
--    which is the only planned warm protocol has some states that have
--    a longer timeout when the remote peer has agency, but it does not
--    transfer much data.
--
-- [synchronous /hot → warm/ transition]:
--    Within a timeout, stop hot protocols and let the warm protocols continue
--    running.  If the timeout expires the connection is closed.  Note that this
--    will impact inbound side of a duplex connection.  We cannot do any
--    better: closing is a cooperative action since we require to arrive at
--    a well defined state of the multiplexer (no outstanding data in ingress
--    queue).  This transition must use last to finish synchronisation of all
--    hot mini-protocols.
--
-- [synchronous /warm → cold/ transition]:
--    Shutdown established and warm protocols.  As in the previous transition
--    it must use last to finish synchronisation on established and warm
--    protocol termination, if this synchronisation timeouts the connection is
--    closed.
--
-- = Monitoring Loop
--
-- The monitoring loop is responsible for taking an action when one of the
-- mini-protocols either terminates or errors.  When a mini-protocol terminates
--
--    * if (mini-protocol was hot): trigger a synchronous /hot → warm/ transition.
--    * otherwise: close the connection.
--
-- The monitoring loop is supposed to stop when the multiplexer stops.
--
-- Note that the monitoring loop must act as soon as one of the mini-protocols
-- terminates or errors, hence the use of first to finish synchronisation.
--
-- The multiplexer guarantees that whenever one of the mini-protocols errors the
-- connection is closed.  This simplifies the actions needed to be taken by the
-- monitoring loop.
--
--
-- = Asynchronous demotions
--
-- [asynchronous /* → cold/ transition]:
-- This demotion is triggered whenever any of the mini-protocol errors.  This
-- does not require a further action by the monitoring loop: mux will close the
-- connection, monitoring loop will terminate.
--
-- [asynchronous /hot → warm/ demotion ]:
-- This demotion is triggered if a hot mini-protocol terminates cleanly.  In
-- this case we trigger synchronous /hot → warm/ demotion which will halt all
-- hot mini-protocols and will notify the peer-to-peer governor about the
-- change.
--
-- = Implementation details
--
-- 'PeerStateActions' are build on top of 'ConnectionManager' which provides
-- a primitive to present us a negotiated connection (i.e. after running
-- the handshake) and the multiplexer api which allows to start mini-protocols
-- and track their termination via an 'STM' interface.  Each connection has an
-- associated 'PeerConnectionHandle' which holds all the data associated with
-- a connection.
--
-- Most important are @pchMux :: Mux mode m@ which allows us
-- to interact with the multiplexer and 'pchAppHandles'.  The latter contains
-- information about each mini-protocol and its 'STM' mini-protocol monitoring
-- action.  'ahMiniProtocolResults' allows us to build last-to-finish
-- 'awaitAllResults' and first-to-finish 'awaitFirstResult' synchronisations that
-- we need in synchronous transitions and monitoring loop respectively.
--
-- 'ahControlVar' is a per-temperature 'TVar' which holds 'ControlMessage'.  It
-- is passed from 'ConnectionHandler' via 'Handle'.  This variable allows
-- us to terminate, quiesce or re-enable mini-protocols.
--
--
-- Below is a schematic illustration of function calls / threads and shared
-- state variables.  Reads done just make assertions are not included.  The
-- diagram does not include 'establishPeerConnection'.
--
-- > Legend: ─  - functions
-- >         │░ - threads
-- >         ━  - STM mutable variables
-- >
-- >         ├──▶┃ - write to a TVar
-- >         │◀──┨ - read from a TVar
-- >         ├──▶│ - function call
-- >
-- >         PeerStateVar        - 'pchPeerStatus' 'TVar'
-- >         MiniProtocolResults - 'ahMiniProtocolResults' 'TVar'
-- >         ControlVar          - 'ahControlVar' 'TVar'
-- >
-- >
-- >
-- >
-- >                     ┌──────────────────────────────────────────┐
-- >                     │ ┌────────┐                               │
-- >                     │ │        │                               │
-- >    ┌────────────────┴─┴─┐      │                               │
-- >   ┌────────────────────┐│      ▼                               ▼
-- >  ┌────────────────────┐││   ┌──────────────────────────┐     ┌─────────────────────┐
-- >  │░░░░░░░░░░░░░░░░░░░░│││   │                          │     │                     │
-- >  │░peerMonitoringLoop░││┘   │ deactivatePeerConnection │     │ closePeerConnection │
-- >  │░░░░░░░░░░░░░░░░░░░░│┘    │                          │     │                     │
-- >  └┬───────────────────┘     └┬────────────────────┬────┘     └───────┬─────────────┘
-- >   │     ▲                    │   ▲                │              ▲ ▲ │
-- >   │ ┌───┼────────────────────┘   │                │              │ │ │
-- >   │ │ ┌─┼────────────────────────┼────────────────┼──────────────┘ │ │
-- >   │ │ │ │                        │     ┌──────────┼────────────────┘ │
-- >   │ │ │ │                        │     │          │ ┌────────────────┘
-- > ▒▒│▒│▒│▒│▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒│▒▒▒▒▒│▒▒▒▒▒▒▒▒▒▒│▒│▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒
-- > ▒ │ │ │ └───────────────┐        │     │          │ │                       ▒▒▒
-- > ▒ ▼ ▼ ▼                 │        │     │          ▼ ▼                       ▒ ▒▒▒
-- > ▒┏━━━━━━━━━━━━━━┓      ┏┷━━━━━━━━┷━━━━━┷┓     ┏━━━━━━━━━━━━━━━━┓            ▒ ▒ ▒
-- > ▒┃              ┃┓     ┃                ┃┓    ┃                ┃┓           ▒ ▒ ▒
-- > ▒┃ PeerStateVar ┃┃┓    ┃  MiniProtocol  ┃┃┓   ┃  ControlVar    ┃┃┓          ▒ ▒ ▒
-- > ▒┃              ┃┃┃    ┃     Results    ┃┃┃   ┃  - established ┃┃┃          ▒ ▒ ▒
-- > ▒┃              ┃┃┃    ┃  - established ┃┃┃   ┃  - warm        ┃┃┃          ▒ ▒ ▒
-- > ▒┗━━━━━━━━━━━━━━┛┃┃    ┃  - warm        ┃┃┃   ┃  - hot         ┃┃┃          ▒ ▒ ▒
-- > ▒ ┗━━━━━━━━━━━━━━┛┃    ┃  - hot         ┃┃┃   ┃                ┃┃┃          ▒ ▒ ▒
-- > ▒  ┗━━━━━━━━━━━━━━┛    ┃                ┃┃┃   ┃                ┃┃┃          ▒ ▒ ▒
-- > ▒  ▲                   ┗━━━━━━━━━━━━━━━━┛┃┃   ┗━━━━━━━━━━━━━━━━┛┃┃          ▒ ▒ ▒
-- > ▒  │                    ┗━━━━━━━━━━━━━━━━┛┃    ┗━━━━━━━━━━━━━━━━┛┃          ▒ ▒ ▒
-- > ▒  │                     ┗━━━━━━━━━━━━━━━━┛     ┗━━━━━━━━━━━━━━━━┛          ▒ ▒ ▒
-- > ▒  │                                             ▲                          ▒ ▒ ▒
-- > ▒  │                   PeerConnectionHandles     │                          ▒ ▒ ▒
-- > ▒▒▒│▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒│▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒ ▒ ▒
-- >  ▒ │                                             │                            ▒ ▒
-- >  ▒▒│▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒│▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒ ▒
-- >   ▒│                                             │                              ▒
-- >   ▒│▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒│▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒
-- >    │                   ┌─────────────────────────┘
-- >  ┌─┴───────────────────┴──┐
-- >  │                        │
-- >  │ activatePeerConnection │
-- >  │                        │
-- >  └────────────────────────┘
--
-- Notes:
--
-- All three upper boxes: 'peerMonitoringLoop', 'deactivatePeerConnection' and
-- 'closePeerConnection' are reading 'ahMiniProtocolResults' via the
-- last-to-finish 'awaitAllResults' synchronisation.
--
-- All of the thin boxes are writing to 'pchPeerStatus' variable; which is read
-- by 'monitorPeerConnection.  Also all of them writing to 'ahControlVar':
-- 'peerMonitoringLoop' does that through a call to 'deactivePeerConnection' or
-- 'closePeerConnection'.

-- | `Mux` gives us access to @'Either' 'SomeException' a@ but in this module
-- we also want to explicitly state that a mini-protocol is not running.  This
-- helps us explicitly track if hot protocols are running or not.  Note that
-- established and warm protocol are always running as far as mux is concerned
-- when the peer is not cold (though they might be quiesced).
--
data HasReturned a
    -- | A mini-protocol has returned value of type @a@.
  = Returned !a

    -- | A mini-protocol thrown some exception
  | Errored  !SomeException

   -- | A mini-protocol is not running.  This makes tracking state of hot
   -- protocols explicit, as they will not be running if a peer is in warm
   -- state.
   --
   -- The argument is the return type of previous run.  We preserve it to not
   -- miss updating the reactivate delay.
  | NotRunning !(Either SomeException a)

    -- | A mini-protocol has never been started yet.
  | NotStarted

hasReturnedFromEither :: Either SomeException a -> HasReturned a
hasReturnedFromEither :: forall a. Either SomeException a -> HasReturned a
hasReturnedFromEither (Left SomeException
e)  = SomeException -> HasReturned a
forall a. SomeException -> HasReturned a
Errored SomeException
e
hasReturnedFromEither (Right a
a) = a -> HasReturned a
forall a. a -> HasReturned a
Returned a
a


data MiniProtocolException = MiniProtocolException {
    MiniProtocolException -> MiniProtocolNum
mpeMiniProtocolNumber    :: !MiniProtocolNum,
    MiniProtocolException -> SomeException
mpeMiniProtocolException :: !SomeException
  }
  deriving Int -> MiniProtocolException -> ShowS
[MiniProtocolException] -> ShowS
MiniProtocolException -> String
(Int -> MiniProtocolException -> ShowS)
-> (MiniProtocolException -> String)
-> ([MiniProtocolException] -> ShowS)
-> Show MiniProtocolException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MiniProtocolException -> ShowS
showsPrec :: Int -> MiniProtocolException -> ShowS
$cshow :: MiniProtocolException -> String
show :: MiniProtocolException -> String
$cshowList :: [MiniProtocolException] -> ShowS
showList :: [MiniProtocolException] -> ShowS
Show

newtype MiniProtocolExceptions = MiniProtocolExceptions [MiniProtocolException]
  deriving Int -> MiniProtocolExceptions -> ShowS
[MiniProtocolExceptions] -> ShowS
MiniProtocolExceptions -> String
(Int -> MiniProtocolExceptions -> ShowS)
-> (MiniProtocolExceptions -> String)
-> ([MiniProtocolExceptions] -> ShowS)
-> Show MiniProtocolExceptions
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MiniProtocolExceptions -> ShowS
showsPrec :: Int -> MiniProtocolExceptions -> ShowS
$cshow :: MiniProtocolExceptions -> String
show :: MiniProtocolExceptions -> String
$cshowList :: [MiniProtocolExceptions] -> ShowS
showList :: [MiniProtocolExceptions] -> ShowS
Show

instance Exception MiniProtocolExceptions


-- | Application Handle which allows to stop or start mux threads.  This only
-- contains information which depends on peer temperature.
--
-- TODO: only for hot applications we need 'ahApplication', we never restart
-- / stop the other ones!
data ApplicationHandle muxMode responderCtx peerAddr extraFlags bytes m a b = ApplicationHandle {
    -- | List of applications for the given peer temperature.
    --
    forall (muxMode :: Mode) responderCtx peerAddr extraFlags bytes
       (m :: * -> *) a b.
ApplicationHandle
  muxMode responderCtx peerAddr extraFlags bytes m a b
-> [MiniProtocol
      muxMode
      (ExpandedInitiatorContext peerAddr extraFlags m)
      responderCtx
      bytes
      m
      a
      b]
ahApplication         :: [MiniProtocol muxMode (ExpandedInitiatorContext peerAddr extraFlags m)
                                                   responderCtx bytes m a b],

    -- | 'ControlMessage' 'TVar' for the given peer temperature.
    --
    forall (muxMode :: Mode) responderCtx peerAddr extraFlags bytes
       (m :: * -> *) a b.
ApplicationHandle
  muxMode responderCtx peerAddr extraFlags bytes m a b
-> StrictTVar m ControlMessage
ahControlVar          :: StrictTVar m ControlMessage,

    -- | 'TVar' which allows to track each mini-protocol of a given
    -- temperature.
    --
    forall (muxMode :: Mode) responderCtx peerAddr extraFlags bytes
       (m :: * -> *) a b.
ApplicationHandle
  muxMode responderCtx peerAddr extraFlags bytes m a b
-> StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))
ahMiniProtocolResults :: StrictTVar m (Map MiniProtocolNum
                                            (STM m (HasReturned a)))
  }


--
-- Useful accessors
--

getControlVar :: SingProtocolTemperature pt
              -> TemperatureBundle (ApplicationHandle muxMode responderCtx peerAddr extraFlags bytes m a b)
              -> StrictTVar m ControlMessage
getControlVar :: forall (pt :: ProtocolTemperature) (muxMode :: Mode) responderCtx
       peerAddr extraFlags bytes (m :: * -> *) a b.
SingProtocolTemperature pt
-> TemperatureBundle
     (ApplicationHandle
        muxMode responderCtx peerAddr extraFlags bytes m a b)
-> StrictTVar m ControlMessage
getControlVar SingProtocolTemperature pt
tok = ApplicationHandle
  muxMode responderCtx peerAddr extraFlags bytes m a b
-> StrictTVar m ControlMessage
forall (muxMode :: Mode) responderCtx peerAddr extraFlags bytes
       (m :: * -> *) a b.
ApplicationHandle
  muxMode responderCtx peerAddr extraFlags bytes m a b
-> StrictTVar m ControlMessage
ahControlVar (ApplicationHandle
   muxMode responderCtx peerAddr extraFlags bytes m a b
 -> StrictTVar m ControlMessage)
-> (TemperatureBundle
      (ApplicationHandle
         muxMode responderCtx peerAddr extraFlags bytes m a b)
    -> ApplicationHandle
         muxMode responderCtx peerAddr extraFlags bytes m a b)
-> TemperatureBundle
     (ApplicationHandle
        muxMode responderCtx peerAddr extraFlags bytes m a b)
-> StrictTVar m ControlMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SingProtocolTemperature pt
-> TemperatureBundle
     (ApplicationHandle
        muxMode responderCtx peerAddr extraFlags bytes m a b)
-> ApplicationHandle
     muxMode responderCtx peerAddr extraFlags bytes m a b
forall (pt :: ProtocolTemperature) a.
SingProtocolTemperature pt -> TemperatureBundle a -> a
projectBundle SingProtocolTemperature pt
tok

getProtocols :: SingProtocolTemperature pt
             -> TemperatureBundle (ApplicationHandle muxMode responderCtx peerAddr extraFlags bytes m a b)
             -> [MiniProtocol muxMode (ExpandedInitiatorContext peerAddr extraFlags m) responderCtx bytes m a b]
getProtocols :: forall (pt :: ProtocolTemperature) (muxMode :: Mode) responderCtx
       peerAddr extraFlags bytes (m :: * -> *) a b.
SingProtocolTemperature pt
-> TemperatureBundle
     (ApplicationHandle
        muxMode responderCtx peerAddr extraFlags bytes m a b)
-> [MiniProtocol
      muxMode
      (ExpandedInitiatorContext peerAddr extraFlags m)
      responderCtx
      bytes
      m
      a
      b]
getProtocols SingProtocolTemperature pt
tok TemperatureBundle
  (ApplicationHandle
     muxMode responderCtx peerAddr extraFlags bytes m a b)
bundle = ApplicationHandle
  muxMode responderCtx peerAddr extraFlags bytes m a b
-> [MiniProtocol
      muxMode
      (ExpandedInitiatorContext peerAddr extraFlags m)
      responderCtx
      bytes
      m
      a
      b]
forall (muxMode :: Mode) responderCtx peerAddr extraFlags bytes
       (m :: * -> *) a b.
ApplicationHandle
  muxMode responderCtx peerAddr extraFlags bytes m a b
-> [MiniProtocol
      muxMode
      (ExpandedInitiatorContext peerAddr extraFlags m)
      responderCtx
      bytes
      m
      a
      b]
ahApplication (SingProtocolTemperature pt
-> TemperatureBundle
     (ApplicationHandle
        muxMode responderCtx peerAddr extraFlags bytes m a b)
-> ApplicationHandle
     muxMode responderCtx peerAddr extraFlags bytes m a b
forall (pt :: ProtocolTemperature) a.
SingProtocolTemperature pt -> TemperatureBundle a -> a
projectBundle SingProtocolTemperature pt
tok TemperatureBundle
  (ApplicationHandle
     muxMode responderCtx peerAddr extraFlags bytes m a b)
bundle)

getMiniProtocolsVar :: SingProtocolTemperature pt
                    -> TemperatureBundle (ApplicationHandle muxMode responderCtx peerAddr extraFlags bytes m a b)
                    -> StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))
getMiniProtocolsVar :: forall (pt :: ProtocolTemperature) (muxMode :: Mode) responderCtx
       peerAddr extraFlags bytes (m :: * -> *) a b.
SingProtocolTemperature pt
-> TemperatureBundle
     (ApplicationHandle
        muxMode responderCtx peerAddr extraFlags bytes m a b)
-> StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))
getMiniProtocolsVar SingProtocolTemperature pt
tok = ApplicationHandle
  muxMode responderCtx peerAddr extraFlags bytes m a b
-> StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))
forall (muxMode :: Mode) responderCtx peerAddr extraFlags bytes
       (m :: * -> *) a b.
ApplicationHandle
  muxMode responderCtx peerAddr extraFlags bytes m a b
-> StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))
ahMiniProtocolResults (ApplicationHandle
   muxMode responderCtx peerAddr extraFlags bytes m a b
 -> StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a))))
-> (TemperatureBundle
      (ApplicationHandle
         muxMode responderCtx peerAddr extraFlags bytes m a b)
    -> ApplicationHandle
         muxMode responderCtx peerAddr extraFlags bytes m a b)
-> TemperatureBundle
     (ApplicationHandle
        muxMode responderCtx peerAddr extraFlags bytes m a b)
-> StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SingProtocolTemperature pt
-> TemperatureBundle
     (ApplicationHandle
        muxMode responderCtx peerAddr extraFlags bytes m a b)
-> ApplicationHandle
     muxMode responderCtx peerAddr extraFlags bytes m a b
forall (pt :: ProtocolTemperature) a.
SingProtocolTemperature pt -> TemperatureBundle a -> a
projectBundle SingProtocolTemperature pt
tok


--
-- Synchronisation primitives
--

-- | A result of a mini-protocol used by first-to-finish synchronisation
-- 'awaitFirstResult'.   For first-to-finish synchronisation we would like to
-- know which mini-protocol returned or errored.  This is useful for logging.
--
data FirstToFinishResult
    -- | A mini-protocol failed with an exception.
    = MiniProtocolError   !MiniProtocolException

    -- | A mini-protocols terminated successfully.
    --
    -- TODO: we should record the return value of a protocol: it is meaningful
    -- (for tracing).  But it requires more plumbing to be done: consensus
    -- applications, as we see them, return `()`!
    | MiniProtocolSuccess !MiniProtocolNum
  deriving Int -> FirstToFinishResult -> ShowS
[FirstToFinishResult] -> ShowS
FirstToFinishResult -> String
(Int -> FirstToFinishResult -> ShowS)
-> (FirstToFinishResult -> String)
-> ([FirstToFinishResult] -> ShowS)
-> Show FirstToFinishResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FirstToFinishResult -> ShowS
showsPrec :: Int -> FirstToFinishResult -> ShowS
$cshow :: FirstToFinishResult -> String
show :: FirstToFinishResult -> String
$cshowList :: [FirstToFinishResult] -> ShowS
showList :: [FirstToFinishResult] -> ShowS
Show

instance Semigroup FirstToFinishResult where
    err :: FirstToFinishResult
err@MiniProtocolError{} <> :: FirstToFinishResult -> FirstToFinishResult -> FirstToFinishResult
<> FirstToFinishResult
_                       = FirstToFinishResult
err
    FirstToFinishResult
_ <> err :: FirstToFinishResult
err@MiniProtocolError{}                       = FirstToFinishResult
err
    res :: FirstToFinishResult
res@MiniProtocolSuccess{} <> MiniProtocolSuccess{} = FirstToFinishResult
res

-- | Await first result from any of any of the protocols which belongs to
-- the indicated bundle.
--
awaitFirstResult :: MonadSTM m
                 => SingProtocolTemperature pt
                 -> TemperatureBundle (ApplicationHandle muxMode responderCtx peerAddr extraFlags bytes m a b)
                 -> STM m FirstToFinishResult
awaitFirstResult :: forall (m :: * -> *) (pt :: ProtocolTemperature) (muxMode :: Mode)
       responderCtx peerAddr extraFlags bytes a b.
MonadSTM m =>
SingProtocolTemperature pt
-> TemperatureBundle
     (ApplicationHandle
        muxMode responderCtx peerAddr extraFlags bytes m a b)
-> STM m FirstToFinishResult
awaitFirstResult SingProtocolTemperature pt
tok TemperatureBundle
  (ApplicationHandle
     muxMode responderCtx peerAddr extraFlags bytes m a b)
bundle = do
    d <- StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))
-> STM m (Map MiniProtocolNum (STM m (HasReturned a)))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (SingProtocolTemperature pt
-> TemperatureBundle
     (ApplicationHandle
        muxMode responderCtx peerAddr extraFlags bytes m a b)
-> StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))
forall (pt :: ProtocolTemperature) (muxMode :: Mode) responderCtx
       peerAddr extraFlags bytes (m :: * -> *) a b.
SingProtocolTemperature pt
-> TemperatureBundle
     (ApplicationHandle
        muxMode responderCtx peerAddr extraFlags bytes m a b)
-> StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))
getMiniProtocolsVar SingProtocolTemperature pt
tok TemperatureBundle
  (ApplicationHandle
     muxMode responderCtx peerAddr extraFlags bytes m a b)
bundle)
    (miniProtocolNum, result)
      <- Map.foldrWithKey (\MiniProtocolNum
num STM m (HasReturned a)
stm STM m (MiniProtocolNum, HasReturned a)
acc -> ((MiniProtocolNum
num,) (HasReturned a -> (MiniProtocolNum, HasReturned a))
-> STM m (HasReturned a) -> STM m (MiniProtocolNum, HasReturned a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM m (HasReturned a)
stm) STM m (MiniProtocolNum, HasReturned a)
-> STM m (MiniProtocolNum, HasReturned a)
-> STM m (MiniProtocolNum, HasReturned a)
forall a. STM m a -> STM m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => STM m a -> STM m a -> STM m a
`orElse` STM m (MiniProtocolNum, HasReturned a)
acc)
                          retry d
    case result of
      Errored  SomeException
e -> FirstToFinishResult -> STM m FirstToFinishResult
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FirstToFinishResult -> STM m FirstToFinishResult)
-> FirstToFinishResult -> STM m FirstToFinishResult
forall a b. (a -> b) -> a -> b
$ MiniProtocolException -> FirstToFinishResult
MiniProtocolError   (MiniProtocolNum -> SomeException -> MiniProtocolException
MiniProtocolException MiniProtocolNum
miniProtocolNum SomeException
e)
      Returned a
_ -> FirstToFinishResult -> STM m FirstToFinishResult
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FirstToFinishResult -> STM m FirstToFinishResult)
-> FirstToFinishResult -> STM m FirstToFinishResult
forall a b. (a -> b) -> a -> b
$ MiniProtocolNum -> FirstToFinishResult
MiniProtocolSuccess MiniProtocolNum
miniProtocolNum
      -- We block if a mini-protocol is not running.  For established or warm
      -- mini-protocols this can only happen when we establish the connection.
      -- For hot mini-protocols this will be the case when the peer is warm:
      -- we are interested when the first established or warm mini-protocol
      -- returned.
      NotRunning Either SomeException a
_ -> STM m FirstToFinishResult
forall a. STM m a
forall (m :: * -> *) a. MonadSTM m => STM m a
retry
      HasReturned a
NotStarted   -> STM m FirstToFinishResult
forall a. STM m a
forall (m :: * -> *) a. MonadSTM m => STM m a
retry


-- | Data structure used in last-to-finish synchronisation for all
-- mini-protocols of a given temperature (see 'awaitAllResults').
--
data LastToFinishResult a =
    -- | All mini protocols returned successfully.
    -- The map will contain results of all mini-protocols (of a given
    -- temperature).
    --
    AllSucceeded !(Map MiniProtocolNum a)

    -- | Some mini-protocols (of a given temperature) errored.
    --
  | SomeErrored  ![MiniProtocolException]

instance Semigroup (LastToFinishResult a) where
    AllSucceeded Map MiniProtocolNum a
a  <> :: LastToFinishResult a
-> LastToFinishResult a -> LastToFinishResult a
<> AllSucceeded Map MiniProtocolNum a
b  = Map MiniProtocolNum a -> LastToFinishResult a
forall a. Map MiniProtocolNum a -> LastToFinishResult a
AllSucceeded (Map MiniProtocolNum a
a Map MiniProtocolNum a
-> Map MiniProtocolNum a -> Map MiniProtocolNum a
forall a. Semigroup a => a -> a -> a
<> Map MiniProtocolNum a
b)
    e :: LastToFinishResult a
e@SomeErrored{} <> AllSucceeded{}  = LastToFinishResult a
e
    AllSucceeded{}  <> e :: LastToFinishResult a
e@SomeErrored{} = LastToFinishResult a
e
    SomeErrored [MiniProtocolException]
e   <> SomeErrored [MiniProtocolException]
e'  = [MiniProtocolException] -> LastToFinishResult a
forall a. [MiniProtocolException] -> LastToFinishResult a
SomeErrored ([MiniProtocolException]
e [MiniProtocolException]
-> [MiniProtocolException] -> [MiniProtocolException]
forall a. [a] -> [a] -> [a]
++ [MiniProtocolException]
e')

instance Monoid (LastToFinishResult a) where
    mempty :: LastToFinishResult a
mempty = Map MiniProtocolNum a -> LastToFinishResult a
forall a. Map MiniProtocolNum a -> LastToFinishResult a
AllSucceeded Map MiniProtocolNum a
forall a. Monoid a => a
mempty


-- | Last to finish synchronisation for mini-protocols of a given protocol
-- temperature.
--
awaitAllResults :: MonadSTM m
                => SingProtocolTemperature pt
                -> TemperatureBundle (ApplicationHandle muxMude responderCtx peerAddr extraFlags bytes m a b)
                -> STM m (LastToFinishResult a)
awaitAllResults :: forall (m :: * -> *) (pt :: ProtocolTemperature) (muxMude :: Mode)
       responderCtx peerAddr extraFlags bytes a b.
MonadSTM m =>
SingProtocolTemperature pt
-> TemperatureBundle
     (ApplicationHandle
        muxMude responderCtx peerAddr extraFlags bytes m a b)
-> STM m (LastToFinishResult a)
awaitAllResults SingProtocolTemperature pt
tok TemperatureBundle
  (ApplicationHandle
     muxMude responderCtx peerAddr extraFlags bytes m a b)
bundle = do
    results <-  StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))
-> STM m (Map MiniProtocolNum (STM m (HasReturned a)))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (SingProtocolTemperature pt
-> TemperatureBundle
     (ApplicationHandle
        muxMude responderCtx peerAddr extraFlags bytes m a b)
-> StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))
forall (pt :: ProtocolTemperature) (muxMode :: Mode) responderCtx
       peerAddr extraFlags bytes (m :: * -> *) a b.
SingProtocolTemperature pt
-> TemperatureBundle
     (ApplicationHandle
        muxMode responderCtx peerAddr extraFlags bytes m a b)
-> StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))
getMiniProtocolsVar SingProtocolTemperature pt
tok TemperatureBundle
  (ApplicationHandle
     muxMude responderCtx peerAddr extraFlags bytes m a b)
bundle)
            STM m (Map MiniProtocolNum (STM m (HasReturned a)))
-> (Map MiniProtocolNum (STM m (HasReturned a))
    -> STM m (Map MiniProtocolNum (HasReturned a)))
-> STM m (Map MiniProtocolNum (HasReturned a))
forall a b. STM m a -> (a -> STM m b) -> STM m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Map MiniProtocolNum (STM m (HasReturned a))
-> STM m (Map MiniProtocolNum (HasReturned a))
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a.
Monad m =>
Map MiniProtocolNum (m a) -> m (Map MiniProtocolNum a)
sequence
    return $ Map.foldMapWithKey
               (\MiniProtocolNum
num HasReturned a
r -> case HasReturned a
r of
                          Errored  SomeException
e           -> [MiniProtocolException] -> LastToFinishResult a
forall a. [MiniProtocolException] -> LastToFinishResult a
SomeErrored [MiniProtocolNum -> SomeException -> MiniProtocolException
MiniProtocolException MiniProtocolNum
num SomeException
e]
                          Returned a
a           -> Map MiniProtocolNum a -> LastToFinishResult a
forall a. Map MiniProtocolNum a -> LastToFinishResult a
AllSucceeded (MiniProtocolNum -> a -> Map MiniProtocolNum a
forall k a. k -> a -> Map k a
Map.singleton MiniProtocolNum
num a
a)
                          NotRunning (Right a
a) -> Map MiniProtocolNum a -> LastToFinishResult a
forall a. Map MiniProtocolNum a -> LastToFinishResult a
AllSucceeded (MiniProtocolNum -> a -> Map MiniProtocolNum a
forall k a. k -> a -> Map k a
Map.singleton MiniProtocolNum
num a
a)
                          NotRunning (Left SomeException
e)  -> [MiniProtocolException] -> LastToFinishResult a
forall a. [MiniProtocolException] -> LastToFinishResult a
SomeErrored [MiniProtocolNum -> SomeException -> MiniProtocolException
MiniProtocolException MiniProtocolNum
num SomeException
e]
                          HasReturned a
NotStarted           -> Map MiniProtocolNum a -> LastToFinishResult a
forall a. Map MiniProtocolNum a -> LastToFinishResult a
AllSucceeded Map MiniProtocolNum a
forall a. Monoid a => a
mempty)
               results


--
-- Internals: peer state & connection handle
--

-- |  Each established connection has access to 'PeerConnectionHandle'.  It
-- allows to promote / demote or close the connection, by having access to
-- 'Mux', three bundles of miniprotocols: for hot, warm and established peers
-- together with their state 'StrictTVar's.
--
data PeerConnectionHandle (muxMode :: Mux.Mode) responderCtx peerAddr extraFlags versionData bytes m a b = PeerConnectionHandle {
    forall (muxMode :: Mode) responderCtx peerAddr extraFlags
       versionData bytes (m :: * -> *) a b.
PeerConnectionHandle
  muxMode responderCtx peerAddr extraFlags versionData bytes m a b
-> ConnectionId peerAddr
pchConnectionId    :: !(ConnectionId peerAddr),
    forall (muxMode :: Mode) responderCtx peerAddr extraFlags
       versionData bytes (m :: * -> *) a b.
PeerConnectionHandle
  muxMode responderCtx peerAddr extraFlags versionData bytes m a b
-> StrictTVar m PeerStatus
pchPeerStatus      :: !(StrictTVar m PeerStatus),
    forall (muxMode :: Mode) responderCtx peerAddr extraFlags
       versionData bytes (m :: * -> *) a b.
PeerConnectionHandle
  muxMode responderCtx peerAddr extraFlags versionData bytes m a b
-> Mux muxMode m
pchMux             :: !(Mux.Mux muxMode m),
    forall (muxMode :: Mode) responderCtx peerAddr extraFlags
       versionData bytes (m :: * -> *) a b.
PeerConnectionHandle
  muxMode responderCtx peerAddr extraFlags versionData bytes m a b
-> TemperatureBundle
     (ApplicationHandle
        muxMode responderCtx peerAddr extraFlags bytes m a b)
pchAppHandles      :: !(TemperatureBundle (ApplicationHandle muxMode responderCtx peerAddr extraFlags bytes m a b)),
    forall (muxMode :: Mode) responderCtx peerAddr extraFlags
       versionData bytes (m :: * -> *) a b.
PeerConnectionHandle
  muxMode responderCtx peerAddr extraFlags versionData bytes m a b
-> versionData
pchVersionData     :: !versionData,
    forall (muxMode :: Mode) responderCtx peerAddr extraFlags
       versionData bytes (m :: * -> *) a b.
PeerConnectionHandle
  muxMode responderCtx peerAddr extraFlags versionData bytes m a b
-> StrictTVar m (Maybe Time)
pchPromotedHotVar  :: !(StrictTVar m (Maybe Time))
  }

-- | Retrieve the time the remote peer has been promoted to hot state
-- or Nothing if either the peer was not promoted or is being currently demoted
--
getPromotedHotTime :: (MonadSTM m)
                   => PeerConnectionHandle muxMode responderCtx peerAddr extraFlags versionData bytes m a b
                   -> STM m (Maybe Time)
getPromotedHotTime :: forall (m :: * -> *) (muxMode :: Mode) responderCtx peerAddr
       extraFlags versionData bytes a b.
MonadSTM m =>
PeerConnectionHandle
  muxMode responderCtx peerAddr extraFlags versionData bytes m a b
-> STM m (Maybe Time)
getPromotedHotTime PeerConnectionHandle { StrictTVar m (Maybe Time)
pchPromotedHotVar :: forall (muxMode :: Mode) responderCtx peerAddr extraFlags
       versionData bytes (m :: * -> *) a b.
PeerConnectionHandle
  muxMode responderCtx peerAddr extraFlags versionData bytes m a b
-> StrictTVar m (Maybe Time)
pchPromotedHotVar :: StrictTVar m (Maybe Time)
pchPromotedHotVar } =
  StrictTVar m (Maybe Time) -> STM m (Maybe Time)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (Maybe Time)
pchPromotedHotVar

mkInitiatorContext :: MonadSTM m
                   => SingProtocolTemperature pt
                   -> IsBigLedgerPeer
                   -> extraFlags
                   -> PeerConnectionHandle muxMode responderCtx peerAddr extraFlags versionDat bytes m a b
                   -> ExpandedInitiatorContext peerAddr extraFlags m
mkInitiatorContext :: forall (m :: * -> *) (pt :: ProtocolTemperature) extraFlags
       (muxMode :: Mode) responderCtx peerAddr versionDat bytes a b.
MonadSTM m =>
SingProtocolTemperature pt
-> IsBigLedgerPeer
-> extraFlags
-> PeerConnectionHandle
     muxMode responderCtx peerAddr extraFlags versionDat bytes m a b
-> ExpandedInitiatorContext peerAddr extraFlags m
mkInitiatorContext SingProtocolTemperature pt
tok IsBigLedgerPeer
isBigLedgerPeer extraFlags
extraFlags
                   PeerConnectionHandle {
                       pchConnectionId :: forall (muxMode :: Mode) responderCtx peerAddr extraFlags
       versionData bytes (m :: * -> *) a b.
PeerConnectionHandle
  muxMode responderCtx peerAddr extraFlags versionData bytes m a b
-> ConnectionId peerAddr
pchConnectionId = ConnectionId peerAddr
connectionId,
                       pchAppHandles :: forall (muxMode :: Mode) responderCtx peerAddr extraFlags
       versionData bytes (m :: * -> *) a b.
PeerConnectionHandle
  muxMode responderCtx peerAddr extraFlags versionData bytes m a b
-> TemperatureBundle
     (ApplicationHandle
        muxMode responderCtx peerAddr extraFlags bytes m a b)
pchAppHandles   = TemperatureBundle
  (ApplicationHandle
     muxMode responderCtx peerAddr extraFlags bytes m a b)
appHandles
                    }
                   =
                   ExpandedInitiatorContext {
                       eicConnectionId :: ConnectionId peerAddr
eicConnectionId    = ConnectionId peerAddr
connectionId,
                       eicControlMessage :: ControlMessageSTM m
eicControlMessage  = StrictTVar m ControlMessage -> ControlMessageSTM m
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (SingProtocolTemperature pt
-> TemperatureBundle
     (ApplicationHandle
        muxMode responderCtx peerAddr extraFlags bytes m a b)
-> StrictTVar m ControlMessage
forall (pt :: ProtocolTemperature) (muxMode :: Mode) responderCtx
       peerAddr extraFlags bytes (m :: * -> *) a b.
SingProtocolTemperature pt
-> TemperatureBundle
     (ApplicationHandle
        muxMode responderCtx peerAddr extraFlags bytes m a b)
-> StrictTVar m ControlMessage
getControlVar SingProtocolTemperature pt
tok TemperatureBundle
  (ApplicationHandle
     muxMode responderCtx peerAddr extraFlags bytes m a b)
appHandles),
                       eicIsBigLedgerPeer :: IsBigLedgerPeer
eicIsBigLedgerPeer = IsBigLedgerPeer
isBigLedgerPeer,
                       eicExtraFlags :: extraFlags
eicExtraFlags      = extraFlags
extraFlags
                     }


instance (Show peerAddr, Show versionData)
      => Show (PeerConnectionHandle muxMode responderCtx peerAddr extraFlags versionData bytes m a b) where
    show :: PeerConnectionHandle
  muxMode responderCtx peerAddr extraFlags versionData bytes m a b
-> String
show PeerConnectionHandle { ConnectionId peerAddr
pchConnectionId :: forall (muxMode :: Mode) responderCtx peerAddr extraFlags
       versionData bytes (m :: * -> *) a b.
PeerConnectionHandle
  muxMode responderCtx peerAddr extraFlags versionData bytes m a b
-> ConnectionId peerAddr
pchConnectionId :: ConnectionId peerAddr
pchConnectionId, versionData
pchVersionData :: forall (muxMode :: Mode) responderCtx peerAddr extraFlags
       versionData bytes (m :: * -> *) a b.
PeerConnectionHandle
  muxMode responderCtx peerAddr extraFlags versionData bytes m a b
-> versionData
pchVersionData :: versionData
pchVersionData } =
      String
"PeerConnectionHandle " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ConnectionId peerAddr -> String
forall a. Show a => a -> String
show ConnectionId peerAddr
pchConnectionId String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ versionData -> String
forall a. Show a => a -> String
show versionData
pchVersionData

pchPeerSharing :: (versionData -> PeerSharing)
               -> PeerConnectionHandle muxMode responderCtx peerAddr extraFlags versionData bytes m a b
               -> PeerSharing
pchPeerSharing :: forall versionData (muxMode :: Mode) responderCtx peerAddr
       extraFlags bytes (m :: * -> *) a b.
(versionData -> PeerSharing)
-> PeerConnectionHandle
     muxMode responderCtx peerAddr extraFlags versionData bytes m a b
-> PeerSharing
pchPeerSharing versionData -> PeerSharing
f = versionData -> PeerSharing
f (versionData -> PeerSharing)
-> (PeerConnectionHandle
      muxMode responderCtx peerAddr extraFlags versionData bytes m a b
    -> versionData)
-> PeerConnectionHandle
     muxMode responderCtx peerAddr extraFlags versionData bytes m a b
-> PeerSharing
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PeerConnectionHandle
  muxMode responderCtx peerAddr extraFlags versionData bytes m a b
-> versionData
forall (muxMode :: Mode) responderCtx peerAddr extraFlags
       versionData bytes (m :: * -> *) a b.
PeerConnectionHandle
  muxMode responderCtx peerAddr extraFlags versionData bytes m a b
-> versionData
pchVersionData

--
-- Exceptions
--

-- | Parent exception of all peer selection action exceptions.
--
data PeerSelectionActionException = forall e. Exception e => PeerSelectionActionException e

instance Show PeerSelectionActionException where
    show :: PeerSelectionActionException -> String
show (PeerSelectionActionException e
e) = e -> String
forall a. Show a => a -> String
show e
e

instance Exception PeerSelectionActionException

peerSelectionActionExceptionToException :: Exception e => e -> SomeException
peerSelectionActionExceptionToException :: forall e. Exception e => e -> SomeException
peerSelectionActionExceptionToException = PeerSelectionActionException -> SomeException
forall e. Exception e => e -> SomeException
toException (PeerSelectionActionException -> SomeException)
-> (e -> PeerSelectionActionException) -> e -> SomeException
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> PeerSelectionActionException
forall e. Exception e => e -> PeerSelectionActionException
PeerSelectionActionException

peerSelectionActionExceptionFromException :: Exception e => SomeException -> Maybe e
peerSelectionActionExceptionFromException :: forall e. Exception e => SomeException -> Maybe e
peerSelectionActionExceptionFromException SomeException
x = do
    PeerSelectionActionException e <- SomeException -> Maybe PeerSelectionActionException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
x
    cast e

-- | Throw an exception when 'monitorPeerConnection' blocks.
--
data MonitorPeerConnectionBlocked = MonitorPeerConnectionBlocked
  deriving Int -> MonitorPeerConnectionBlocked -> ShowS
[MonitorPeerConnectionBlocked] -> ShowS
MonitorPeerConnectionBlocked -> String
(Int -> MonitorPeerConnectionBlocked -> ShowS)
-> (MonitorPeerConnectionBlocked -> String)
-> ([MonitorPeerConnectionBlocked] -> ShowS)
-> Show MonitorPeerConnectionBlocked
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MonitorPeerConnectionBlocked -> ShowS
showsPrec :: Int -> MonitorPeerConnectionBlocked -> ShowS
$cshow :: MonitorPeerConnectionBlocked -> String
show :: MonitorPeerConnectionBlocked -> String
$cshowList :: [MonitorPeerConnectionBlocked] -> ShowS
showList :: [MonitorPeerConnectionBlocked] -> ShowS
Show

instance Exception MonitorPeerConnectionBlocked

data EstablishConnectionException versionNumber
      -- | Handshake client failed
    = ClientException
        !(HandshakeException versionNumber)

      -- | Handshake server failed
    | ServerException
        !(HandshakeException versionNumber)
  deriving Int -> EstablishConnectionException versionNumber -> ShowS
[EstablishConnectionException versionNumber] -> ShowS
EstablishConnectionException versionNumber -> String
(Int -> EstablishConnectionException versionNumber -> ShowS)
-> (EstablishConnectionException versionNumber -> String)
-> ([EstablishConnectionException versionNumber] -> ShowS)
-> Show (EstablishConnectionException versionNumber)
forall versionNumber.
Show versionNumber =>
Int -> EstablishConnectionException versionNumber -> ShowS
forall versionNumber.
Show versionNumber =>
[EstablishConnectionException versionNumber] -> ShowS
forall versionNumber.
Show versionNumber =>
EstablishConnectionException versionNumber -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall versionNumber.
Show versionNumber =>
Int -> EstablishConnectionException versionNumber -> ShowS
showsPrec :: Int -> EstablishConnectionException versionNumber -> ShowS
$cshow :: forall versionNumber.
Show versionNumber =>
EstablishConnectionException versionNumber -> String
show :: EstablishConnectionException versionNumber -> String
$cshowList :: forall versionNumber.
Show versionNumber =>
[EstablishConnectionException versionNumber] -> ShowS
showList :: [EstablishConnectionException versionNumber] -> ShowS
Show

instance ( Show versionNumber
         , Typeable versionNumber
         ) => Exception (EstablishConnectionException versionNumber) where
    toException :: EstablishConnectionException versionNumber -> SomeException
toException   = EstablishConnectionException versionNumber -> SomeException
forall e. Exception e => e -> SomeException
peerSelectionActionExceptionToException
    fromException :: SomeException -> Maybe (EstablishConnectionException versionNumber)
fromException = SomeException -> Maybe (EstablishConnectionException versionNumber)
forall e. Exception e => SomeException -> Maybe e
peerSelectionActionExceptionFromException


data PeerSelectionTimeoutException peerAddr
    = DeactivationTimeout    !(ConnectionId peerAddr)
  deriving Int -> PeerSelectionTimeoutException peerAddr -> ShowS
[PeerSelectionTimeoutException peerAddr] -> ShowS
PeerSelectionTimeoutException peerAddr -> String
(Int -> PeerSelectionTimeoutException peerAddr -> ShowS)
-> (PeerSelectionTimeoutException peerAddr -> String)
-> ([PeerSelectionTimeoutException peerAddr] -> ShowS)
-> Show (PeerSelectionTimeoutException peerAddr)
forall peerAddr.
Show peerAddr =>
Int -> PeerSelectionTimeoutException peerAddr -> ShowS
forall peerAddr.
Show peerAddr =>
[PeerSelectionTimeoutException peerAddr] -> ShowS
forall peerAddr.
Show peerAddr =>
PeerSelectionTimeoutException peerAddr -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall peerAddr.
Show peerAddr =>
Int -> PeerSelectionTimeoutException peerAddr -> ShowS
showsPrec :: Int -> PeerSelectionTimeoutException peerAddr -> ShowS
$cshow :: forall peerAddr.
Show peerAddr =>
PeerSelectionTimeoutException peerAddr -> String
show :: PeerSelectionTimeoutException peerAddr -> String
$cshowList :: forall peerAddr.
Show peerAddr =>
[PeerSelectionTimeoutException peerAddr] -> ShowS
showList :: [PeerSelectionTimeoutException peerAddr] -> ShowS
Show

instance ( Show peerAddr
         , Typeable peerAddr
         ) => Exception (PeerSelectionTimeoutException peerAddr) where
    toException :: PeerSelectionTimeoutException peerAddr -> SomeException
toException   = PeerSelectionTimeoutException peerAddr -> SomeException
forall e. Exception e => e -> SomeException
peerSelectionActionExceptionToException
    fromException :: SomeException -> Maybe (PeerSelectionTimeoutException peerAddr)
fromException = SomeException -> Maybe (PeerSelectionTimeoutException peerAddr)
forall e. Exception e => SomeException -> Maybe e
peerSelectionActionExceptionFromException


data ColdActionException peerAddr
    = ColdActivationException   !(ConnectionId peerAddr)
    | ColdDeactivationException !(ConnectionId peerAddr)
  deriving Int -> ColdActionException peerAddr -> ShowS
[ColdActionException peerAddr] -> ShowS
ColdActionException peerAddr -> String
(Int -> ColdActionException peerAddr -> ShowS)
-> (ColdActionException peerAddr -> String)
-> ([ColdActionException peerAddr] -> ShowS)
-> Show (ColdActionException peerAddr)
forall peerAddr.
Show peerAddr =>
Int -> ColdActionException peerAddr -> ShowS
forall peerAddr.
Show peerAddr =>
[ColdActionException peerAddr] -> ShowS
forall peerAddr.
Show peerAddr =>
ColdActionException peerAddr -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall peerAddr.
Show peerAddr =>
Int -> ColdActionException peerAddr -> ShowS
showsPrec :: Int -> ColdActionException peerAddr -> ShowS
$cshow :: forall peerAddr.
Show peerAddr =>
ColdActionException peerAddr -> String
show :: ColdActionException peerAddr -> String
$cshowList :: forall peerAddr.
Show peerAddr =>
[ColdActionException peerAddr] -> ShowS
showList :: [ColdActionException peerAddr] -> ShowS
Show

instance ( Show peerAddr
         , Typeable peerAddr
         ) => Exception (ColdActionException peerAddr) where
    toException :: ColdActionException peerAddr -> SomeException
toException   = ColdActionException peerAddr -> SomeException
forall e. Exception e => e -> SomeException
peerSelectionActionExceptionToException
    fromException :: SomeException -> Maybe (ColdActionException peerAddr)
fromException = SomeException -> Maybe (ColdActionException peerAddr)
forall e. Exception e => SomeException -> Maybe e
peerSelectionActionExceptionFromException


--
-- 'PeerStateActionsArguments' and 'peerStateActions'
--


-- | Record of arguments of 'peerSelectionActions'.
--
data PeerStateActionsArguments muxMode socket responderCtx peerAddr extraFlags versionData versionNumber m a b =
    PeerStateActionsArguments {

      forall (muxMode :: Mode) socket responderCtx peerAddr extraFlags
       versionData versionNumber (m :: * -> *) a b.
PeerStateActionsArguments
  muxMode
  socket
  responderCtx
  peerAddr
  extraFlags
  versionData
  versionNumber
  m
  a
  b
-> Tracer m (PeerSelectionActionsTrace peerAddr versionNumber)
spsTracer                 :: Tracer m (PeerSelectionActionsTrace peerAddr versionNumber),

      -- | Peer deactivation timeout: timeouts stopping hot protocols.
      --
      forall (muxMode :: Mode) socket responderCtx peerAddr extraFlags
       versionData versionNumber (m :: * -> *) a b.
PeerStateActionsArguments
  muxMode
  socket
  responderCtx
  peerAddr
  extraFlags
  versionData
  versionNumber
  m
  a
  b
-> DiffTime
spsDeactivateTimeout      :: DiffTime,

      -- | Timeout on closing connection: timeouts stopping established and warm
      -- peer protocols.
      --
      forall (muxMode :: Mode) socket responderCtx peerAddr extraFlags
       versionData versionNumber (m :: * -> *) a b.
PeerStateActionsArguments
  muxMode
  socket
  responderCtx
  peerAddr
  extraFlags
  versionData
  versionNumber
  m
  a
  b
-> DiffTime
spsCloseConnectionTimeout :: DiffTime,

      forall (muxMode :: Mode) socket responderCtx peerAddr extraFlags
       versionData versionNumber (m :: * -> *) a b.
PeerStateActionsArguments
  muxMode
  socket
  responderCtx
  peerAddr
  extraFlags
  versionData
  versionNumber
  m
  a
  b
-> MuxConnectionManager
     muxMode
     socket
     (ExpandedInitiatorContext peerAddr extraFlags m)
     responderCtx
     peerAddr
     versionData
     versionNumber
     ByteString
     m
     a
     b
spsConnectionManager      :: MuxConnectionManager muxMode socket
                                                        (ExpandedInitiatorContext peerAddr extraFlags m)
                                                        responderCtx peerAddr
                                                        versionData versionNumber
                                                        ByteString m a b,

      forall (muxMode :: Mode) socket responderCtx peerAddr extraFlags
       versionData versionNumber (m :: * -> *) a b.
PeerStateActionsArguments
  muxMode
  socket
  responderCtx
  peerAddr
  extraFlags
  versionData
  versionNumber
  m
  a
  b
-> ExitPolicy a
spsExitPolicy             :: ExitPolicy a,
      forall (muxMode :: Mode) socket responderCtx peerAddr extraFlags
       versionData versionNumber (m :: * -> *) a b.
PeerStateActionsArguments
  muxMode
  socket
  responderCtx
  peerAddr
  extraFlags
  versionData
  versionNumber
  m
  a
  b
-> RethrowPolicy
spsRethrowPolicy          :: RethrowPolicy,
      forall (muxMode :: Mode) socket responderCtx peerAddr extraFlags
       versionData versionNumber (m :: * -> *) a b.
PeerStateActionsArguments
  muxMode
  socket
  responderCtx
  peerAddr
  extraFlags
  versionData
  versionNumber
  m
  a
  b
-> ThreadId m
spsMainThreadId           :: ThreadId m
    }


withPeerStateActions
    :: forall (muxMode :: Mux.Mode) socket responderCtx peerAddr extraFlags versionData versionNumber m a b x.
       ( Alternative (STM m)
       , MonadAsync         m
       , MonadCatch         m
       , MonadLabelledSTM   m
       , MonadFork          m
       , MonadMask          m
       , MonadTimer         m
       , MonadThrow         (STM m)
       , HasInitiator muxMode ~ True
       , Typeable versionNumber
       , Show     versionNumber
       , Ord      peerAddr
       , Typeable peerAddr
       , Show     peerAddr
       )
    => PeerStateActionsArguments muxMode socket responderCtx peerAddr extraFlags versionData versionNumber m a b
    -> (PeerStateActions
          peerAddr
          extraFlags
          (PeerConnectionHandle muxMode responderCtx peerAddr extraFlags versionData ByteString m a b)
          m
          -> m x)
    -> m x

withPeerStateActions :: forall (muxMode :: Mode) socket responderCtx peerAddr extraFlags
       versionData versionNumber (m :: * -> *) a b x.
(Alternative (STM m), MonadAsync m, MonadCatch m,
 MonadLabelledSTM m, MonadFork m, MonadMask m, MonadTimer m,
 MonadThrow (STM m), HasInitiator muxMode ~ 'True,
 Typeable versionNumber, Show versionNumber, Ord peerAddr,
 Typeable peerAddr, Show peerAddr) =>
PeerStateActionsArguments
  muxMode
  socket
  responderCtx
  peerAddr
  extraFlags
  versionData
  versionNumber
  m
  a
  b
-> (PeerStateActions
      peerAddr
      extraFlags
      (PeerConnectionHandle
         muxMode
         responderCtx
         peerAddr
         extraFlags
         versionData
         ByteString
         m
         a
         b)
      m
    -> m x)
-> m x
withPeerStateActions PeerStateActionsArguments {
                       DiffTime
spsDeactivateTimeout :: forall (muxMode :: Mode) socket responderCtx peerAddr extraFlags
       versionData versionNumber (m :: * -> *) a b.
PeerStateActionsArguments
  muxMode
  socket
  responderCtx
  peerAddr
  extraFlags
  versionData
  versionNumber
  m
  a
  b
-> DiffTime
spsDeactivateTimeout :: DiffTime
spsDeactivateTimeout,
                       DiffTime
spsCloseConnectionTimeout :: forall (muxMode :: Mode) socket responderCtx peerAddr extraFlags
       versionData versionNumber (m :: * -> *) a b.
PeerStateActionsArguments
  muxMode
  socket
  responderCtx
  peerAddr
  extraFlags
  versionData
  versionNumber
  m
  a
  b
-> DiffTime
spsCloseConnectionTimeout :: DiffTime
spsCloseConnectionTimeout,
                       Tracer m (PeerSelectionActionsTrace peerAddr versionNumber)
spsTracer :: forall (muxMode :: Mode) socket responderCtx peerAddr extraFlags
       versionData versionNumber (m :: * -> *) a b.
PeerStateActionsArguments
  muxMode
  socket
  responderCtx
  peerAddr
  extraFlags
  versionData
  versionNumber
  m
  a
  b
-> Tracer m (PeerSelectionActionsTrace peerAddr versionNumber)
spsTracer :: Tracer m (PeerSelectionActionsTrace peerAddr versionNumber)
spsTracer,
                       MuxConnectionManager
  muxMode
  socket
  (ExpandedInitiatorContext peerAddr extraFlags m)
  responderCtx
  peerAddr
  versionData
  versionNumber
  ByteString
  m
  a
  b
spsConnectionManager :: forall (muxMode :: Mode) socket responderCtx peerAddr extraFlags
       versionData versionNumber (m :: * -> *) a b.
PeerStateActionsArguments
  muxMode
  socket
  responderCtx
  peerAddr
  extraFlags
  versionData
  versionNumber
  m
  a
  b
-> MuxConnectionManager
     muxMode
     socket
     (ExpandedInitiatorContext peerAddr extraFlags m)
     responderCtx
     peerAddr
     versionData
     versionNumber
     ByteString
     m
     a
     b
spsConnectionManager :: MuxConnectionManager
  muxMode
  socket
  (ExpandedInitiatorContext peerAddr extraFlags m)
  responderCtx
  peerAddr
  versionData
  versionNumber
  ByteString
  m
  a
  b
spsConnectionManager,
                       ExitPolicy a
spsExitPolicy :: forall (muxMode :: Mode) socket responderCtx peerAddr extraFlags
       versionData versionNumber (m :: * -> *) a b.
PeerStateActionsArguments
  muxMode
  socket
  responderCtx
  peerAddr
  extraFlags
  versionData
  versionNumber
  m
  a
  b
-> ExitPolicy a
spsExitPolicy :: ExitPolicy a
spsExitPolicy,
                       RethrowPolicy
spsRethrowPolicy :: forall (muxMode :: Mode) socket responderCtx peerAddr extraFlags
       versionData versionNumber (m :: * -> *) a b.
PeerStateActionsArguments
  muxMode
  socket
  responderCtx
  peerAddr
  extraFlags
  versionData
  versionNumber
  m
  a
  b
-> RethrowPolicy
spsRethrowPolicy :: RethrowPolicy
spsRethrowPolicy,
                       ThreadId m
spsMainThreadId :: forall (muxMode :: Mode) socket responderCtx peerAddr extraFlags
       versionData versionNumber (m :: * -> *) a b.
PeerStateActionsArguments
  muxMode
  socket
  responderCtx
  peerAddr
  extraFlags
  versionData
  versionNumber
  m
  a
  b
-> ThreadId m
spsMainThreadId :: ThreadId m
spsMainThreadId
                     }
                     PeerStateActions
  peerAddr
  extraFlags
  (PeerConnectionHandle
     muxMode
     responderCtx
     peerAddr
     extraFlags
     versionData
     ByteString
     m
     a
     b)
  m
-> m x
k =
    (JobPool () m (Maybe SomeException) -> m x) -> m x
forall group (m :: * -> *) a b.
(MonadAsync m, MonadThrow m, MonadLabelledSTM m) =>
(JobPool group m a -> m b) -> m b
JobPool.withJobPool ((JobPool () m (Maybe SomeException) -> m x) -> m x)
-> (JobPool () m (Maybe SomeException) -> m x) -> m x
forall a b. (a -> b) -> a -> b
$ \JobPool () m (Maybe SomeException)
jobPool ->
      PeerStateActions
  peerAddr
  extraFlags
  (PeerConnectionHandle
     muxMode
     responderCtx
     peerAddr
     extraFlags
     versionData
     ByteString
     m
     a
     b)
  m
-> m x
k PeerStateActions {
          establishPeerConnection :: IsBigLedgerPeer
-> DiffusionMode
-> Provenance
-> peerAddr
-> extraFlags
-> m (PeerConnectionHandle
        muxMode
        responderCtx
        peerAddr
        extraFlags
        versionData
        ByteString
        m
        a
        b)
establishPeerConnection = JobPool () m (Maybe SomeException)
-> IsBigLedgerPeer
-> DiffusionMode
-> Provenance
-> peerAddr
-> extraFlags
-> m (PeerConnectionHandle
        muxMode
        responderCtx
        peerAddr
        extraFlags
        versionData
        ByteString
        m
        a
        b)
establishPeerConnection JobPool () m (Maybe SomeException)
jobPool,
          PeerConnectionHandle
  muxMode
  responderCtx
  peerAddr
  extraFlags
  versionData
  ByteString
  m
  a
  b
-> STM m (PeerStatus, Maybe RepromoteDelay)
monitorPeerConnection :: PeerConnectionHandle
  muxMode
  responderCtx
  peerAddr
  extraFlags
  versionData
  ByteString
  m
  a
  b
-> STM m (PeerStatus, Maybe RepromoteDelay)
monitorPeerConnection :: PeerConnectionHandle
  muxMode
  responderCtx
  peerAddr
  extraFlags
  versionData
  ByteString
  m
  a
  b
-> STM m (PeerStatus, Maybe RepromoteDelay)
monitorPeerConnection,
          IsBigLedgerPeer
-> extraFlags
-> PeerConnectionHandle
     muxMode
     responderCtx
     peerAddr
     extraFlags
     versionData
     ByteString
     m
     a
     b
-> m ()
activatePeerConnection :: IsBigLedgerPeer
-> extraFlags
-> PeerConnectionHandle
     muxMode
     responderCtx
     peerAddr
     extraFlags
     versionData
     ByteString
     m
     a
     b
-> m ()
activatePeerConnection :: IsBigLedgerPeer
-> extraFlags
-> PeerConnectionHandle
     muxMode
     responderCtx
     peerAddr
     extraFlags
     versionData
     ByteString
     m
     a
     b
-> m ()
activatePeerConnection,
          PeerConnectionHandle
  muxMode
  responderCtx
  peerAddr
  extraFlags
  versionData
  ByteString
  m
  a
  b
-> m ()
deactivatePeerConnection :: PeerConnectionHandle
  muxMode
  responderCtx
  peerAddr
  extraFlags
  versionData
  ByteString
  m
  a
  b
-> m ()
deactivatePeerConnection :: PeerConnectionHandle
  muxMode
  responderCtx
  peerAddr
  extraFlags
  versionData
  ByteString
  m
  a
  b
-> m ()
deactivatePeerConnection,
          closePeerConnection :: PeerConnectionHandle
  muxMode
  responderCtx
  peerAddr
  extraFlags
  versionData
  ByteString
  m
  a
  b
-> m ()
closePeerConnection = m PeerStatus -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m PeerStatus -> m ())
-> (PeerConnectionHandle
      muxMode
      responderCtx
      peerAddr
      extraFlags
      versionData
      ByteString
      m
      a
      b
    -> m PeerStatus)
-> PeerConnectionHandle
     muxMode
     responderCtx
     peerAddr
     extraFlags
     versionData
     ByteString
     m
     a
     b
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PeerConnectionHandle
  muxMode
  responderCtx
  peerAddr
  extraFlags
  versionData
  ByteString
  m
  a
  b
-> m PeerStatus
closePeerConnection,
          errorDelay :: RepromoteDelay
errorDelay = ExitPolicy a -> RepromoteDelay
forall a. ExitPolicy a -> RepromoteDelay
epErrorDelay ExitPolicy a
spsExitPolicy
        }

  where

    -- Update PeerState with the new state only if the current state isn't
    -- cold. Returns True if the state wasn't cold
    updateUnlessCoolingOrCold :: StrictTVar m PeerStatus -> PeerStatus -> STM m Bool
    updateUnlessCoolingOrCold :: StrictTVar m PeerStatus -> PeerStatus -> STM m Bool
updateUnlessCoolingOrCold StrictTVar m PeerStatus
stateVar PeerStatus
newState = do
      status <- StrictTVar m PeerStatus -> STM m PeerStatus
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m PeerStatus
stateVar
      if status <= PeerCooling
         then return False
         else writeTVar stateVar newState >> return True

    tracePeerHotDuration
      :: PeerConnectionHandle muxMode responderCtx peerAddr extraFlags versionData bytes m a b
      -> m ()
    tracePeerHotDuration :: forall bytes.
PeerConnectionHandle
  muxMode responderCtx peerAddr extraFlags versionData bytes m a b
-> m ()
tracePeerHotDuration PeerConnectionHandle { ConnectionId peerAddr
pchConnectionId :: forall (muxMode :: Mode) responderCtx peerAddr extraFlags
       versionData bytes (m :: * -> *) a b.
PeerConnectionHandle
  muxMode responderCtx peerAddr extraFlags versionData bytes m a b
-> ConnectionId peerAddr
pchConnectionId :: ConnectionId peerAddr
pchConnectionId, StrictTVar m (Maybe Time)
pchPromotedHotVar :: forall (muxMode :: Mode) responderCtx peerAddr extraFlags
       versionData bytes (m :: * -> *) a b.
PeerConnectionHandle
  muxMode responderCtx peerAddr extraFlags versionData bytes m a b
-> StrictTVar m (Maybe Time)
pchPromotedHotVar :: StrictTVar m (Maybe Time)
pchPromotedHotVar } = do
      pchPromotedHot <- STM m (Maybe Time) -> m (Maybe Time)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Maybe Time) -> m (Maybe Time))
-> STM m (Maybe Time) -> m (Maybe Time)
forall a b. (a -> b) -> a -> b
$ StrictTVar m (Maybe Time)
-> (Maybe Time -> (Maybe Time, Maybe Time)) -> STM m (Maybe Time)
forall (m :: * -> *) s a.
MonadSTM m =>
StrictTVar m s -> (s -> (a, s)) -> STM m a
stateTVar StrictTVar m (Maybe Time)
pchPromotedHotVar (, Maybe Time
forall a. Maybe a
Nothing)
      case pchPromotedHot of
        Just Time
t1 -> do
          dt <- (Time -> Time -> DiffTime
`diffTime` Time
t1) (Time -> DiffTime) -> m Time -> m DiffTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime
          traceWith spsTracer (PeerHotDuration pchConnectionId dt)
        Maybe Time
Nothing -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    peerMonitoringLoop
      :: PeerConnectionHandle muxMode responderCtx peerAddr extraFlags versionData ByteString m a b
      -> m ()
    peerMonitoringLoop :: PeerConnectionHandle
  muxMode
  responderCtx
  peerAddr
  extraFlags
  versionData
  ByteString
  m
  a
  b
-> m ()
peerMonitoringLoop pch :: PeerConnectionHandle
  muxMode
  responderCtx
  peerAddr
  extraFlags
  versionData
  ByteString
  m
  a
  b
pch@PeerConnectionHandle {
                             ConnectionId peerAddr
pchConnectionId :: forall (muxMode :: Mode) responderCtx peerAddr extraFlags
       versionData bytes (m :: * -> *) a b.
PeerConnectionHandle
  muxMode responderCtx peerAddr extraFlags versionData bytes m a b
-> ConnectionId peerAddr
pchConnectionId :: ConnectionId peerAddr
pchConnectionId,
                             StrictTVar m PeerStatus
pchPeerStatus :: forall (muxMode :: Mode) responderCtx peerAddr extraFlags
       versionData bytes (m :: * -> *) a b.
PeerConnectionHandle
  muxMode responderCtx peerAddr extraFlags versionData bytes m a b
-> StrictTVar m PeerStatus
pchPeerStatus :: StrictTVar m PeerStatus
pchPeerStatus,
                             TemperatureBundle
  (ApplicationHandle
     muxMode responderCtx peerAddr extraFlags ByteString m a b)
pchAppHandles :: forall (muxMode :: Mode) responderCtx peerAddr extraFlags
       versionData bytes (m :: * -> *) a b.
PeerConnectionHandle
  muxMode responderCtx peerAddr extraFlags versionData bytes m a b
-> TemperatureBundle
     (ApplicationHandle
        muxMode responderCtx peerAddr extraFlags bytes m a b)
pchAppHandles :: TemperatureBundle
  (ApplicationHandle
     muxMode responderCtx peerAddr extraFlags ByteString m a b)
pchAppHandles
                           } = do
        -- A first-to-finish synchronisation on all the bundles; As a result
        -- this is a first-to-finish synchronisation between all the
        -- mini-protocols runs toward the given peer.
        r <-
          STM m (Maybe (WithSomeProtocolTemperature FirstToFinishResult))
-> m (Maybe (WithSomeProtocolTemperature FirstToFinishResult))
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Maybe (WithSomeProtocolTemperature FirstToFinishResult))
 -> m (Maybe (WithSomeProtocolTemperature FirstToFinishResult)))
-> STM m (Maybe (WithSomeProtocolTemperature FirstToFinishResult))
-> m (Maybe (WithSomeProtocolTemperature FirstToFinishResult))
forall a b. (a -> b) -> a -> b
$ do
            peerStatus <- StrictTVar m PeerStatus -> STM m PeerStatus
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m PeerStatus
pchPeerStatus
            -- If we already monitored mux and are waiting for the peer connection
            -- to be cleaned then the peer status will be 'PeerCold' and we can't
            -- make progress until it is 'PeerReallyCold'
            case peerStatus of
              PeerStatus
PeerCold ->
                Maybe (WithSomeProtocolTemperature FirstToFinishResult)
-> STM m (Maybe (WithSomeProtocolTemperature FirstToFinishResult))
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (WithSomeProtocolTemperature FirstToFinishResult)
forall a. Maybe a
Nothing
              PeerStatus
PeerCooling -> do
                MuxConnectionManager
  muxMode
  socket
  (ExpandedInitiatorContext peerAddr extraFlags m)
  responderCtx
  peerAddr
  versionData
  versionNumber
  ByteString
  m
  a
  b
-> ConnectionId peerAddr -> STM m ()
forall (muxMode :: Mode) socket peerAddr handle handleError
       (m :: * -> *).
ConnectionManager muxMode socket peerAddr handle handleError m
-> ConnectionId peerAddr -> STM m ()
waitForOutboundDemotion MuxConnectionManager
  muxMode
  socket
  (ExpandedInitiatorContext peerAddr extraFlags m)
  responderCtx
  peerAddr
  versionData
  versionNumber
  ByteString
  m
  a
  b
spsConnectionManager ConnectionId peerAddr
pchConnectionId
                StrictTVar m PeerStatus -> PeerStatus -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m PeerStatus
pchPeerStatus PeerStatus
PeerCold
                Maybe (WithSomeProtocolTemperature FirstToFinishResult)
-> STM m (Maybe (WithSomeProtocolTemperature FirstToFinishResult))
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (WithSomeProtocolTemperature FirstToFinishResult)
forall a. Maybe a
Nothing
              PeerStatus
_ ->
                  (WithSomeProtocolTemperature FirstToFinishResult
-> Maybe (WithSomeProtocolTemperature FirstToFinishResult)
forall a. a -> Maybe a
Just (WithSomeProtocolTemperature FirstToFinishResult
 -> Maybe (WithSomeProtocolTemperature FirstToFinishResult))
-> (FirstToFinishResult
    -> WithSomeProtocolTemperature FirstToFinishResult)
-> FirstToFinishResult
-> Maybe (WithSomeProtocolTemperature FirstToFinishResult)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithProtocolTemperature 'Established FirstToFinishResult
-> WithSomeProtocolTemperature FirstToFinishResult
forall (pt :: ProtocolTemperature) a.
WithProtocolTemperature pt a -> WithSomeProtocolTemperature a
WithSomeProtocolTemperature (WithProtocolTemperature 'Established FirstToFinishResult
 -> WithSomeProtocolTemperature FirstToFinishResult)
-> (FirstToFinishResult
    -> WithProtocolTemperature 'Established FirstToFinishResult)
-> FirstToFinishResult
-> WithSomeProtocolTemperature FirstToFinishResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FirstToFinishResult
-> WithProtocolTemperature 'Established FirstToFinishResult
forall a. a -> WithProtocolTemperature 'Established a
WithEstablished
                    (FirstToFinishResult
 -> Maybe (WithSomeProtocolTemperature FirstToFinishResult))
-> STM m FirstToFinishResult
-> STM m (Maybe (WithSomeProtocolTemperature FirstToFinishResult))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SingProtocolTemperature 'Established
-> TemperatureBundle
     (ApplicationHandle
        muxMode responderCtx peerAddr extraFlags ByteString m a b)
-> STM m FirstToFinishResult
forall (m :: * -> *) (pt :: ProtocolTemperature) (muxMode :: Mode)
       responderCtx peerAddr extraFlags bytes a b.
MonadSTM m =>
SingProtocolTemperature pt
-> TemperatureBundle
     (ApplicationHandle
        muxMode responderCtx peerAddr extraFlags bytes m a b)
-> STM m FirstToFinishResult
awaitFirstResult SingProtocolTemperature 'Established
SingEstablished TemperatureBundle
  (ApplicationHandle
     muxMode responderCtx peerAddr extraFlags ByteString m a b)
pchAppHandles)
                STM m (Maybe (WithSomeProtocolTemperature FirstToFinishResult))
-> STM m (Maybe (WithSomeProtocolTemperature FirstToFinishResult))
-> STM m (Maybe (WithSomeProtocolTemperature FirstToFinishResult))
forall a. STM m a -> STM m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => STM m a -> STM m a -> STM m a
`orElse`
                  (WithSomeProtocolTemperature FirstToFinishResult
-> Maybe (WithSomeProtocolTemperature FirstToFinishResult)
forall a. a -> Maybe a
Just (WithSomeProtocolTemperature FirstToFinishResult
 -> Maybe (WithSomeProtocolTemperature FirstToFinishResult))
-> (FirstToFinishResult
    -> WithSomeProtocolTemperature FirstToFinishResult)
-> FirstToFinishResult
-> Maybe (WithSomeProtocolTemperature FirstToFinishResult)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithProtocolTemperature 'Warm FirstToFinishResult
-> WithSomeProtocolTemperature FirstToFinishResult
forall (pt :: ProtocolTemperature) a.
WithProtocolTemperature pt a -> WithSomeProtocolTemperature a
WithSomeProtocolTemperature (WithProtocolTemperature 'Warm FirstToFinishResult
 -> WithSomeProtocolTemperature FirstToFinishResult)
-> (FirstToFinishResult
    -> WithProtocolTemperature 'Warm FirstToFinishResult)
-> FirstToFinishResult
-> WithSomeProtocolTemperature FirstToFinishResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FirstToFinishResult
-> WithProtocolTemperature 'Warm FirstToFinishResult
forall a. a -> WithProtocolTemperature 'Warm a
WithWarm
                    (FirstToFinishResult
 -> Maybe (WithSomeProtocolTemperature FirstToFinishResult))
-> STM m FirstToFinishResult
-> STM m (Maybe (WithSomeProtocolTemperature FirstToFinishResult))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SingProtocolTemperature 'Warm
-> TemperatureBundle
     (ApplicationHandle
        muxMode responderCtx peerAddr extraFlags ByteString m a b)
-> STM m FirstToFinishResult
forall (m :: * -> *) (pt :: ProtocolTemperature) (muxMode :: Mode)
       responderCtx peerAddr extraFlags bytes a b.
MonadSTM m =>
SingProtocolTemperature pt
-> TemperatureBundle
     (ApplicationHandle
        muxMode responderCtx peerAddr extraFlags bytes m a b)
-> STM m FirstToFinishResult
awaitFirstResult SingProtocolTemperature 'Warm
SingWarm TemperatureBundle
  (ApplicationHandle
     muxMode responderCtx peerAddr extraFlags ByteString m a b)
pchAppHandles)
                STM m (Maybe (WithSomeProtocolTemperature FirstToFinishResult))
-> STM m (Maybe (WithSomeProtocolTemperature FirstToFinishResult))
-> STM m (Maybe (WithSomeProtocolTemperature FirstToFinishResult))
forall a. STM m a -> STM m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => STM m a -> STM m a -> STM m a
`orElse`
                  (WithSomeProtocolTemperature FirstToFinishResult
-> Maybe (WithSomeProtocolTemperature FirstToFinishResult)
forall a. a -> Maybe a
Just (WithSomeProtocolTemperature FirstToFinishResult
 -> Maybe (WithSomeProtocolTemperature FirstToFinishResult))
-> (FirstToFinishResult
    -> WithSomeProtocolTemperature FirstToFinishResult)
-> FirstToFinishResult
-> Maybe (WithSomeProtocolTemperature FirstToFinishResult)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithProtocolTemperature 'Hot FirstToFinishResult
-> WithSomeProtocolTemperature FirstToFinishResult
forall (pt :: ProtocolTemperature) a.
WithProtocolTemperature pt a -> WithSomeProtocolTemperature a
WithSomeProtocolTemperature (WithProtocolTemperature 'Hot FirstToFinishResult
 -> WithSomeProtocolTemperature FirstToFinishResult)
-> (FirstToFinishResult
    -> WithProtocolTemperature 'Hot FirstToFinishResult)
-> FirstToFinishResult
-> WithSomeProtocolTemperature FirstToFinishResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FirstToFinishResult
-> WithProtocolTemperature 'Hot FirstToFinishResult
forall a. a -> WithProtocolTemperature 'Hot a
WithHot
                    (FirstToFinishResult
 -> Maybe (WithSomeProtocolTemperature FirstToFinishResult))
-> STM m FirstToFinishResult
-> STM m (Maybe (WithSomeProtocolTemperature FirstToFinishResult))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SingProtocolTemperature 'Hot
-> TemperatureBundle
     (ApplicationHandle
        muxMode responderCtx peerAddr extraFlags ByteString m a b)
-> STM m FirstToFinishResult
forall (m :: * -> *) (pt :: ProtocolTemperature) (muxMode :: Mode)
       responderCtx peerAddr extraFlags bytes a b.
MonadSTM m =>
SingProtocolTemperature pt
-> TemperatureBundle
     (ApplicationHandle
        muxMode responderCtx peerAddr extraFlags bytes m a b)
-> STM m FirstToFinishResult
awaitFirstResult SingProtocolTemperature 'Hot
SingHot TemperatureBundle
  (ApplicationHandle
     muxMode responderCtx peerAddr extraFlags ByteString m a b)
pchAppHandles)

        traceWith spsTracer (PeerMonitoringResult pchConnectionId r)
        case r of
          --
          -- Errors in a protocol thread (asynchronous demotions to cold state)
          --
          -- On error, the multiplexer closes the bearer, we take advantage of
          -- it here.
          --
          -- we don't need to update connection manager; the connection handler
          -- thread terminated abruptly and the connection state will be
          -- updated by the finally handler of a connection handler.
          --

          Just (WithSomeProtocolTemperature (WithHot MiniProtocolError{})) -> do
            -- current `pchPeerStatus` must be 'HotPeer'
            state <- STM m PeerStatus -> m PeerStatus
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m PeerStatus -> m PeerStatus)
-> STM m PeerStatus -> m PeerStatus
forall a b. (a -> b) -> a -> b
$ do
              peerState <- StrictTVar m PeerStatus -> STM m PeerStatus
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m PeerStatus
pchPeerStatus
              _  <- updateUnlessCoolingOrCold pchPeerStatus PeerCooling
              return peerState
            case state of
              PeerStatus
PeerCold    -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
              PeerStatus
PeerCooling -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
              PeerStatus
hotOrWarm -> Bool -> m () -> m ()
forall a. HasCallStack => Bool -> a -> a
assert (PeerStatus
hotOrWarm PeerStatus -> PeerStatus -> Bool
forall a. Eq a => a -> a -> Bool
== PeerStatus
PeerHot) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
                           Tracer m (PeerSelectionActionsTrace peerAddr versionNumber)
-> PeerSelectionActionsTrace peerAddr versionNumber -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (PeerSelectionActionsTrace peerAddr versionNumber)
spsTracer (PeerStatusChangeType peerAddr
-> PeerSelectionActionsTrace peerAddr versionNumber
forall peerAddr vNumber.
PeerStatusChangeType peerAddr
-> PeerSelectionActionsTrace peerAddr vNumber
PeerStatusChanged (ConnectionId peerAddr -> PeerStatusChangeType peerAddr
forall peerAddr.
ConnectionId peerAddr -> PeerStatusChangeType peerAddr
HotToCooling ConnectionId peerAddr
pchConnectionId))
            peerMonitoringLoop pch
          Just (WithSomeProtocolTemperature (WithWarm MiniProtocolError{})) -> do
            -- current `pchPeerStatus` must be 'WarmPeer'
            Tracer m (PeerSelectionActionsTrace peerAddr versionNumber)
-> PeerSelectionActionsTrace peerAddr versionNumber -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (PeerSelectionActionsTrace peerAddr versionNumber)
spsTracer (PeerStatusChangeType peerAddr
-> PeerSelectionActionsTrace peerAddr versionNumber
forall peerAddr vNumber.
PeerStatusChangeType peerAddr
-> PeerSelectionActionsTrace peerAddr vNumber
PeerStatusChanged (ConnectionId peerAddr -> PeerStatusChangeType peerAddr
forall peerAddr.
ConnectionId peerAddr -> PeerStatusChangeType peerAddr
WarmToCooling ConnectionId peerAddr
pchConnectionId))
            m Bool -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m Bool -> m ()) -> m Bool -> m ()
forall a b. (a -> b) -> a -> b
$ STM m Bool -> m Bool
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (StrictTVar m PeerStatus -> PeerStatus -> STM m Bool
updateUnlessCoolingOrCold StrictTVar m PeerStatus
pchPeerStatus PeerStatus
PeerCooling)
            PeerConnectionHandle
  muxMode
  responderCtx
  peerAddr
  extraFlags
  versionData
  ByteString
  m
  a
  b
-> m ()
peerMonitoringLoop PeerConnectionHandle
  muxMode
  responderCtx
  peerAddr
  extraFlags
  versionData
  ByteString
  m
  a
  b
pch
          Just (WithSomeProtocolTemperature (WithEstablished MiniProtocolError{})) -> do
            -- update 'pchPeerStatus' and log (as the two other transition to
            -- cold state.
            state <- STM m PeerStatus -> m PeerStatus
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m PeerStatus -> m PeerStatus)
-> STM m PeerStatus -> m PeerStatus
forall a b. (a -> b) -> a -> b
$ do
              peerState <- StrictTVar m PeerStatus -> STM m PeerStatus
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m PeerStatus
pchPeerStatus
              _  <- updateUnlessCoolingOrCold pchPeerStatus PeerCooling
              pure peerState
            case state of
              PeerStatus
PeerCold    -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
              PeerStatus
PeerCooling -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
              PeerStatus
PeerWarm    -> Tracer m (PeerSelectionActionsTrace peerAddr versionNumber)
-> PeerSelectionActionsTrace peerAddr versionNumber -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (PeerSelectionActionsTrace peerAddr versionNumber)
spsTracer (PeerStatusChangeType peerAddr
-> PeerSelectionActionsTrace peerAddr versionNumber
forall peerAddr vNumber.
PeerStatusChangeType peerAddr
-> PeerSelectionActionsTrace peerAddr vNumber
PeerStatusChanged (ConnectionId peerAddr -> PeerStatusChangeType peerAddr
forall peerAddr.
ConnectionId peerAddr -> PeerStatusChangeType peerAddr
WarmToCooling ConnectionId peerAddr
pchConnectionId))
              PeerStatus
PeerHot     -> Tracer m (PeerSelectionActionsTrace peerAddr versionNumber)
-> PeerSelectionActionsTrace peerAddr versionNumber -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (PeerSelectionActionsTrace peerAddr versionNumber)
spsTracer (PeerStatusChangeType peerAddr
-> PeerSelectionActionsTrace peerAddr versionNumber
forall peerAddr vNumber.
PeerStatusChangeType peerAddr
-> PeerSelectionActionsTrace peerAddr vNumber
PeerStatusChanged (ConnectionId peerAddr -> PeerStatusChangeType peerAddr
forall peerAddr.
ConnectionId peerAddr -> PeerStatusChangeType peerAddr
HotToCooling ConnectionId peerAddr
pchConnectionId))
            peerMonitoringLoop pch

          --
          -- Successful termination
          --

          -- A /hot/ protocol terminated, we deactivate the connection and keep
          -- monitoring /warm/ and /established/ protocols.
          Just (WithSomeProtocolTemperature (WithHot MiniProtocolSuccess {})) -> do
            PeerConnectionHandle
  muxMode
  responderCtx
  peerAddr
  extraFlags
  versionData
  ByteString
  m
  a
  b
-> m ()
deactivatePeerConnection PeerConnectionHandle
  muxMode
  responderCtx
  peerAddr
  extraFlags
  versionData
  ByteString
  m
  a
  b
pch
            PeerConnectionHandle
  muxMode
  responderCtx
  peerAddr
  extraFlags
  versionData
  ByteString
  m
  a
  b
-> m ()
peerMonitoringLoop PeerConnectionHandle
  muxMode
  responderCtx
  peerAddr
  extraFlags
  versionData
  ByteString
  m
  a
  b
pch

          -- If an /established/ or /warm/ we demote the peer to 'PeerCold'.
          -- Warm protocols are quiesced when a peer becomes hot, but never
          -- terminated by 'PeerStateActions' (with the obvious exception of
          -- 'closePeerConnection'); also, established mini-protocols are not
          -- supposed to terminate (unless the remote peer did something
          -- wrong).
          Just (WithSomeProtocolTemperature (WithWarm MiniProtocolSuccess {})) -> do
            _peerStatus <- PeerConnectionHandle
  muxMode
  responderCtx
  peerAddr
  extraFlags
  versionData
  ByteString
  m
  a
  b
-> m PeerStatus
closePeerConnection PeerConnectionHandle
  muxMode
  responderCtx
  peerAddr
  extraFlags
  versionData
  ByteString
  m
  a
  b
pch
            -- if peerStatus is `PeerCold`, in the next loop we'll log
            -- `CoolingToCold`; it's likely it is `PeerCooling` in which case
            -- we'll block until whole connection is demoted.
            peerMonitoringLoop pch
          Just (WithSomeProtocolTemperature (WithEstablished MiniProtocolSuccess {})) -> do
            _peerStatus <- PeerConnectionHandle
  muxMode
  responderCtx
  peerAddr
  extraFlags
  versionData
  ByteString
  m
  a
  b
-> m PeerStatus
closePeerConnection PeerConnectionHandle
  muxMode
  responderCtx
  peerAddr
  extraFlags
  versionData
  ByteString
  m
  a
  b
pch
            -- if peerStatus is `PeerCold`, in the next loop we'll log
            -- `CoolingToCold`; it's likely it is `PeerCooling` in which case
            -- we'll block until whole connection is demoted.
            peerMonitoringLoop pch

          --
          -- peerMonitingLoop exit
          --

          Maybe (WithSomeProtocolTemperature FirstToFinishResult)
Nothing ->
            PeerConnectionHandle
  muxMode
  responderCtx
  peerAddr
  extraFlags
  versionData
  ByteString
  m
  a
  b
-> m ()
forall bytes.
PeerConnectionHandle
  muxMode responderCtx peerAddr extraFlags versionData bytes m a b
-> m ()
tracePeerHotDuration PeerConnectionHandle
  muxMode
  responderCtx
  peerAddr
  extraFlags
  versionData
  ByteString
  m
  a
  b
pch m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
            Tracer m (PeerSelectionActionsTrace peerAddr versionNumber)
-> PeerSelectionActionsTrace peerAddr versionNumber -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (PeerSelectionActionsTrace peerAddr versionNumber)
spsTracer (PeerStatusChangeType peerAddr
-> PeerSelectionActionsTrace peerAddr versionNumber
forall peerAddr vNumber.
PeerStatusChangeType peerAddr
-> PeerSelectionActionsTrace peerAddr vNumber
PeerStatusChanged (ConnectionId peerAddr -> PeerStatusChangeType peerAddr
forall peerAddr.
ConnectionId peerAddr -> PeerStatusChangeType peerAddr
CoolingToCold ConnectionId peerAddr
pchConnectionId))

    establishPeerConnection :: JobPool () m (Maybe SomeException)
                            -> IsBigLedgerPeer
                            -> DiffusionMode
                            -> Provenance
                            -> peerAddr
                            -> extraFlags
                            -> m (PeerConnectionHandle muxMode responderCtx peerAddr extraFlags versionData ByteString m a b)
    establishPeerConnection :: JobPool () m (Maybe SomeException)
-> IsBigLedgerPeer
-> DiffusionMode
-> Provenance
-> peerAddr
-> extraFlags
-> m (PeerConnectionHandle
        muxMode
        responderCtx
        peerAddr
        extraFlags
        versionData
        ByteString
        m
        a
        b)
establishPeerConnection JobPool () m (Maybe SomeException)
jobPool IsBigLedgerPeer
isBigLedgerPeer DiffusionMode
diffusionMode Provenance
provenance peerAddr
remotePeerAddr extraFlags
extraFlags =
      -- Protect consistency of the peer state with 'bracketOnError' if
      -- opening a connection fails.
      m (StrictTVar m PeerStatus)
-> (StrictTVar m PeerStatus -> m ())
-> (StrictTVar m PeerStatus
    -> m (PeerConnectionHandle
            muxMode
            responderCtx
            peerAddr
            extraFlags
            versionData
            ByteString
            m
            a
            b))
-> m (PeerConnectionHandle
        muxMode
        responderCtx
        peerAddr
        extraFlags
        versionData
        ByteString
        m
        a
        b)
forall a b c. m a -> (a -> m b) -> (a -> m c) -> m c
forall (m :: * -> *) a b c.
MonadCatch m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracketOnError
        (PeerStatus -> m (StrictTVar m PeerStatus)
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
newTVarIO PeerStatus
PeerCold)
        (\StrictTVar m PeerStatus
peerStateVar -> STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ StrictTVar m PeerStatus -> PeerStatus -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m PeerStatus
peerStateVar PeerStatus
PeerCold)
        ((StrictTVar m PeerStatus
  -> m (PeerConnectionHandle
          muxMode
          responderCtx
          peerAddr
          extraFlags
          versionData
          ByteString
          m
          a
          b))
 -> m (PeerConnectionHandle
         muxMode
         responderCtx
         peerAddr
         extraFlags
         versionData
         ByteString
         m
         a
         b))
-> (StrictTVar m PeerStatus
    -> m (PeerConnectionHandle
            muxMode
            responderCtx
            peerAddr
            extraFlags
            versionData
            ByteString
            m
            a
            b))
-> m (PeerConnectionHandle
        muxMode
        responderCtx
        peerAddr
        extraFlags
        versionData
        ByteString
        m
        a
        b)
forall a b. (a -> b) -> a -> b
$ \StrictTVar m PeerStatus
peerStateVar -> do
          res <- m (Connected
     peerAddr
     (Handle
        muxMode
        (ExpandedInitiatorContext peerAddr extraFlags m)
        responderCtx
        versionData
        ByteString
        m
        a
        b)
     (HandlerError versionNumber))
-> m (Either
        SomeException
        (Connected
           peerAddr
           (Handle
              muxMode
              (ExpandedInitiatorContext peerAddr extraFlags m)
              responderCtx
              versionData
              ByteString
              m
              a
              b)
           (HandlerError versionNumber)))
forall e a. Exception e => m a -> m (Either e a)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (m (Connected
      peerAddr
      (Handle
         muxMode
         (ExpandedInitiatorContext peerAddr extraFlags m)
         responderCtx
         versionData
         ByteString
         m
         a
         b)
      (HandlerError versionNumber))
 -> m (Either
         SomeException
         (Connected
            peerAddr
            (Handle
               muxMode
               (ExpandedInitiatorContext peerAddr extraFlags m)
               responderCtx
               versionData
               ByteString
               m
               a
               b)
            (HandlerError versionNumber))))
-> m (Connected
        peerAddr
        (Handle
           muxMode
           (ExpandedInitiatorContext peerAddr extraFlags m)
           responderCtx
           versionData
           ByteString
           m
           a
           b)
        (HandlerError versionNumber))
-> m (Either
        SomeException
        (Connected
           peerAddr
           (Handle
              muxMode
              (ExpandedInitiatorContext peerAddr extraFlags m)
              responderCtx
              versionData
              ByteString
              m
              a
              b)
           (HandlerError versionNumber)))
forall a b. (a -> b) -> a -> b
$ MuxConnectionManager
  muxMode
  socket
  (ExpandedInitiatorContext peerAddr extraFlags m)
  responderCtx
  peerAddr
  versionData
  versionNumber
  ByteString
  m
  a
  b
-> AcquireOutboundConnection
     peerAddr
     (Handle
        muxMode
        (ExpandedInitiatorContext peerAddr extraFlags m)
        responderCtx
        versionData
        ByteString
        m
        a
        b)
     (HandlerError versionNumber)
     m
forall (muxMode :: Mode) socket peerAddr handle handleError
       (m :: * -> *).
(HasInitiator muxMode ~ 'True) =>
ConnectionManager muxMode socket peerAddr handle handleError m
-> AcquireOutboundConnection peerAddr handle handleError m
acquireOutboundConnection
                         MuxConnectionManager
  muxMode
  socket
  (ExpandedInitiatorContext peerAddr extraFlags m)
  responderCtx
  peerAddr
  versionData
  versionNumber
  ByteString
  m
  a
  b
spsConnectionManager
                         DiffusionMode
diffusionMode
                         peerAddr
remotePeerAddr
                         Provenance
provenance
          case res of
            Left SomeException
e -> do
              Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe SomeAsyncException -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe SomeAsyncException -> Bool)
-> Maybe SomeAsyncException -> Bool
forall a b. (a -> b) -> a -> b
$ forall e. Exception e => SomeException -> Maybe e
fromException @SomeAsyncException SomeException
e) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
                Tracer m (PeerSelectionActionsTrace peerAddr versionNumber)
-> PeerSelectionActionsTrace peerAddr versionNumber -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (PeerSelectionActionsTrace peerAddr versionNumber)
spsTracer (SomeException -> PeerSelectionActionsTrace peerAddr versionNumber
forall peerAddr vNumber.
SomeException -> PeerSelectionActionsTrace peerAddr vNumber
AcquireConnectionError SomeException
e)
              case RethrowPolicy -> ErrorContext -> SomeException -> ErrorCommand
runRethrowPolicy RethrowPolicy
spsRethrowPolicy ErrorContext
OutboundError SomeException
e of
                ErrorCommand
ShutdownNode -> ThreadId m -> SomeException -> m ()
forall e. Exception e => ThreadId m -> e -> m ()
forall (m :: * -> *) e.
(MonadFork m, Exception e) =>
ThreadId m -> e -> m ()
throwTo ThreadId m
spsMainThreadId SomeException
e
                             m ()
-> m (PeerConnectionHandle
        muxMode
        responderCtx
        peerAddr
        extraFlags
        versionData
        ByteString
        m
        a
        b)
-> m (PeerConnectionHandle
        muxMode
        responderCtx
        peerAddr
        extraFlags
        versionData
        ByteString
        m
        a
        b)
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SomeException
-> m (PeerConnectionHandle
        muxMode
        responderCtx
        peerAddr
        extraFlags
        versionData
        ByteString
        m
        a
        b)
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO SomeException
e
                ErrorCommand
ShutdownPeer -> SomeException
-> m (PeerConnectionHandle
        muxMode
        responderCtx
        peerAddr
        extraFlags
        versionData
        ByteString
        m
        a
        b)
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO SomeException
e

            Right (Connected connId :: ConnectionId peerAddr
connId@ConnectionId { peerAddr
localAddress :: peerAddr
localAddress :: forall addr. ConnectionId addr -> addr
localAddress, peerAddr
remoteAddress :: peerAddr
remoteAddress :: forall addr. ConnectionId addr -> addr
remoteAddress }
                             DataFlow
_dataFlow
                            (Handle Mux muxMode m
mux OuroborosBundle
  muxMode
  (ExpandedInitiatorContext peerAddr extraFlags m)
  responderCtx
  ByteString
  m
  a
  b
muxBundle TemperatureBundle (StrictTVar m ControlMessage)
controlMessageBundle versionData
versionData)) -> do

              STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
                StrictTVar m ControlMessage -> ControlMessage -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> a -> STM m ()
writeTVar (SingProtocolTemperature 'Hot
-> TemperatureBundle (StrictTVar m ControlMessage)
-> StrictTVar m ControlMessage
forall (pt :: ProtocolTemperature) a.
SingProtocolTemperature pt -> TemperatureBundle a -> a
projectBundle SingProtocolTemperature 'Hot
SingHot         TemperatureBundle (StrictTVar m ControlMessage)
controlMessageBundle) ControlMessage
Terminate
                StrictTVar m ControlMessage -> ControlMessage -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> a -> STM m ()
writeTVar (SingProtocolTemperature 'Warm
-> TemperatureBundle (StrictTVar m ControlMessage)
-> StrictTVar m ControlMessage
forall (pt :: ProtocolTemperature) a.
SingProtocolTemperature pt -> TemperatureBundle a -> a
projectBundle SingProtocolTemperature 'Warm
SingWarm        TemperatureBundle (StrictTVar m ControlMessage)
controlMessageBundle) ControlMessage
Continue
                StrictTVar m ControlMessage -> ControlMessage -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> a -> STM m ()
writeTVar (SingProtocolTemperature 'Established
-> TemperatureBundle (StrictTVar m ControlMessage)
-> StrictTVar m ControlMessage
forall (pt :: ProtocolTemperature) a.
SingProtocolTemperature pt -> TemperatureBundle a -> a
projectBundle SingProtocolTemperature 'Established
SingEstablished TemperatureBundle (StrictTVar m ControlMessage)
controlMessageBundle) ControlMessage
Continue

              awaitVarBundle    <- STM
  m
  (TemperatureBundle
     (StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))))
-> m (TemperatureBundle
        (StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))))
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM
   m
   (TemperatureBundle
      (StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))))
 -> m (TemperatureBundle
         (StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a))))))
-> STM
     m
     (TemperatureBundle
        (StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))))
-> m (TemperatureBundle
        (StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))))
forall a b. (a -> b) -> a -> b
$ OuroborosBundle
  muxMode
  (ExpandedInitiatorContext peerAddr extraFlags m)
  responderCtx
  ByteString
  m
  a
  b
-> STM
     m
     (TemperatureBundle
        (StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))))
mkAwaitVars OuroborosBundle
  muxMode
  (ExpandedInitiatorContext peerAddr extraFlags m)
  responderCtx
  ByteString
  m
  a
  b
muxBundle
              pchPromotedHotVar <- newTVarIO Nothing

              let connHandle =
                    PeerConnectionHandle {
                        pchConnectionId :: ConnectionId peerAddr
pchConnectionId = ConnectionId peerAddr
connId,
                        pchPeerStatus :: StrictTVar m PeerStatus
pchPeerStatus   = StrictTVar m PeerStatus
peerStateVar,
                        pchMux :: Mux muxMode m
pchMux          = Mux muxMode m
mux,
                        pchAppHandles :: TemperatureBundle
  (ApplicationHandle
     muxMode responderCtx peerAddr extraFlags ByteString m a b)
pchAppHandles   = OuroborosBundle
  muxMode
  (ExpandedInitiatorContext peerAddr extraFlags m)
  responderCtx
  ByteString
  m
  a
  b
-> TemperatureBundle (StrictTVar m ControlMessage)
-> TemperatureBundle
     (StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a))))
-> TemperatureBundle
     (ApplicationHandle
        muxMode responderCtx peerAddr extraFlags ByteString m a b)
forall (muxMode :: Mode) responderCtx peerAddr extraFlags bytes
       (m :: * -> *) a b.
OuroborosBundle
  muxMode
  (ExpandedInitiatorContext peerAddr extraFlags m)
  responderCtx
  bytes
  m
  a
  b
-> TemperatureBundle (StrictTVar m ControlMessage)
-> TemperatureBundle
     (StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a))))
-> TemperatureBundle
     (ApplicationHandle
        muxMode responderCtx peerAddr extraFlags bytes m a b)
mkApplicationHandleBundle
                                            OuroborosBundle
  muxMode
  (ExpandedInitiatorContext peerAddr extraFlags m)
  responderCtx
  ByteString
  m
  a
  b
muxBundle
                                            TemperatureBundle (StrictTVar m ControlMessage)
controlMessageBundle
                                            TemperatureBundle
  (StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a))))
awaitVarBundle,
                        pchVersionData :: versionData
pchVersionData  = versionData
versionData,
                        StrictTVar m (Maybe Time)
pchPromotedHotVar :: StrictTVar m (Maybe Time)
pchPromotedHotVar :: StrictTVar m (Maybe Time)
pchPromotedHotVar
                      }

              startProtocols SingWarm isBigLedgerPeer extraFlags connHandle
              startProtocols SingEstablished isBigLedgerPeer extraFlags connHandle
              atomically $ writeTVar peerStateVar PeerWarm
              traceWith spsTracer (PeerStatusChanged
                                    (ColdToWarm
                                      (Just localAddress)
                                      remoteAddress))

              JobPool.forkJob jobPool
                              (Job (handleJust
                                     (\SomeException
e -> case SomeException -> Maybe SomeAsyncException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
                                        Just SomeAsyncException {} -> Maybe SomeException
forall a. Maybe a
Nothing
                                        Maybe SomeAsyncException
Nothing                    -> SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just SomeException
e)
                                     (\SomeException
e -> do
                                        STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically do
                                          MuxConnectionManager
  muxMode
  socket
  (ExpandedInitiatorContext peerAddr extraFlags m)
  responderCtx
  peerAddr
  versionData
  versionNumber
  ByteString
  m
  a
  b
-> ConnectionId peerAddr -> STM m ()
forall (muxMode :: Mode) socket peerAddr handle handleError
       (m :: * -> *).
ConnectionManager muxMode socket peerAddr handle handleError m
-> ConnectionId peerAddr -> STM m ()
waitForOutboundDemotion MuxConnectionManager
  muxMode
  socket
  (ExpandedInitiatorContext peerAddr extraFlags m)
  responderCtx
  peerAddr
  versionData
  versionNumber
  ByteString
  m
  a
  b
spsConnectionManager ConnectionId peerAddr
connId
                                          StrictTVar m PeerStatus -> PeerStatus -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m PeerStatus
peerStateVar PeerStatus
PeerCold
                                        PeerConnectionHandle
  muxMode
  responderCtx
  peerAddr
  extraFlags
  versionData
  ByteString
  m
  a
  b
-> m ()
forall bytes.
PeerConnectionHandle
  muxMode responderCtx peerAddr extraFlags versionData bytes m a b
-> m ()
tracePeerHotDuration PeerConnectionHandle
  muxMode
  responderCtx
  peerAddr
  extraFlags
  versionData
  ByteString
  m
  a
  b
connHandle
                                        Tracer m (PeerSelectionActionsTrace peerAddr versionNumber)
-> PeerSelectionActionsTrace peerAddr versionNumber -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (PeerSelectionActionsTrace peerAddr versionNumber)
spsTracer (ConnectionId peerAddr
-> SomeException
-> PeerSelectionActionsTrace peerAddr versionNumber
forall peerAddr vNumber.
ConnectionId peerAddr
-> SomeException -> PeerSelectionActionsTrace peerAddr vNumber
PeerMonitoringError ConnectionId peerAddr
connId SomeException
e)
                                        SomeException -> m (Maybe SomeException)
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO SomeException
e)
                                     (peerMonitoringLoop connHandle $> Nothing))
                                   (return . Just)
                                   ()  -- unit group, not using JobPool to group jobs.
                                   ("peerMonitoringLoop " ++ show remoteAddress))
              pure connHandle

            Right (Disconnected ConnectionId peerAddr
_ DisconnectionException (HandlerError versionNumber)
disconnectionError) ->
              case DisconnectionException (HandlerError versionNumber)
disconnectionError of
                ConnectionHandlerError HandlerError versionNumber
handlerError ->
                  case HandlerError versionNumber
handlerError of
                    HandleHandshakeClientError HandshakeException versionNumber
err -> do
                      Tracer m (PeerSelectionActionsTrace peerAddr versionNumber)
-> PeerSelectionActionsTrace peerAddr versionNumber -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (PeerSelectionActionsTrace peerAddr versionNumber)
spsTracer (PeerStatusChangeType peerAddr
-> FailureType versionNumber
-> PeerSelectionActionsTrace peerAddr versionNumber
forall peerAddr vNumber.
PeerStatusChangeType peerAddr
-> FailureType vNumber
-> PeerSelectionActionsTrace peerAddr vNumber
PeerStatusChangeFailure
                                            (Maybe peerAddr -> peerAddr -> PeerStatusChangeType peerAddr
forall peerAddr.
Maybe peerAddr -> peerAddr -> PeerStatusChangeType peerAddr
ColdToWarm Maybe peerAddr
forall a. Maybe a
Nothing peerAddr
remotePeerAddr)
                                            (HandshakeException versionNumber -> FailureType versionNumber
forall versionNumber.
HandshakeException versionNumber -> FailureType versionNumber
HandshakeClientFailure HandshakeException versionNumber
err))
                      EstablishConnectionException versionNumber
-> m (PeerConnectionHandle
        muxMode
        responderCtx
        peerAddr
        extraFlags
        versionData
        ByteString
        m
        a
        b)
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (HandshakeException versionNumber
-> EstablishConnectionException versionNumber
forall versionNumber.
HandshakeException versionNumber
-> EstablishConnectionException versionNumber
ClientException HandshakeException versionNumber
err)

                    HandleHandshakeServerError HandshakeException versionNumber
err -> do
                      Tracer m (PeerSelectionActionsTrace peerAddr versionNumber)
-> PeerSelectionActionsTrace peerAddr versionNumber -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (PeerSelectionActionsTrace peerAddr versionNumber)
spsTracer (PeerStatusChangeType peerAddr
-> FailureType versionNumber
-> PeerSelectionActionsTrace peerAddr versionNumber
forall peerAddr vNumber.
PeerStatusChangeType peerAddr
-> FailureType vNumber
-> PeerSelectionActionsTrace peerAddr vNumber
PeerStatusChangeFailure
                                            (Maybe peerAddr -> peerAddr -> PeerStatusChangeType peerAddr
forall peerAddr.
Maybe peerAddr -> peerAddr -> PeerStatusChangeType peerAddr
ColdToWarm Maybe peerAddr
forall a. Maybe a
Nothing peerAddr
remotePeerAddr)
                                            (HandshakeException versionNumber -> FailureType versionNumber
forall versionNumber.
HandshakeException versionNumber -> FailureType versionNumber
HandshakeServerFailure HandshakeException versionNumber
err))
                      EstablishConnectionException versionNumber
-> m (PeerConnectionHandle
        muxMode
        responderCtx
        peerAddr
        extraFlags
        versionData
        ByteString
        m
        a
        b)
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (HandshakeException versionNumber
-> EstablishConnectionException versionNumber
forall versionNumber.
HandshakeException versionNumber
-> EstablishConnectionException versionNumber
ServerException HandshakeException versionNumber
err)

                    HandlerError SomeException
err -> do
                      Tracer m (PeerSelectionActionsTrace peerAddr versionNumber)
-> PeerSelectionActionsTrace peerAddr versionNumber -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (PeerSelectionActionsTrace peerAddr versionNumber)
spsTracer (PeerStatusChangeType peerAddr
-> FailureType versionNumber
-> PeerSelectionActionsTrace peerAddr versionNumber
forall peerAddr vNumber.
PeerStatusChangeType peerAddr
-> FailureType vNumber
-> PeerSelectionActionsTrace peerAddr vNumber
PeerStatusChangeFailure
                                            (Maybe peerAddr -> peerAddr -> PeerStatusChangeType peerAddr
forall peerAddr.
Maybe peerAddr -> peerAddr -> PeerStatusChangeType peerAddr
ColdToWarm Maybe peerAddr
forall a. Maybe a
Nothing peerAddr
remotePeerAddr )
                                            (SomeException -> FailureType versionNumber
forall versionNumber. SomeException -> FailureType versionNumber
HandleFailure SomeException
err))
                      SomeException
-> m (PeerConnectionHandle
        muxMode
        responderCtx
        peerAddr
        extraFlags
        versionData
        ByteString
        m
        a
        b)
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO SomeException
err

                DisconnectionException (HandlerError versionNumber)
_ -> DisconnectionException (HandlerError versionNumber)
-> m (PeerConnectionHandle
        muxMode
        responderCtx
        peerAddr
        extraFlags
        versionData
        ByteString
        m
        a
        b)
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO DisconnectionException (HandlerError versionNumber)
disconnectionError
      where
        mkAwaitVars :: OuroborosBundle muxMode (ExpandedInitiatorContext peerAddr extraFlags m)
                                               responderCtx ByteString m a b
                    -> STM m (TemperatureBundle
                               (StrictTVar m
                                 (Map MiniProtocolNum
                                   (STM m (HasReturned a)))))
        mkAwaitVars :: OuroborosBundle
  muxMode
  (ExpandedInitiatorContext peerAddr extraFlags m)
  responderCtx
  ByteString
  m
  a
  b
-> STM
     m
     (TemperatureBundle
        (StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))))
mkAwaitVars = ([MiniProtocol
    muxMode
    (ExpandedInitiatorContext peerAddr extraFlags m)
    responderCtx
    ByteString
    m
    a
    b]
 -> STM
      m (StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))))
-> OuroborosBundle
     muxMode
     (ExpandedInitiatorContext peerAddr extraFlags m)
     responderCtx
     ByteString
     m
     a
     b
-> STM
     m
     (TemperatureBundle
        (StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> TemperatureBundle a -> f (TemperatureBundle b)
traverse [MiniProtocol
   muxMode
   (ExpandedInitiatorContext peerAddr extraFlags m)
   responderCtx
   ByteString
   m
   a
   b]
-> STM
     m (StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a))))
f
          where
            f :: [MiniProtocol muxMode (ExpandedInitiatorContext peerAddr extraFlags m)
                                       responderCtx ByteString m a b]
              -> STM m (StrictTVar m
                         (Map MiniProtocolNum
                           (STM m (HasReturned a))))
            f :: [MiniProtocol
   muxMode
   (ExpandedInitiatorContext peerAddr extraFlags m)
   responderCtx
   ByteString
   m
   a
   b]
-> STM
     m (StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a))))
f = Map MiniProtocolNum (STM m (HasReturned a))
-> STM
     m (StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a))))
forall (m :: * -> *) a. MonadSTM m => a -> STM m (StrictTVar m a)
newTVar
              (Map MiniProtocolNum (STM m (HasReturned a))
 -> STM
      m (StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))))
-> ([MiniProtocol
       muxMode
       (ExpandedInitiatorContext peerAddr extraFlags m)
       responderCtx
       ByteString
       m
       a
       b]
    -> Map MiniProtocolNum (STM m (HasReturned a)))
-> [MiniProtocol
      muxMode
      (ExpandedInitiatorContext peerAddr extraFlags m)
      responderCtx
      ByteString
      m
      a
      b]
-> STM
     m (StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a))))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(MiniProtocolNum, STM m (HasReturned a))]
-> Map MiniProtocolNum (STM m (HasReturned a))
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
              ([(MiniProtocolNum, STM m (HasReturned a))]
 -> Map MiniProtocolNum (STM m (HasReturned a)))
-> ([MiniProtocol
       muxMode
       (ExpandedInitiatorContext peerAddr extraFlags m)
       responderCtx
       ByteString
       m
       a
       b]
    -> [(MiniProtocolNum, STM m (HasReturned a))])
-> [MiniProtocol
      muxMode
      (ExpandedInitiatorContext peerAddr extraFlags m)
      responderCtx
      ByteString
      m
      a
      b]
-> Map MiniProtocolNum (STM m (HasReturned a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MiniProtocol
   muxMode
   (ExpandedInitiatorContext peerAddr extraFlags m)
   responderCtx
   ByteString
   m
   a
   b
 -> (MiniProtocolNum, STM m (HasReturned a)))
-> [MiniProtocol
      muxMode
      (ExpandedInitiatorContext peerAddr extraFlags m)
      responderCtx
      ByteString
      m
      a
      b]
-> [(MiniProtocolNum, STM m (HasReturned a))]
forall a b. (a -> b) -> [a] -> [b]
map (\MiniProtocol { MiniProtocolNum
miniProtocolNum :: MiniProtocolNum
miniProtocolNum :: forall (mode :: Mode) initiatorCtx responderCtx bytes (m :: * -> *)
       a b.
MiniProtocol mode initiatorCtx responderCtx bytes m a b
-> MiniProtocolNum
miniProtocolNum } ->
                      ( MiniProtocolNum
miniProtocolNum
                      -- Initially none of the protocols is running; This will
                      -- shortly get updated for established and warm
                      -- protocols, since 'establishPeerConnection' runs
                      -- 'startProtocols'; for hot protocols this will be
                      -- updated once the peer is promoted to hot.
                      , HasReturned a -> STM m (HasReturned a)
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HasReturned a
forall a. HasReturned a
NotStarted
                      ))


    -- 'monitorPeerConnection' is only used against established connections.
    -- It returns 'Nothing' only if all mini-protocols are either not running
    -- or still executing.
    --
    monitorPeerConnection :: PeerConnectionHandle muxMode responderCtx peerAddr extraFlags versionData ByteString m a b
                          -> STM m (PeerStatus, Maybe RepromoteDelay)
    monitorPeerConnection :: PeerConnectionHandle
  muxMode
  responderCtx
  peerAddr
  extraFlags
  versionData
  ByteString
  m
  a
  b
-> STM m (PeerStatus, Maybe RepromoteDelay)
monitorPeerConnection PeerConnectionHandle { StrictTVar m PeerStatus
pchPeerStatus :: forall (muxMode :: Mode) responderCtx peerAddr extraFlags
       versionData bytes (m :: * -> *) a b.
PeerConnectionHandle
  muxMode responderCtx peerAddr extraFlags versionData bytes m a b
-> StrictTVar m PeerStatus
pchPeerStatus :: StrictTVar m PeerStatus
pchPeerStatus, TemperatureBundle
  (ApplicationHandle
     muxMode responderCtx peerAddr extraFlags ByteString m a b)
pchAppHandles :: forall (muxMode :: Mode) responderCtx peerAddr extraFlags
       versionData bytes (m :: * -> *) a b.
PeerConnectionHandle
  muxMode responderCtx peerAddr extraFlags versionData bytes m a b
-> TemperatureBundle
     (ApplicationHandle
        muxMode responderCtx peerAddr extraFlags bytes m a b)
pchAppHandles :: TemperatureBundle
  (ApplicationHandle
     muxMode responderCtx peerAddr extraFlags ByteString m a b)
pchAppHandles } =
         PeerStatus
-> Maybe RepromoteDelay -> (PeerStatus, Maybe RepromoteDelay)
p  (PeerStatus
 -> Maybe RepromoteDelay -> (PeerStatus, Maybe RepromoteDelay))
-> STM m PeerStatus
-> STM
     m (Maybe RepromoteDelay -> (PeerStatus, Maybe RepromoteDelay))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar m PeerStatus -> STM m PeerStatus
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m PeerStatus
pchPeerStatus
            STM m (Maybe RepromoteDelay -> (PeerStatus, Maybe RepromoteDelay))
-> STM m (Maybe RepromoteDelay)
-> STM m (PeerStatus, Maybe RepromoteDelay)
forall a b. STM m (a -> b) -> STM m a -> STM m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (TemperatureBundle (Map MiniProtocolNum (Maybe (HasReturned a)))
-> Maybe RepromoteDelay
g (TemperatureBundle (Map MiniProtocolNum (Maybe (HasReturned a)))
 -> Maybe RepromoteDelay)
-> STM
     m (TemperatureBundle (Map MiniProtocolNum (Maybe (HasReturned a))))
-> STM m (Maybe RepromoteDelay)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ApplicationHandle
   muxMode responderCtx peerAddr extraFlags ByteString m a b
 -> STM m (Map MiniProtocolNum (Maybe (HasReturned a))))
-> TemperatureBundle
     (ApplicationHandle
        muxMode responderCtx peerAddr extraFlags ByteString m a b)
-> STM
     m (TemperatureBundle (Map MiniProtocolNum (Maybe (HasReturned a))))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> TemperatureBundle a -> f (TemperatureBundle b)
traverse ApplicationHandle
  muxMode responderCtx peerAddr extraFlags ByteString m a b
-> STM m (Map MiniProtocolNum (Maybe (HasReturned a)))
f TemperatureBundle
  (ApplicationHandle
     muxMode responderCtx peerAddr extraFlags ByteString m a b)
pchAppHandles)
        STM m (Maybe RepromoteDelay)
-> STM m (Maybe RepromoteDelay) -> STM m (Maybe RepromoteDelay)
forall a. STM m a -> STM m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => STM m a -> STM m a -> STM m a
`orElse` MonitorPeerConnectionBlocked -> STM m (Maybe RepromoteDelay)
forall (m :: * -> *) e a.
(MonadSTM m, MonadThrow (STM m), Exception e) =>
e -> STM m a
throwSTM MonitorPeerConnectionBlocked
MonitorPeerConnectionBlocked
      where
        f :: ApplicationHandle muxMode responderCtx peerAddr extraFlags ByteString m a b
          -> STM m (Map MiniProtocolNum (Maybe (HasReturned a)))
             -- do not block when a mini-protocol is still running, otherwise
             -- outbound governor
             -- `Ouroboros.Network.PeerSelection.Governor.Monitor.connections`
             -- will not be able to get the 'PeerStatus' of all peers.
        f :: ApplicationHandle
  muxMode responderCtx peerAddr extraFlags ByteString m a b
-> STM m (Map MiniProtocolNum (Maybe (HasReturned a)))
f =  (STM m (HasReturned a) -> STM m (Maybe (HasReturned a)))
-> Map MiniProtocolNum (STM m (HasReturned a))
-> STM m (Map MiniProtocolNum (Maybe (HasReturned a)))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Map MiniProtocolNum a -> f (Map MiniProtocolNum b)
traverse (\STM m (HasReturned a)
stm -> (HasReturned a -> Maybe (HasReturned a)
forall a. a -> Maybe a
Just (HasReturned a -> Maybe (HasReturned a))
-> STM m (HasReturned a) -> STM m (Maybe (HasReturned a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM m (HasReturned a)
stm) STM m (Maybe (HasReturned a))
-> STM m (Maybe (HasReturned a)) -> STM m (Maybe (HasReturned a))
forall a. STM m a -> STM m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => STM m a -> STM m a -> STM m a
`orElse` Maybe (HasReturned a) -> STM m (Maybe (HasReturned a))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (HasReturned a)
forall a. Maybe a
Nothing)
         (Map MiniProtocolNum (STM m (HasReturned a))
 -> STM m (Map MiniProtocolNum (Maybe (HasReturned a))))
-> (ApplicationHandle
      muxMode responderCtx peerAddr extraFlags ByteString m a b
    -> STM m (Map MiniProtocolNum (STM m (HasReturned a))))
-> ApplicationHandle
     muxMode responderCtx peerAddr extraFlags ByteString m a b
-> STM m (Map MiniProtocolNum (Maybe (HasReturned a)))
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))
-> STM m (Map MiniProtocolNum (STM m (HasReturned a)))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))
 -> STM m (Map MiniProtocolNum (STM m (HasReturned a))))
-> (ApplicationHandle
      muxMode responderCtx peerAddr extraFlags ByteString m a b
    -> StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a))))
-> ApplicationHandle
     muxMode responderCtx peerAddr extraFlags ByteString m a b
-> STM m (Map MiniProtocolNum (STM m (HasReturned a)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ApplicationHandle
  muxMode responderCtx peerAddr extraFlags ByteString m a b
-> StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))
forall (muxMode :: Mode) responderCtx peerAddr extraFlags bytes
       (m :: * -> *) a b.
ApplicationHandle
  muxMode responderCtx peerAddr extraFlags bytes m a b
-> StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))
ahMiniProtocolResults

        g :: TemperatureBundle (Map MiniProtocolNum (Maybe (HasReturned a)))
          -> Maybe RepromoteDelay
        g :: TemperatureBundle (Map MiniProtocolNum (Maybe (HasReturned a)))
-> Maybe RepromoteDelay
g = (Map MiniProtocolNum (Maybe (HasReturned a))
 -> Maybe RepromoteDelay)
-> TemperatureBundle (Map MiniProtocolNum (Maybe (HasReturned a)))
-> Maybe RepromoteDelay
forall m a. Monoid m => (a -> m) -> TemperatureBundle a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((Maybe (HasReturned a) -> Maybe RepromoteDelay)
-> Map MiniProtocolNum (Maybe (HasReturned a))
-> Maybe RepromoteDelay
forall m a. Monoid m => (a -> m) -> Map MiniProtocolNum a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Maybe (HasReturned a) -> Maybe RepromoteDelay
h)

        h :: Maybe (HasReturned a) -> Maybe RepromoteDelay
        h :: Maybe (HasReturned a) -> Maybe RepromoteDelay
h (Just (Returned a
a)) = RepromoteDelay -> Maybe RepromoteDelay
forall a. a -> Maybe a
Just (RepromoteDelay -> Maybe RepromoteDelay)
-> RepromoteDelay -> Maybe RepromoteDelay
forall a b. (a -> b) -> a -> b
$ ExitPolicy a -> ReturnPolicy a
forall a. ExitPolicy a -> ReturnPolicy a
epReturnDelay ExitPolicy a
spsExitPolicy a
a
        -- Note: we do 'RethrowPolicy' in 'ConnectionHandler' (see
        -- 'makeConnectionHandler').
        h (Just Errored {})     = RepromoteDelay -> Maybe RepromoteDelay
forall a. a -> Maybe a
Just (RepromoteDelay -> Maybe RepromoteDelay)
-> RepromoteDelay -> Maybe RepromoteDelay
forall a b. (a -> b) -> a -> b
$ ExitPolicy a -> RepromoteDelay
forall a. ExitPolicy a -> RepromoteDelay
epErrorDelay ExitPolicy a
spsExitPolicy
        h (Just (NotRunning Either SomeException a
a)) = case Either SomeException a
a of
                                    Left {} -> RepromoteDelay -> Maybe RepromoteDelay
forall a. a -> Maybe a
Just (RepromoteDelay -> Maybe RepromoteDelay)
-> RepromoteDelay -> Maybe RepromoteDelay
forall a b. (a -> b) -> a -> b
$ ExitPolicy a -> RepromoteDelay
forall a. ExitPolicy a -> RepromoteDelay
epErrorDelay ExitPolicy a
spsExitPolicy
                                    Right a
b -> RepromoteDelay -> Maybe RepromoteDelay
forall a. a -> Maybe a
Just (RepromoteDelay -> Maybe RepromoteDelay)
-> RepromoteDelay -> Maybe RepromoteDelay
forall a b. (a -> b) -> a -> b
$ ExitPolicy a -> ReturnPolicy a
forall a. ExitPolicy a -> ReturnPolicy a
epReturnDelay ExitPolicy a
spsExitPolicy a
b
        h (Just HasReturned a
NotStarted)     = Maybe RepromoteDelay
forall a. Maybe a
Nothing
        h Maybe (HasReturned a)
Nothing               = Maybe RepromoteDelay
forall a. Maybe a
Nothing

        -- the delay in the `PeerCooling` state is ignored, let's make it
        -- explicit.
        p :: PeerStatus
          -> Maybe RepromoteDelay
          -> (PeerStatus, Maybe RepromoteDelay)
        p :: PeerStatus
-> Maybe RepromoteDelay -> (PeerStatus, Maybe RepromoteDelay)
p st :: PeerStatus
st@PeerStatus
PeerCooling Maybe RepromoteDelay
_ = (PeerStatus
st, Maybe RepromoteDelay
forall a. Maybe a
Nothing)
        p PeerStatus
st Maybe RepromoteDelay
delay         = (PeerStatus
st, Maybe RepromoteDelay
delay)


    -- Take a warm peer and promote it to a hot one.
    -- NB when adding any operations that can block for an extended period of
    -- of time timeouts should be implemented here in the same way it is in
    -- establishPeerConnection and deactivatePeerConnection.
    activatePeerConnection :: IsBigLedgerPeer
                           -> extraFlags
                           -> PeerConnectionHandle muxMode responderCtx peerAddr extraFlags versionData ByteString m a b
                           -> m ()
    activatePeerConnection :: IsBigLedgerPeer
-> extraFlags
-> PeerConnectionHandle
     muxMode
     responderCtx
     peerAddr
     extraFlags
     versionData
     ByteString
     m
     a
     b
-> m ()
activatePeerConnection
        IsBigLedgerPeer
isBigLedgerPeer
        extraFlags
extraFlags
        connHandle :: PeerConnectionHandle
  muxMode
  responderCtx
  peerAddr
  extraFlags
  versionData
  ByteString
  m
  a
  b
connHandle@PeerConnectionHandle {
            ConnectionId peerAddr
pchConnectionId :: forall (muxMode :: Mode) responderCtx peerAddr extraFlags
       versionData bytes (m :: * -> *) a b.
PeerConnectionHandle
  muxMode responderCtx peerAddr extraFlags versionData bytes m a b
-> ConnectionId peerAddr
pchConnectionId :: ConnectionId peerAddr
pchConnectionId,
            StrictTVar m PeerStatus
pchPeerStatus :: forall (muxMode :: Mode) responderCtx peerAddr extraFlags
       versionData bytes (m :: * -> *) a b.
PeerConnectionHandle
  muxMode responderCtx peerAddr extraFlags versionData bytes m a b
-> StrictTVar m PeerStatus
pchPeerStatus :: StrictTVar m PeerStatus
pchPeerStatus,
            TemperatureBundle
  (ApplicationHandle
     muxMode responderCtx peerAddr extraFlags ByteString m a b)
pchAppHandles :: forall (muxMode :: Mode) responderCtx peerAddr extraFlags
       versionData bytes (m :: * -> *) a b.
PeerConnectionHandle
  muxMode responderCtx peerAddr extraFlags versionData bytes m a b
-> TemperatureBundle
     (ApplicationHandle
        muxMode responderCtx peerAddr extraFlags bytes m a b)
pchAppHandles :: TemperatureBundle
  (ApplicationHandle
     muxMode responderCtx peerAddr extraFlags ByteString m a b)
pchAppHandles,
            StrictTVar m (Maybe Time)
pchPromotedHotVar :: forall (muxMode :: Mode) responderCtx peerAddr extraFlags
       versionData bytes (m :: * -> *) a b.
PeerConnectionHandle
  muxMode responderCtx peerAddr extraFlags versionData bytes m a b
-> StrictTVar m (Maybe Time)
pchPromotedHotVar :: StrictTVar m (Maybe Time)
pchPromotedHotVar } = do
      m (m ()) -> m ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (m (m ()) -> m ())
-> (STM m (m ()) -> m (m ())) -> STM m (m ()) -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM m (m ()) -> m (m ())
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (m ()) -> m ()) -> STM m (m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ do
        peerStatus <- StrictTVar m PeerStatus -> STM m PeerStatus
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m PeerStatus
pchPeerStatus
        case peerStatus of
          PeerStatus
PeerWarm -> do
            StrictTVar m ControlMessage -> ControlMessage -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> a -> STM m ()
writeTVar (SingProtocolTemperature 'Hot
-> TemperatureBundle
     (ApplicationHandle
        muxMode responderCtx peerAddr extraFlags ByteString m a b)
-> StrictTVar m ControlMessage
forall (pt :: ProtocolTemperature) (muxMode :: Mode) responderCtx
       peerAddr extraFlags bytes (m :: * -> *) a b.
SingProtocolTemperature pt
-> TemperatureBundle
     (ApplicationHandle
        muxMode responderCtx peerAddr extraFlags bytes m a b)
-> StrictTVar m ControlMessage
getControlVar SingProtocolTemperature 'Hot
SingHot TemperatureBundle
  (ApplicationHandle
     muxMode responderCtx peerAddr extraFlags ByteString m a b)
pchAppHandles) ControlMessage
Continue
            StrictTVar m ControlMessage -> ControlMessage -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> a -> STM m ()
writeTVar (SingProtocolTemperature 'Warm
-> TemperatureBundle
     (ApplicationHandle
        muxMode responderCtx peerAddr extraFlags ByteString m a b)
-> StrictTVar m ControlMessage
forall (pt :: ProtocolTemperature) (muxMode :: Mode) responderCtx
       peerAddr extraFlags bytes (m :: * -> *) a b.
SingProtocolTemperature pt
-> TemperatureBundle
     (ApplicationHandle
        muxMode responderCtx peerAddr extraFlags bytes m a b)
-> StrictTVar m ControlMessage
getControlVar SingProtocolTemperature 'Warm
SingWarm TemperatureBundle
  (ApplicationHandle
     muxMode responderCtx peerAddr extraFlags ByteString m a b)
pchAppHandles) ControlMessage
Quiesce
            StrictTVar m PeerStatus -> PeerStatus -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m PeerStatus
pchPeerStatus PeerStatus
PeerHot
            m () -> STM m (m ())
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return (m () -> STM m (m ())) -> m () -> STM m (m ())
forall a b. (a -> b) -> a -> b
$ () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

          PeerStatus
_otherwise -> m () -> STM m (m ())
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return do
            Tracer m (PeerSelectionActionsTrace peerAddr versionNumber)
-> PeerSelectionActionsTrace peerAddr versionNumber -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (PeerSelectionActionsTrace peerAddr versionNumber)
spsTracer (PeerStatusChangeType peerAddr
-> FailureType versionNumber
-> PeerSelectionActionsTrace peerAddr versionNumber
forall peerAddr vNumber.
PeerStatusChangeType peerAddr
-> FailureType vNumber
-> PeerSelectionActionsTrace peerAddr vNumber
PeerStatusChangeFailure
                                  (ConnectionId peerAddr -> PeerStatusChangeType peerAddr
forall peerAddr.
ConnectionId peerAddr -> PeerStatusChangeType peerAddr
WarmToHot ConnectionId peerAddr
pchConnectionId)
                                  (PeerStatus -> FailureType versionNumber
forall versionNumber. PeerStatus -> FailureType versionNumber
ActiveCold PeerStatus
peerStatus))
            ColdActionException peerAddr -> m ()
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (ColdActionException peerAddr -> m ())
-> ColdActionException peerAddr -> m ()
forall a b. (a -> b) -> a -> b
$ ConnectionId peerAddr -> ColdActionException peerAddr
forall peerAddr.
ConnectionId peerAddr -> ColdActionException peerAddr
ColdActivationException ConnectionId peerAddr
pchConnectionId

      SingProtocolTemperature 'Hot
-> IsBigLedgerPeer
-> extraFlags
-> PeerConnectionHandle
     muxMode
     responderCtx
     peerAddr
     extraFlags
     versionData
     ByteString
     m
     a
     b
-> m ()
forall (muxMode :: Mode) (pt :: ProtocolTemperature) responderCtx
       peerAddr extraFlags versionData (m :: * -> *) a b.
(Alternative (STM m), MonadAsync m, MonadCatch m,
 MonadThrow (STM m), HasInitiator muxMode ~ 'True) =>
SingProtocolTemperature pt
-> IsBigLedgerPeer
-> extraFlags
-> PeerConnectionHandle
     muxMode
     responderCtx
     peerAddr
     extraFlags
     versionData
     ByteString
     m
     a
     b
-> m ()
startProtocols SingProtocolTemperature 'Hot
SingHot IsBigLedgerPeer
isBigLedgerPeer extraFlags
extraFlags PeerConnectionHandle
  muxMode
  responderCtx
  peerAddr
  extraFlags
  versionData
  ByteString
  m
  a
  b
connHandle
      STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> (Time -> STM m ()) -> Time -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrictTVar m (Maybe Time) -> Maybe Time -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (Maybe Time)
pchPromotedHotVar (Maybe Time -> STM m ())
-> (Time -> Maybe Time) -> Time -> STM m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Time -> Maybe Time
forall a. a -> Maybe a
Just (Time -> Maybe Time) -> Time -> Maybe Time
forall a b. (a -> b) -> a -> b
$!) (Time -> m ()) -> m Time -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime
      Tracer m (PeerSelectionActionsTrace peerAddr versionNumber)
-> PeerSelectionActionsTrace peerAddr versionNumber -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (PeerSelectionActionsTrace peerAddr versionNumber)
spsTracer (PeerStatusChangeType peerAddr
-> PeerSelectionActionsTrace peerAddr versionNumber
forall peerAddr vNumber.
PeerStatusChangeType peerAddr
-> PeerSelectionActionsTrace peerAddr vNumber
PeerStatusChanged (ConnectionId peerAddr -> PeerStatusChangeType peerAddr
forall peerAddr.
ConnectionId peerAddr -> PeerStatusChangeType peerAddr
WarmToHot ConnectionId peerAddr
pchConnectionId))


    -- Take a hot peer and demote it to a warm one.
    -- this can be raced by 'peerMonitoringLoop' and peer selection demotion activity
    deactivatePeerConnection :: PeerConnectionHandle muxMode responderCtx peerAddr extraFlags versionData ByteString m a b -> m ()
    deactivatePeerConnection :: PeerConnectionHandle
  muxMode
  responderCtx
  peerAddr
  extraFlags
  versionData
  ByteString
  m
  a
  b
-> m ()
deactivatePeerConnection
        pch :: PeerConnectionHandle
  muxMode
  responderCtx
  peerAddr
  extraFlags
  versionData
  ByteString
  m
  a
  b
pch@PeerConnectionHandle {
            ConnectionId peerAddr
pchConnectionId :: forall (muxMode :: Mode) responderCtx peerAddr extraFlags
       versionData bytes (m :: * -> *) a b.
PeerConnectionHandle
  muxMode responderCtx peerAddr extraFlags versionData bytes m a b
-> ConnectionId peerAddr
pchConnectionId :: ConnectionId peerAddr
pchConnectionId,
            StrictTVar m PeerStatus
pchPeerStatus :: forall (muxMode :: Mode) responderCtx peerAddr extraFlags
       versionData bytes (m :: * -> *) a b.
PeerConnectionHandle
  muxMode responderCtx peerAddr extraFlags versionData bytes m a b
-> StrictTVar m PeerStatus
pchPeerStatus :: StrictTVar m PeerStatus
pchPeerStatus,
            Mux muxMode m
pchMux :: forall (muxMode :: Mode) responderCtx peerAddr extraFlags
       versionData bytes (m :: * -> *) a b.
PeerConnectionHandle
  muxMode responderCtx peerAddr extraFlags versionData bytes m a b
-> Mux muxMode m
pchMux :: Mux muxMode m
pchMux,
            TemperatureBundle
  (ApplicationHandle
     muxMode responderCtx peerAddr extraFlags ByteString m a b)
pchAppHandles :: forall (muxMode :: Mode) responderCtx peerAddr extraFlags
       versionData bytes (m :: * -> *) a b.
PeerConnectionHandle
  muxMode responderCtx peerAddr extraFlags versionData bytes m a b
-> TemperatureBundle
     (ApplicationHandle
        muxMode responderCtx peerAddr extraFlags bytes m a b)
pchAppHandles :: TemperatureBundle
  (ApplicationHandle
     muxMode responderCtx peerAddr extraFlags ByteString m a b)
pchAppHandles
          } = do
      m (m ()) -> m ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (m (m ()) -> m ())
-> (STM m (m ()) -> m (m ())) -> STM m (m ()) -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM m (m ()) -> m (m ())
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (m ()) -> m ()) -> STM m (m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ do
        peerStatus <- StrictTVar m PeerStatus -> STM m PeerStatus
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m PeerStatus
pchPeerStatus
        case peerStatus of
          PeerStatus
PeerHot -> do
            StrictTVar m ControlMessage -> ControlMessage -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> a -> STM m ()
writeTVar (SingProtocolTemperature 'Hot
-> TemperatureBundle
     (ApplicationHandle
        muxMode responderCtx peerAddr extraFlags ByteString m a b)
-> StrictTVar m ControlMessage
forall (pt :: ProtocolTemperature) (muxMode :: Mode) responderCtx
       peerAddr extraFlags bytes (m :: * -> *) a b.
SingProtocolTemperature pt
-> TemperatureBundle
     (ApplicationHandle
        muxMode responderCtx peerAddr extraFlags bytes m a b)
-> StrictTVar m ControlMessage
getControlVar SingProtocolTemperature 'Hot
SingHot TemperatureBundle
  (ApplicationHandle
     muxMode responderCtx peerAddr extraFlags ByteString m a b)
pchAppHandles) ControlMessage
Terminate
            StrictTVar m ControlMessage -> ControlMessage -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> a -> STM m ()
writeTVar (SingProtocolTemperature 'Warm
-> TemperatureBundle
     (ApplicationHandle
        muxMode responderCtx peerAddr extraFlags ByteString m a b)
-> StrictTVar m ControlMessage
forall (pt :: ProtocolTemperature) (muxMode :: Mode) responderCtx
       peerAddr extraFlags bytes (m :: * -> *) a b.
SingProtocolTemperature pt
-> TemperatureBundle
     (ApplicationHandle
        muxMode responderCtx peerAddr extraFlags bytes m a b)
-> StrictTVar m ControlMessage
getControlVar SingProtocolTemperature 'Warm
SingWarm TemperatureBundle
  (ApplicationHandle
     muxMode responderCtx peerAddr extraFlags ByteString m a b)
pchAppHandles) ControlMessage
Continue
            m () -> STM m (m ())
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return do
              -- Hot protocols should stop within 'spsDeactivateTimeout'.
              res <-
                DiffTime -> m () -> m (Maybe ())
forall a. DiffTime -> m a -> m (Maybe a)
forall (m :: * -> *) a.
MonadTimer m =>
DiffTime -> m a -> m (Maybe a)
timeout DiffTime
spsDeactivateTimeout
                      (m () -> m (Maybe ())) -> m () -> m (Maybe ())
forall a b. (a -> b) -> a -> b
$ m (m ()) -> m ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (m (m ()) -> m ())
-> (STM m (m ()) -> m (m ())) -> STM m (m ()) -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM m (m ()) -> m (m ())
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (m ()) -> m ()) -> STM m (m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ do
                          res <- SingProtocolTemperature 'Hot
-> TemperatureBundle
     (ApplicationHandle
        muxMode responderCtx peerAddr extraFlags ByteString m a b)
-> STM m (LastToFinishResult a)
forall (m :: * -> *) (pt :: ProtocolTemperature) (muxMude :: Mode)
       responderCtx peerAddr extraFlags bytes a b.
MonadSTM m =>
SingProtocolTemperature pt
-> TemperatureBundle
     (ApplicationHandle
        muxMude responderCtx peerAddr extraFlags bytes m a b)
-> STM m (LastToFinishResult a)
awaitAllResults SingProtocolTemperature 'Hot
SingHot TemperatureBundle
  (ApplicationHandle
     muxMode responderCtx peerAddr extraFlags ByteString m a b)
pchAppHandles
                          case res of
                            AllSucceeded Map MiniProtocolNum a
results -> do
                              StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))
-> (Map MiniProtocolNum (STM m (HasReturned a))
    -> Map MiniProtocolNum (STM m (HasReturned a)))
-> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar (SingProtocolTemperature 'Hot
-> TemperatureBundle
     (ApplicationHandle
        muxMode responderCtx peerAddr extraFlags ByteString m a b)
-> StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))
forall (pt :: ProtocolTemperature) (muxMode :: Mode) responderCtx
       peerAddr extraFlags bytes (m :: * -> *) a b.
SingProtocolTemperature pt
-> TemperatureBundle
     (ApplicationHandle
        muxMode responderCtx peerAddr extraFlags bytes m a b)
-> StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))
getMiniProtocolsVar SingProtocolTemperature 'Hot
SingHot TemperatureBundle
  (ApplicationHandle
     muxMode responderCtx peerAddr extraFlags ByteString m a b)
pchAppHandles)
                                         (\Map MiniProtocolNum (STM m (HasReturned a))
_ -> (a -> STM m (HasReturned a))
-> Map MiniProtocolNum a
-> Map MiniProtocolNum (STM m (HasReturned a))
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (HasReturned a -> STM m (HasReturned a)
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HasReturned a -> STM m (HasReturned a))
-> (a -> HasReturned a) -> a -> STM m (HasReturned a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either SomeException a -> HasReturned a
forall a. Either SomeException a -> HasReturned a
NotRunning (Either SomeException a -> HasReturned a)
-> (a -> Either SomeException a) -> a -> HasReturned a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either SomeException a
forall a b. b -> Either a b
Right) Map MiniProtocolNum a
results)
                              StrictTVar m PeerStatus
-> (PeerStatus -> (m (), PeerStatus)) -> STM m (m ())
forall (m :: * -> *) s a.
MonadSTM m =>
StrictTVar m s -> (s -> (a, s)) -> STM m a
stateTVar StrictTVar m PeerStatus
pchPeerStatus \case
                                PeerStatus
PeerHot -> (  Tracer m (PeerSelectionActionsTrace peerAddr versionNumber)
-> PeerSelectionActionsTrace peerAddr versionNumber -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (PeerSelectionActionsTrace peerAddr versionNumber)
spsTracer (PeerStatusChangeType peerAddr
-> PeerSelectionActionsTrace peerAddr versionNumber
forall peerAddr vNumber.
PeerStatusChangeType peerAddr
-> PeerSelectionActionsTrace peerAddr vNumber
PeerStatusChanged
                                                                    (ConnectionId peerAddr -> PeerStatusChangeType peerAddr
forall peerAddr.
ConnectionId peerAddr -> PeerStatusChangeType peerAddr
HotToWarm ConnectionId peerAddr
pchConnectionId))
                                           ,  PeerStatus
PeerWarm)
                                PeerStatus
x       -> (() -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure () , PeerStatus
x)
                            SomeErrored [MiniProtocolException]
errs ->
                              StrictTVar m PeerStatus
-> (PeerStatus -> (m (), PeerStatus)) -> STM m (m ())
forall (m :: * -> *) s a.
MonadSTM m =>
StrictTVar m s -> (s -> (a, s)) -> STM m a
stateTVar StrictTVar m PeerStatus
pchPeerStatus \PeerStatus
status ->
                                if PeerStatus
status PeerStatus -> PeerStatus -> Bool
forall a. Ord a => a -> a -> Bool
<= PeerStatus
PeerCooling then
                                     (MiniProtocolExceptions -> m ()
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO ([MiniProtocolException] -> MiniProtocolExceptions
MiniProtocolExceptions [MiniProtocolException]
errs), PeerStatus
status)
                                else (  Tracer m (PeerSelectionActionsTrace peerAddr versionNumber)
-> PeerSelectionActionsTrace peerAddr versionNumber -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (PeerSelectionActionsTrace peerAddr versionNumber)
spsTracer (PeerStatusChangeType peerAddr
-> FailureType versionNumber
-> PeerSelectionActionsTrace peerAddr versionNumber
forall peerAddr vNumber.
PeerStatusChangeType peerAddr
-> FailureType vNumber
-> PeerSelectionActionsTrace peerAddr vNumber
PeerStatusChangeFailure
                                                              (ConnectionId peerAddr -> PeerStatusChangeType peerAddr
forall peerAddr.
ConnectionId peerAddr -> PeerStatusChangeType peerAddr
HotToCooling ConnectionId peerAddr
pchConnectionId)
                                                              ([MiniProtocolException] -> FailureType versionNumber
forall versionNumber.
[MiniProtocolException] -> FailureType versionNumber
ApplicationFailure [MiniProtocolException]
errs))
                                        m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MiniProtocolExceptions -> m ()
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO ([MiniProtocolException] -> MiniProtocolExceptions
MiniProtocolExceptions [MiniProtocolException]
errs)
                                     ,  PeerStatus
PeerCooling)

              case res of
                Maybe ()
Nothing -> do
                  Mux muxMode m -> m ()
forall (m :: * -> *) (mode :: Mode).
MonadSTM m =>
Mux mode m -> m ()
Mux.stop Mux muxMode m
pchMux
                  trace <- STM m Bool -> m Bool
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m Bool -> m Bool) -> STM m Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ StrictTVar m PeerStatus -> PeerStatus -> STM m Bool
updateUnlessCoolingOrCold StrictTVar m PeerStatus
pchPeerStatus PeerStatus
PeerCooling
                  when trace do
                    traceWith spsTracer (PeerStatusChangeFailure
                                          (HotToCooling pchConnectionId)
                                          TimeoutError)
                  throwIO (DeactivationTimeout pchConnectionId)
                Just ()
_ -> PeerConnectionHandle
  muxMode
  responderCtx
  peerAddr
  extraFlags
  versionData
  ByteString
  m
  a
  b
-> m ()
forall bytes.
PeerConnectionHandle
  muxMode responderCtx peerAddr extraFlags versionData bytes m a b
-> m ()
tracePeerHotDuration PeerConnectionHandle
  muxMode
  responderCtx
  peerAddr
  extraFlags
  versionData
  ByteString
  m
  a
  b
pch

          -- we could genuinly hit this case due to a race between 'peerMonitoringLoop'
          -- and peer selection demotion job
          PeerStatus
PeerWarm -> m () -> STM m (m ())
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return (m () -> STM m (m ())) -> m () -> STM m (m ())
forall a b. (a -> b) -> a -> b
$ () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

          PeerStatus
_otherwise ->
            m () -> STM m (m ())
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return (m () -> STM m (m ())) -> m () -> STM m (m ())
forall a b. (a -> b) -> a -> b
$ do
              Tracer m (PeerSelectionActionsTrace peerAddr versionNumber)
-> PeerSelectionActionsTrace peerAddr versionNumber -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (PeerSelectionActionsTrace peerAddr versionNumber)
spsTracer (PeerStatusChangeType peerAddr
-> FailureType versionNumber
-> PeerSelectionActionsTrace peerAddr versionNumber
forall peerAddr vNumber.
PeerStatusChangeType peerAddr
-> FailureType vNumber
-> PeerSelectionActionsTrace peerAddr vNumber
PeerStatusChangeFailure
                                    (ConnectionId peerAddr -> PeerStatusChangeType peerAddr
forall peerAddr.
ConnectionId peerAddr -> PeerStatusChangeType peerAddr
HotToWarm ConnectionId peerAddr
pchConnectionId)
                                    (PeerStatus -> FailureType versionNumber
forall versionNumber. PeerStatus -> FailureType versionNumber
ActiveCold PeerStatus
peerStatus))
              ColdActionException peerAddr -> m ()
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (ColdActionException peerAddr -> m ())
-> ColdActionException peerAddr -> m ()
forall a b. (a -> b) -> a -> b
$ ConnectionId peerAddr -> ColdActionException peerAddr
forall peerAddr.
ConnectionId peerAddr -> ColdActionException peerAddr
ColdDeactivationException ConnectionId peerAddr
pchConnectionId


    closePeerConnection :: PeerConnectionHandle muxMode responderCtx peerAddr extraFlags versionData ByteString m a b
                        -> m PeerStatus
    closePeerConnection :: PeerConnectionHandle
  muxMode
  responderCtx
  peerAddr
  extraFlags
  versionData
  ByteString
  m
  a
  b
-> m PeerStatus
closePeerConnection
        PeerConnectionHandle {
            ConnectionId peerAddr
pchConnectionId :: forall (muxMode :: Mode) responderCtx peerAddr extraFlags
       versionData bytes (m :: * -> *) a b.
PeerConnectionHandle
  muxMode responderCtx peerAddr extraFlags versionData bytes m a b
-> ConnectionId peerAddr
pchConnectionId :: ConnectionId peerAddr
pchConnectionId,
            StrictTVar m PeerStatus
pchPeerStatus :: forall (muxMode :: Mode) responderCtx peerAddr extraFlags
       versionData bytes (m :: * -> *) a b.
PeerConnectionHandle
  muxMode responderCtx peerAddr extraFlags versionData bytes m a b
-> StrictTVar m PeerStatus
pchPeerStatus :: StrictTVar m PeerStatus
pchPeerStatus,
            TemperatureBundle
  (ApplicationHandle
     muxMode responderCtx peerAddr extraFlags ByteString m a b)
pchAppHandles :: forall (muxMode :: Mode) responderCtx peerAddr extraFlags
       versionData bytes (m :: * -> *) a b.
PeerConnectionHandle
  muxMode responderCtx peerAddr extraFlags versionData bytes m a b
-> TemperatureBundle
     (ApplicationHandle
        muxMode responderCtx peerAddr extraFlags bytes m a b)
pchAppHandles :: TemperatureBundle
  (ApplicationHandle
     muxMode responderCtx peerAddr extraFlags ByteString m a b)
pchAppHandles,
            Mux muxMode m
pchMux :: forall (muxMode :: Mode) responderCtx peerAddr extraFlags
       versionData bytes (m :: * -> *) a b.
PeerConnectionHandle
  muxMode responderCtx peerAddr extraFlags versionData bytes m a b
-> Mux muxMode m
pchMux :: Mux muxMode m
pchMux
          } = do
      peerStatus <- STM m PeerStatus -> m PeerStatus
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically do
        StrictTVar m ControlMessage -> ControlMessage -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> a -> STM m ()
writeTVar (SingProtocolTemperature 'Warm
-> TemperatureBundle
     (ApplicationHandle
        muxMode responderCtx peerAddr extraFlags ByteString m a b)
-> StrictTVar m ControlMessage
forall (pt :: ProtocolTemperature) (muxMode :: Mode) responderCtx
       peerAddr extraFlags bytes (m :: * -> *) a b.
SingProtocolTemperature pt
-> TemperatureBundle
     (ApplicationHandle
        muxMode responderCtx peerAddr extraFlags bytes m a b)
-> StrictTVar m ControlMessage
getControlVar SingProtocolTemperature 'Warm
SingWarm TemperatureBundle
  (ApplicationHandle
     muxMode responderCtx peerAddr extraFlags ByteString m a b)
pchAppHandles) ControlMessage
Terminate
        StrictTVar m ControlMessage -> ControlMessage -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> a -> STM m ()
writeTVar (SingProtocolTemperature 'Established
-> TemperatureBundle
     (ApplicationHandle
        muxMode responderCtx peerAddr extraFlags ByteString m a b)
-> StrictTVar m ControlMessage
forall (pt :: ProtocolTemperature) (muxMode :: Mode) responderCtx
       peerAddr extraFlags bytes (m :: * -> *) a b.
SingProtocolTemperature pt
-> TemperatureBundle
     (ApplicationHandle
        muxMode responderCtx peerAddr extraFlags bytes m a b)
-> StrictTVar m ControlMessage
getControlVar SingProtocolTemperature 'Established
SingEstablished TemperatureBundle
  (ApplicationHandle
     muxMode responderCtx peerAddr extraFlags ByteString m a b)
pchAppHandles) ControlMessage
Terminate
        StrictTVar m ControlMessage -> ControlMessage -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> a -> STM m ()
writeTVar (SingProtocolTemperature 'Hot
-> TemperatureBundle
     (ApplicationHandle
        muxMode responderCtx peerAddr extraFlags ByteString m a b)
-> StrictTVar m ControlMessage
forall (pt :: ProtocolTemperature) (muxMode :: Mode) responderCtx
       peerAddr extraFlags bytes (m :: * -> *) a b.
SingProtocolTemperature pt
-> TemperatureBundle
     (ApplicationHandle
        muxMode responderCtx peerAddr extraFlags bytes m a b)
-> StrictTVar m ControlMessage
getControlVar SingProtocolTemperature 'Hot
SingHot TemperatureBundle
  (ApplicationHandle
     muxMode responderCtx peerAddr extraFlags ByteString m a b)
pchAppHandles) ControlMessage
Terminate
        StrictTVar m PeerStatus -> STM m PeerStatus
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m PeerStatus
pchPeerStatus STM m PeerStatus -> STM m Bool -> STM m PeerStatus
forall a b. STM m a -> STM m b -> STM m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* StrictTVar m PeerStatus -> PeerStatus -> STM m Bool
updateUnlessCoolingOrCold StrictTVar m PeerStatus
pchPeerStatus PeerStatus
PeerCooling

      case peerStatus of
        PeerStatus
PeerCooling -> PeerStatus -> m PeerStatus
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return PeerStatus
peerStatus
        PeerStatus
PeerCold    -> PeerStatus -> m PeerStatus
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return PeerStatus
peerStatus
        PeerStatus
_otherwise  -> do
          res <-
            DiffTime
-> m (LastToFinishResult a) -> m (Maybe (LastToFinishResult a))
forall a. DiffTime -> m a -> m (Maybe a)
forall (m :: * -> *) a.
MonadTimer m =>
DiffTime -> m a -> m (Maybe a)
timeout DiffTime
spsCloseConnectionTimeout
                    (STM m (LastToFinishResult a) -> m (LastToFinishResult a)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (LastToFinishResult a) -> m (LastToFinishResult a))
-> STM m (LastToFinishResult a) -> m (LastToFinishResult a)
forall a b. (a -> b) -> a -> b
$
                      (\LastToFinishResult a
a LastToFinishResult a
b LastToFinishResult a
c -> LastToFinishResult a
a LastToFinishResult a
-> LastToFinishResult a -> LastToFinishResult a
forall a. Semigroup a => a -> a -> a
<> LastToFinishResult a
b LastToFinishResult a
-> LastToFinishResult a -> LastToFinishResult a
forall a. Semigroup a => a -> a -> a
<> LastToFinishResult a
c)
                        -- note: we use last to finish on hot, warm and
                        -- established mini-protocols since 'closePeerConnection'
                        -- is also used by asynchronous demotions, not just
                        -- /warm → cold/ transition.
                        (LastToFinishResult a
 -> LastToFinishResult a
 -> LastToFinishResult a
 -> LastToFinishResult a)
-> STM m (LastToFinishResult a)
-> STM
     m
     (LastToFinishResult a
      -> LastToFinishResult a -> LastToFinishResult a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SingProtocolTemperature 'Hot
-> TemperatureBundle
     (ApplicationHandle
        muxMode responderCtx peerAddr extraFlags ByteString m a b)
-> STM m (LastToFinishResult a)
forall (m :: * -> *) (pt :: ProtocolTemperature) (muxMude :: Mode)
       responderCtx peerAddr extraFlags bytes a b.
MonadSTM m =>
SingProtocolTemperature pt
-> TemperatureBundle
     (ApplicationHandle
        muxMude responderCtx peerAddr extraFlags bytes m a b)
-> STM m (LastToFinishResult a)
awaitAllResults SingProtocolTemperature 'Hot
SingHot TemperatureBundle
  (ApplicationHandle
     muxMode responderCtx peerAddr extraFlags ByteString m a b)
pchAppHandles
                        STM
  m
  (LastToFinishResult a
   -> LastToFinishResult a -> LastToFinishResult a)
-> STM m (LastToFinishResult a)
-> STM m (LastToFinishResult a -> LastToFinishResult a)
forall a b. STM m (a -> b) -> STM m a -> STM m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SingProtocolTemperature 'Warm
-> TemperatureBundle
     (ApplicationHandle
        muxMode responderCtx peerAddr extraFlags ByteString m a b)
-> STM m (LastToFinishResult a)
forall (m :: * -> *) (pt :: ProtocolTemperature) (muxMude :: Mode)
       responderCtx peerAddr extraFlags bytes a b.
MonadSTM m =>
SingProtocolTemperature pt
-> TemperatureBundle
     (ApplicationHandle
        muxMude responderCtx peerAddr extraFlags bytes m a b)
-> STM m (LastToFinishResult a)
awaitAllResults SingProtocolTemperature 'Warm
SingWarm TemperatureBundle
  (ApplicationHandle
     muxMode responderCtx peerAddr extraFlags ByteString m a b)
pchAppHandles
                        STM m (LastToFinishResult a -> LastToFinishResult a)
-> STM m (LastToFinishResult a) -> STM m (LastToFinishResult a)
forall a b. STM m (a -> b) -> STM m a -> STM m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SingProtocolTemperature 'Established
-> TemperatureBundle
     (ApplicationHandle
        muxMode responderCtx peerAddr extraFlags ByteString m a b)
-> STM m (LastToFinishResult a)
forall (m :: * -> *) (pt :: ProtocolTemperature) (muxMude :: Mode)
       responderCtx peerAddr extraFlags bytes a b.
MonadSTM m =>
SingProtocolTemperature pt
-> TemperatureBundle
     (ApplicationHandle
        muxMude responderCtx peerAddr extraFlags bytes m a b)
-> STM m (LastToFinishResult a)
awaitAllResults SingProtocolTemperature 'Established
SingEstablished TemperatureBundle
  (ApplicationHandle
     muxMode responderCtx peerAddr extraFlags ByteString m a b)
pchAppHandles)

          PeerCooling <$ case res of
            Maybe (LastToFinishResult a)
Nothing -> do
              -- timeout fired
              Mux muxMode m -> m ()
forall (m :: * -> *) (mode :: Mode).
MonadSTM m =>
Mux mode m -> m ()
Mux.stop Mux muxMode m
pchMux
              Tracer m (PeerSelectionActionsTrace peerAddr versionNumber)
-> PeerSelectionActionsTrace peerAddr versionNumber -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (PeerSelectionActionsTrace peerAddr versionNumber)
spsTracer (PeerStatusChangeType peerAddr
-> FailureType versionNumber
-> PeerSelectionActionsTrace peerAddr versionNumber
forall peerAddr vNumber.
PeerStatusChangeType peerAddr
-> FailureType vNumber
-> PeerSelectionActionsTrace peerAddr vNumber
PeerStatusChangeFailure
                                    (ConnectionId peerAddr -> PeerStatusChangeType peerAddr
forall peerAddr.
ConnectionId peerAddr -> PeerStatusChangeType peerAddr
WarmToCooling ConnectionId peerAddr
pchConnectionId)
                                    FailureType versionNumber
forall versionNumber. FailureType versionNumber
TimeoutError)

            Just (SomeErrored [MiniProtocolException]
errs) -> do
              -- some mini-protocol errored
              --
              -- we don't need to notify the connection manager, we can instead
              -- rely on mux property: if any of the mini-protocols errors, mux
              -- throws an exception as well.
              Tracer m (PeerSelectionActionsTrace peerAddr versionNumber)
-> PeerSelectionActionsTrace peerAddr versionNumber -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (PeerSelectionActionsTrace peerAddr versionNumber)
spsTracer (PeerStatusChangeType peerAddr
-> FailureType versionNumber
-> PeerSelectionActionsTrace peerAddr versionNumber
forall peerAddr vNumber.
PeerStatusChangeType peerAddr
-> FailureType vNumber
-> PeerSelectionActionsTrace peerAddr vNumber
PeerStatusChangeFailure
                                     (ConnectionId peerAddr -> PeerStatusChangeType peerAddr
forall peerAddr.
ConnectionId peerAddr -> PeerStatusChangeType peerAddr
WarmToCooling ConnectionId peerAddr
pchConnectionId)
                                     ([MiniProtocolException] -> FailureType versionNumber
forall versionNumber.
[MiniProtocolException] -> FailureType versionNumber
ApplicationFailure [MiniProtocolException]
errs))
              MiniProtocolExceptions -> m ()
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO ([MiniProtocolException] -> MiniProtocolExceptions
MiniProtocolExceptions [MiniProtocolException]
errs)

            Just AllSucceeded {} -> do
              -- all mini-protocols terminated cleanly
              --
              -- 'unregisterOutboundConnection' could only fail to demote the peer if
              -- connection manager would simultaneously promote it, but this is not
              -- possible.
              _ <- MuxConnectionManager
  muxMode
  socket
  (ExpandedInitiatorContext peerAddr extraFlags m)
  responderCtx
  peerAddr
  versionData
  versionNumber
  ByteString
  m
  a
  b
-> ConnectionId peerAddr -> m (OperationResult AbstractState)
forall (muxMode :: Mode) socket peerAddr handle handleError
       (m :: * -> *).
(HasInitiator muxMode ~ 'True) =>
ConnectionManager muxMode socket peerAddr handle handleError m
-> ConnectionId peerAddr -> m (OperationResult AbstractState)
releaseOutboundConnection MuxConnectionManager
  muxMode
  socket
  (ExpandedInitiatorContext peerAddr extraFlags m)
  responderCtx
  peerAddr
  versionData
  versionNumber
  ByteString
  m
  a
  b
spsConnectionManager ConnectionId peerAddr
pchConnectionId
              traceWith spsTracer (PeerStatusChanged (WarmToCooling pchConnectionId))


--
-- Utilities
--


-- | Smart constructor for 'ApplicationHandle'.
--
mkApplicationHandleBundle
    :: forall (muxMode :: Mux.Mode) responderCtx peerAddr extraFlags bytes m a b.
       OuroborosBundle muxMode (ExpandedInitiatorContext peerAddr extraFlags m)
                               responderCtx bytes m a b
    -- ^ mux application
    -> TemperatureBundle (StrictTVar m ControlMessage)
    -- ^ 'ControlMessage' bundle
    -> TemperatureBundle (StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a))))
    -- ^ await for application termination
    -> TemperatureBundle (ApplicationHandle muxMode responderCtx peerAddr extraFlags bytes m a b)
mkApplicationHandleBundle :: forall (muxMode :: Mode) responderCtx peerAddr extraFlags bytes
       (m :: * -> *) a b.
OuroborosBundle
  muxMode
  (ExpandedInitiatorContext peerAddr extraFlags m)
  responderCtx
  bytes
  m
  a
  b
-> TemperatureBundle (StrictTVar m ControlMessage)
-> TemperatureBundle
     (StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a))))
-> TemperatureBundle
     (ApplicationHandle
        muxMode responderCtx peerAddr extraFlags bytes m a b)
mkApplicationHandleBundle OuroborosBundle
  muxMode
  (ExpandedInitiatorContext peerAddr extraFlags m)
  responderCtx
  bytes
  m
  a
  b
muxBundle TemperatureBundle (StrictTVar m ControlMessage)
controlMessageBundle TemperatureBundle
  (StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a))))
awaitVarsBundle =
    WithProtocolTemperature
  'Hot
  (ApplicationHandle
     muxMode responderCtx peerAddr extraFlags bytes m a b)
-> WithProtocolTemperature
     'Warm
     (ApplicationHandle
        muxMode responderCtx peerAddr extraFlags bytes m a b)
-> WithProtocolTemperature
     'Established
     (ApplicationHandle
        muxMode responderCtx peerAddr extraFlags bytes m a b)
-> TemperatureBundle
     (ApplicationHandle
        muxMode responderCtx peerAddr extraFlags bytes m a b)
forall a.
WithProtocolTemperature 'Hot a
-> WithProtocolTemperature 'Warm a
-> WithProtocolTemperature 'Established a
-> TemperatureBundle a
TemperatureBundle
      (SingProtocolTemperature 'Hot
-> WithProtocolTemperature
     'Hot
     (ApplicationHandle
        muxMode responderCtx peerAddr extraFlags bytes m a b)
forall (pt :: ProtocolTemperature).
SingProtocolTemperature pt
-> WithProtocolTemperature
     pt
     (ApplicationHandle
        muxMode responderCtx peerAddr extraFlags bytes m a b)
mkApplication SingProtocolTemperature 'Hot
SingHot)
      (SingProtocolTemperature 'Warm
-> WithProtocolTemperature
     'Warm
     (ApplicationHandle
        muxMode responderCtx peerAddr extraFlags bytes m a b)
forall (pt :: ProtocolTemperature).
SingProtocolTemperature pt
-> WithProtocolTemperature
     pt
     (ApplicationHandle
        muxMode responderCtx peerAddr extraFlags bytes m a b)
mkApplication SingProtocolTemperature 'Warm
SingWarm)
      (SingProtocolTemperature 'Established
-> WithProtocolTemperature
     'Established
     (ApplicationHandle
        muxMode responderCtx peerAddr extraFlags bytes m a b)
forall (pt :: ProtocolTemperature).
SingProtocolTemperature pt
-> WithProtocolTemperature
     pt
     (ApplicationHandle
        muxMode responderCtx peerAddr extraFlags bytes m a b)
mkApplication SingProtocolTemperature 'Established
SingEstablished)
  where
    mkApplication :: SingProtocolTemperature pt
                  -> WithProtocolTemperature pt (ApplicationHandle muxMode responderCtx peerAddr extraFlags bytes m a b)
    mkApplication :: forall (pt :: ProtocolTemperature).
SingProtocolTemperature pt
-> WithProtocolTemperature
     pt
     (ApplicationHandle
        muxMode responderCtx peerAddr extraFlags bytes m a b)
mkApplication SingProtocolTemperature pt
tok =
      let app :: ApplicationHandle
  muxMode responderCtx peerAddr extraFlags bytes m a b
app =
            ApplicationHandle {
              ahApplication :: [MiniProtocol
   muxMode
   (ExpandedInitiatorContext peerAddr extraFlags m)
   responderCtx
   bytes
   m
   a
   b]
ahApplication         = SingProtocolTemperature pt
-> OuroborosBundle
     muxMode
     (ExpandedInitiatorContext peerAddr extraFlags m)
     responderCtx
     bytes
     m
     a
     b
-> [MiniProtocol
      muxMode
      (ExpandedInitiatorContext peerAddr extraFlags m)
      responderCtx
      bytes
      m
      a
      b]
forall (pt :: ProtocolTemperature) a.
SingProtocolTemperature pt -> TemperatureBundle a -> a
projectBundle SingProtocolTemperature pt
tok OuroborosBundle
  muxMode
  (ExpandedInitiatorContext peerAddr extraFlags m)
  responderCtx
  bytes
  m
  a
  b
muxBundle,
              ahControlVar :: StrictTVar m ControlMessage
ahControlVar          = SingProtocolTemperature pt
-> TemperatureBundle (StrictTVar m ControlMessage)
-> StrictTVar m ControlMessage
forall (pt :: ProtocolTemperature) a.
SingProtocolTemperature pt -> TemperatureBundle a -> a
projectBundle SingProtocolTemperature pt
tok TemperatureBundle (StrictTVar m ControlMessage)
controlMessageBundle,
              ahMiniProtocolResults :: StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))
ahMiniProtocolResults = SingProtocolTemperature pt
-> TemperatureBundle
     (StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a))))
-> StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))
forall (pt :: ProtocolTemperature) a.
SingProtocolTemperature pt -> TemperatureBundle a -> a
projectBundle SingProtocolTemperature pt
tok TemperatureBundle
  (StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a))))
awaitVarsBundle
            }
      in case SingProtocolTemperature pt
tok of
          SingProtocolTemperature pt
SingHot         -> ApplicationHandle
  muxMode responderCtx peerAddr extraFlags bytes m a b
-> WithProtocolTemperature
     'Hot
     (ApplicationHandle
        muxMode responderCtx peerAddr extraFlags bytes m a b)
forall a. a -> WithProtocolTemperature 'Hot a
WithHot ApplicationHandle
  muxMode responderCtx peerAddr extraFlags bytes m a b
app
          SingProtocolTemperature pt
SingWarm        -> ApplicationHandle
  muxMode responderCtx peerAddr extraFlags bytes m a b
-> WithProtocolTemperature
     'Warm
     (ApplicationHandle
        muxMode responderCtx peerAddr extraFlags bytes m a b)
forall a. a -> WithProtocolTemperature 'Warm a
WithWarm ApplicationHandle
  muxMode responderCtx peerAddr extraFlags bytes m a b
app
          SingProtocolTemperature pt
SingEstablished -> ApplicationHandle
  muxMode responderCtx peerAddr extraFlags bytes m a b
-> WithProtocolTemperature
     'Established
     (ApplicationHandle
        muxMode responderCtx peerAddr extraFlags bytes m a b)
forall a. a -> WithProtocolTemperature 'Established a
WithEstablished ApplicationHandle
  muxMode responderCtx peerAddr extraFlags bytes m a b
app


-- | Given a singleton 'SingProtocolTemperature' and 'PeerConnectionHandle' start the mux
-- protocol bundle indicated by the type of the first argument.
--
startProtocols :: forall (muxMode :: Mux.Mode) (pt :: ProtocolTemperature)
                         responderCtx peerAddr extraFlags versionData m a b.
                  ( Alternative (STM m)
                  , MonadAsync m
                  , MonadCatch m
                  , MonadThrow (STM m)
                  , HasInitiator muxMode ~ True
                  )
               => SingProtocolTemperature pt
               -> IsBigLedgerPeer
               -> extraFlags
               -> PeerConnectionHandle muxMode responderCtx peerAddr extraFlags versionData ByteString m a b
               -> m ()
startProtocols :: forall (muxMode :: Mode) (pt :: ProtocolTemperature) responderCtx
       peerAddr extraFlags versionData (m :: * -> *) a b.
(Alternative (STM m), MonadAsync m, MonadCatch m,
 MonadThrow (STM m), HasInitiator muxMode ~ 'True) =>
SingProtocolTemperature pt
-> IsBigLedgerPeer
-> extraFlags
-> PeerConnectionHandle
     muxMode
     responderCtx
     peerAddr
     extraFlags
     versionData
     ByteString
     m
     a
     b
-> m ()
startProtocols SingProtocolTemperature pt
tok IsBigLedgerPeer
isBigLedgerPeer extraFlags
extraFlags connHandle :: PeerConnectionHandle
  muxMode
  responderCtx
  peerAddr
  extraFlags
  versionData
  ByteString
  m
  a
  b
connHandle@PeerConnectionHandle { Mux muxMode m
pchMux :: forall (muxMode :: Mode) responderCtx peerAddr extraFlags
       versionData bytes (m :: * -> *) a b.
PeerConnectionHandle
  muxMode responderCtx peerAddr extraFlags versionData bytes m a b
-> Mux muxMode m
pchMux :: Mux muxMode m
pchMux, TemperatureBundle
  (ApplicationHandle
     muxMode responderCtx peerAddr extraFlags ByteString m a b)
pchAppHandles :: forall (muxMode :: Mode) responderCtx peerAddr extraFlags
       versionData bytes (m :: * -> *) a b.
PeerConnectionHandle
  muxMode responderCtx peerAddr extraFlags versionData bytes m a b
-> TemperatureBundle
     (ApplicationHandle
        muxMode responderCtx peerAddr extraFlags bytes m a b)
pchAppHandles :: TemperatureBundle
  (ApplicationHandle
     muxMode responderCtx peerAddr extraFlags ByteString m a b)
pchAppHandles } = do
    let ptcls :: [MiniProtocol
   muxMode
   (ExpandedInitiatorContext peerAddr extraFlags m)
   responderCtx
   ByteString
   m
   a
   b]
ptcls = SingProtocolTemperature pt
-> TemperatureBundle
     (ApplicationHandle
        muxMode responderCtx peerAddr extraFlags ByteString m a b)
-> [MiniProtocol
      muxMode
      (ExpandedInitiatorContext peerAddr extraFlags m)
      responderCtx
      ByteString
      m
      a
      b]
forall (pt :: ProtocolTemperature) (muxMode :: Mode) responderCtx
       peerAddr extraFlags bytes (m :: * -> *) a b.
SingProtocolTemperature pt
-> TemperatureBundle
     (ApplicationHandle
        muxMode responderCtx peerAddr extraFlags bytes m a b)
-> [MiniProtocol
      muxMode
      (ExpandedInitiatorContext peerAddr extraFlags m)
      responderCtx
      bytes
      m
      a
      b]
getProtocols SingProtocolTemperature pt
tok TemperatureBundle
  (ApplicationHandle
     muxMode responderCtx peerAddr extraFlags ByteString m a b)
pchAppHandles
    as <- (MiniProtocol
   muxMode
   (ExpandedInitiatorContext peerAddr extraFlags m)
   responderCtx
   ByteString
   m
   a
   b
 -> m (STM m (Either SomeException a)))
-> [MiniProtocol
      muxMode
      (ExpandedInitiatorContext peerAddr extraFlags m)
      responderCtx
      ByteString
      m
      a
      b]
-> m [STM m (Either SomeException a)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse MiniProtocol
  muxMode
  (ExpandedInitiatorContext peerAddr extraFlags m)
  responderCtx
  ByteString
  m
  a
  b
-> m (STM m (Either SomeException a))
runInitiator [MiniProtocol
   muxMode
   (ExpandedInitiatorContext peerAddr extraFlags m)
   responderCtx
   ByteString
   m
   a
   b]
ptcls
    atomically $ writeTVar (getMiniProtocolsVar tok pchAppHandles)
                           (miniProtocolResults $ zip (miniProtocolNum `map` ptcls) as)
  where

    miniProtocolResults :: [(MiniProtocolNum, STM m (Either SomeException a))]
                        -> Map MiniProtocolNum (STM m (HasReturned a))
    miniProtocolResults :: [(MiniProtocolNum, STM m (Either SomeException a))]
-> Map MiniProtocolNum (STM m (HasReturned a))
miniProtocolResults = (STM m (Either SomeException a) -> STM m (HasReturned a))
-> Map MiniProtocolNum (STM m (Either SomeException a))
-> Map MiniProtocolNum (STM m (HasReturned a))
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map ((Either SomeException a -> HasReturned a)
-> STM m (Either SomeException a) -> STM m (HasReturned a)
forall a b. (a -> b) -> STM m a -> STM m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either SomeException a -> HasReturned a
forall a. Either SomeException a -> HasReturned a
hasReturnedFromEither)
                        (Map MiniProtocolNum (STM m (Either SomeException a))
 -> Map MiniProtocolNum (STM m (HasReturned a)))
-> ([(MiniProtocolNum, STM m (Either SomeException a))]
    -> Map MiniProtocolNum (STM m (Either SomeException a)))
-> [(MiniProtocolNum, STM m (Either SomeException a))]
-> Map MiniProtocolNum (STM m (HasReturned a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(MiniProtocolNum, STM m (Either SomeException a))]
-> Map MiniProtocolNum (STM m (Either SomeException a))
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList

    runInitiator :: MiniProtocol muxMode (ExpandedInitiatorContext peerAddr extraFlags m)
                                         responderCtx ByteString m a b
                 -> m (STM m (Either SomeException a))
    runInitiator :: MiniProtocol
  muxMode
  (ExpandedInitiatorContext peerAddr extraFlags m)
  responderCtx
  ByteString
  m
  a
  b
-> m (STM m (Either SomeException a))
runInitiator MiniProtocol {
                      MiniProtocolNum
miniProtocolNum :: forall (mode :: Mode) initiatorCtx responderCtx bytes (m :: * -> *)
       a b.
MiniProtocol mode initiatorCtx responderCtx bytes m a b
-> MiniProtocolNum
miniProtocolNum :: MiniProtocolNum
miniProtocolNum,
                      RunMiniProtocol
  muxMode
  (ExpandedInitiatorContext peerAddr extraFlags m)
  responderCtx
  ByteString
  m
  a
  b
miniProtocolRun :: RunMiniProtocol
  muxMode
  (ExpandedInitiatorContext peerAddr extraFlags m)
  responderCtx
  ByteString
  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
                    } =
        case RunMiniProtocol
  muxMode
  (ExpandedInitiatorContext peerAddr extraFlags m)
  responderCtx
  ByteString
  m
  a
  b
miniProtocolRun of
          InitiatorProtocolOnly MiniProtocolCb
  (ExpandedInitiatorContext peerAddr extraFlags m) ByteString m a
initiator ->
              Mux muxMode m
-> MiniProtocolNum
-> MiniProtocolDirection muxMode
-> StartOnDemandOrEagerly
-> (ByteChannel m -> m (a, Maybe ByteString))
-> m (STM m (Either SomeException a))
forall (mode :: Mode) (m :: * -> *) a.
(Alternative (STM m), MonadSTM m, MonadThrow m,
 MonadThrow (STM m)) =>
Mux mode m
-> MiniProtocolNum
-> MiniProtocolDirection mode
-> StartOnDemandOrEagerly
-> (ByteChannel m -> m (a, Maybe ByteString))
-> m (STM m (Either SomeException a))
Mux.runMiniProtocol
                Mux muxMode m
pchMux MiniProtocolNum
miniProtocolNum
                MiniProtocolDirection muxMode
MiniProtocolDirection 'InitiatorMode
Mux.InitiatorDirectionOnly
                StartOnDemandOrEagerly
Mux.StartEagerly
                (MiniProtocolCb
  (ExpandedInitiatorContext peerAddr extraFlags m) ByteString m a
-> ExpandedInitiatorContext peerAddr extraFlags m
-> ByteChannel m
-> m (a, Maybe ByteString)
forall ctx bytes (m :: * -> *) a.
MiniProtocolCb ctx bytes m a
-> ctx -> Channel m bytes -> m (a, Maybe bytes)
runMiniProtocolCb MiniProtocolCb
  (ExpandedInitiatorContext peerAddr extraFlags m) ByteString m a
initiator ExpandedInitiatorContext peerAddr extraFlags m
context)
          InitiatorAndResponderProtocol MiniProtocolCb
  (ExpandedInitiatorContext peerAddr extraFlags m) ByteString m a
initiator MiniProtocolCb responderCtx ByteString m b
_ ->
              Mux muxMode m
-> MiniProtocolNum
-> MiniProtocolDirection muxMode
-> StartOnDemandOrEagerly
-> (ByteChannel m -> m (a, Maybe ByteString))
-> m (STM m (Either SomeException a))
forall (mode :: Mode) (m :: * -> *) a.
(Alternative (STM m), MonadSTM m, MonadThrow m,
 MonadThrow (STM m)) =>
Mux mode m
-> MiniProtocolNum
-> MiniProtocolDirection mode
-> StartOnDemandOrEagerly
-> (ByteChannel m -> m (a, Maybe ByteString))
-> m (STM m (Either SomeException a))
Mux.runMiniProtocol
                Mux muxMode m
pchMux MiniProtocolNum
miniProtocolNum
                MiniProtocolDirection muxMode
MiniProtocolDirection 'InitiatorResponderMode
Mux.InitiatorDirection
                StartOnDemandOrEagerly
Mux.StartEagerly
                (MiniProtocolCb
  (ExpandedInitiatorContext peerAddr extraFlags m) ByteString m a
-> ExpandedInitiatorContext peerAddr extraFlags m
-> ByteChannel m
-> m (a, Maybe ByteString)
forall ctx bytes (m :: * -> *) a.
MiniProtocolCb ctx bytes m a
-> ctx -> Channel m bytes -> m (a, Maybe bytes)
runMiniProtocolCb MiniProtocolCb
  (ExpandedInitiatorContext peerAddr extraFlags m) ByteString m a
initiator ExpandedInitiatorContext peerAddr extraFlags m
context)
      where
        context :: ExpandedInitiatorContext peerAddr extraFlags m
        context :: ExpandedInitiatorContext peerAddr extraFlags m
context = SingProtocolTemperature pt
-> IsBigLedgerPeer
-> extraFlags
-> PeerConnectionHandle
     muxMode
     responderCtx
     peerAddr
     extraFlags
     versionData
     ByteString
     m
     a
     b
-> ExpandedInitiatorContext peerAddr extraFlags m
forall (m :: * -> *) (pt :: ProtocolTemperature) extraFlags
       (muxMode :: Mode) responderCtx peerAddr versionDat bytes a b.
MonadSTM m =>
SingProtocolTemperature pt
-> IsBigLedgerPeer
-> extraFlags
-> PeerConnectionHandle
     muxMode responderCtx peerAddr extraFlags versionDat bytes m a b
-> ExpandedInitiatorContext peerAddr extraFlags m
mkInitiatorContext SingProtocolTemperature pt
tok IsBigLedgerPeer
isBigLedgerPeer extraFlags
extraFlags PeerConnectionHandle
  muxMode
  responderCtx
  peerAddr
  extraFlags
  versionData
  ByteString
  m
  a
  b
connHandle


--
-- Trace
--

-- | Type of failure with additional exception context; We don't log handshake
-- errors as this will be done by the handshake tracer.
--
data FailureType versionNumber =
      HandshakeClientFailure !(HandshakeException versionNumber)
    | HandshakeServerFailure !(HandshakeException versionNumber)
    | HandleFailure !SomeException
    | MuxStoppedFailure
    | TimeoutError
    | ActiveCold !PeerStatus
    | ApplicationFailure ![MiniProtocolException]
  deriving Int -> FailureType versionNumber -> ShowS
[FailureType versionNumber] -> ShowS
FailureType versionNumber -> String
(Int -> FailureType versionNumber -> ShowS)
-> (FailureType versionNumber -> String)
-> ([FailureType versionNumber] -> ShowS)
-> Show (FailureType versionNumber)
forall versionNumber.
Show versionNumber =>
Int -> FailureType versionNumber -> ShowS
forall versionNumber.
Show versionNumber =>
[FailureType versionNumber] -> ShowS
forall versionNumber.
Show versionNumber =>
FailureType versionNumber -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall versionNumber.
Show versionNumber =>
Int -> FailureType versionNumber -> ShowS
showsPrec :: Int -> FailureType versionNumber -> ShowS
$cshow :: forall versionNumber.
Show versionNumber =>
FailureType versionNumber -> String
show :: FailureType versionNumber -> String
$cshowList :: forall versionNumber.
Show versionNumber =>
[FailureType versionNumber] -> ShowS
showList :: [FailureType versionNumber] -> ShowS
Show

-- | All transitions.
--
data PeerStatusChangeType peerAddr =
    -- | During the 'ColdToWarm' transition we have the remote address, and only
    -- if establishing connection (establishing bearer & handshake negotiation)
    -- is successful we have access to full `ConnectionId`.
      ColdToWarm
        !(Maybe peerAddr) -- ^ local peer address
        !peerAddr         -- ^ remote peer address
    | WarmToHot        !(ConnectionId peerAddr)
    | HotToWarm        !(ConnectionId peerAddr)
    | WarmToCooling    !(ConnectionId peerAddr)
    | HotToCooling     !(ConnectionId peerAddr)
    | CoolingToCold    !(ConnectionId peerAddr)
  deriving Int -> PeerStatusChangeType peerAddr -> ShowS
[PeerStatusChangeType peerAddr] -> ShowS
PeerStatusChangeType peerAddr -> String
(Int -> PeerStatusChangeType peerAddr -> ShowS)
-> (PeerStatusChangeType peerAddr -> String)
-> ([PeerStatusChangeType peerAddr] -> ShowS)
-> Show (PeerStatusChangeType peerAddr)
forall peerAddr.
Show peerAddr =>
Int -> PeerStatusChangeType peerAddr -> ShowS
forall peerAddr.
Show peerAddr =>
[PeerStatusChangeType peerAddr] -> ShowS
forall peerAddr.
Show peerAddr =>
PeerStatusChangeType peerAddr -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall peerAddr.
Show peerAddr =>
Int -> PeerStatusChangeType peerAddr -> ShowS
showsPrec :: Int -> PeerStatusChangeType peerAddr -> ShowS
$cshow :: forall peerAddr.
Show peerAddr =>
PeerStatusChangeType peerAddr -> String
show :: PeerStatusChangeType peerAddr -> String
$cshowList :: forall peerAddr.
Show peerAddr =>
[PeerStatusChangeType peerAddr] -> ShowS
showList :: [PeerStatusChangeType peerAddr] -> ShowS
Show

-- | Traces produced by 'peerSelectionActions'.
--
data PeerSelectionActionsTrace peerAddr vNumber =
      PeerStatusChanged       (PeerStatusChangeType peerAddr)
    | PeerStatusChangeFailure (PeerStatusChangeType peerAddr) (FailureType vNumber)
    | PeerMonitoringError     (ConnectionId peerAddr) SomeException
    | PeerMonitoringResult    (ConnectionId peerAddr) (Maybe (WithSomeProtocolTemperature FirstToFinishResult))
    | AcquireConnectionError  SomeException
    | PeerHotDuration         (ConnectionId peerAddr) DiffTime
  deriving Int -> PeerSelectionActionsTrace peerAddr vNumber -> ShowS
[PeerSelectionActionsTrace peerAddr vNumber] -> ShowS
PeerSelectionActionsTrace peerAddr vNumber -> String
(Int -> PeerSelectionActionsTrace peerAddr vNumber -> ShowS)
-> (PeerSelectionActionsTrace peerAddr vNumber -> String)
-> ([PeerSelectionActionsTrace peerAddr vNumber] -> ShowS)
-> Show (PeerSelectionActionsTrace peerAddr vNumber)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall peerAddr vNumber.
(Show peerAddr, Show vNumber) =>
Int -> PeerSelectionActionsTrace peerAddr vNumber -> ShowS
forall peerAddr vNumber.
(Show peerAddr, Show vNumber) =>
[PeerSelectionActionsTrace peerAddr vNumber] -> ShowS
forall peerAddr vNumber.
(Show peerAddr, Show vNumber) =>
PeerSelectionActionsTrace peerAddr vNumber -> String
$cshowsPrec :: forall peerAddr vNumber.
(Show peerAddr, Show vNumber) =>
Int -> PeerSelectionActionsTrace peerAddr vNumber -> ShowS
showsPrec :: Int -> PeerSelectionActionsTrace peerAddr vNumber -> ShowS
$cshow :: forall peerAddr vNumber.
(Show peerAddr, Show vNumber) =>
PeerSelectionActionsTrace peerAddr vNumber -> String
show :: PeerSelectionActionsTrace peerAddr vNumber -> String
$cshowList :: forall peerAddr vNumber.
(Show peerAddr, Show vNumber) =>
[PeerSelectionActionsTrace peerAddr vNumber] -> ShowS
showList :: [PeerSelectionActionsTrace peerAddr vNumber] -> ShowS
Show