{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE KindSignatures      #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections       #-}
{-# 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
  , 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 (when, (<=<))
import Control.Monad.Class.MonadAsync
import Control.Monad.Class.MonadFork
import Control.Monad.Class.MonadThrow
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.Typeable (Typeable, cast)

import Network.Mux qualified as Mux

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

import Ouroboros.Network.ConnectionHandler (Handle (..), HandleError (..),
           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, Typeable)

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 bytes m a b = ApplicationHandle {
    -- | List of applications for the given peer temperature.
    --
    forall (muxMode :: Mode) responderCtx peerAddr bytes (m :: * -> *)
       a b.
ApplicationHandle muxMode responderCtx peerAddr bytes m a b
-> [MiniProtocol
      muxMode
      (ExpandedInitiatorContext peerAddr m)
      responderCtx
      bytes
      m
      a
      b]
ahApplication         :: [MiniProtocol muxMode (ExpandedInitiatorContext peerAddr m)
                                                   responderCtx bytes m a b],

    -- | 'ControlMessage' 'TVar' for the given peer temperature.
    --
    forall (muxMode :: Mode) responderCtx peerAddr bytes (m :: * -> *)
       a b.
ApplicationHandle muxMode responderCtx peerAddr 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 bytes (m :: * -> *)
       a b.
ApplicationHandle muxMode responderCtx peerAddr 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 bytes m a b)
              -> StrictTVar m ControlMessage
getControlVar :: forall (pt :: ProtocolTemperature) (muxMode :: Mode) responderCtx
       peerAddr bytes (m :: * -> *) a b.
SingProtocolTemperature pt
-> TemperatureBundle
     (ApplicationHandle muxMode responderCtx peerAddr bytes m a b)
-> StrictTVar m ControlMessage
getControlVar SingProtocolTemperature pt
tok = ApplicationHandle muxMode responderCtx peerAddr bytes m a b
-> StrictTVar m ControlMessage
forall (muxMode :: Mode) responderCtx peerAddr bytes (m :: * -> *)
       a b.
ApplicationHandle muxMode responderCtx peerAddr bytes m a b
-> StrictTVar m ControlMessage
ahControlVar (ApplicationHandle muxMode responderCtx peerAddr bytes m a b
 -> StrictTVar m ControlMessage)
-> (TemperatureBundle
      (ApplicationHandle muxMode responderCtx peerAddr bytes m a b)
    -> ApplicationHandle muxMode responderCtx peerAddr bytes m a b)
-> TemperatureBundle
     (ApplicationHandle muxMode responderCtx peerAddr bytes m a b)
-> StrictTVar m ControlMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SingProtocolTemperature pt
-> TemperatureBundle
     (ApplicationHandle muxMode responderCtx peerAddr bytes m a b)
-> ApplicationHandle muxMode responderCtx peerAddr 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 bytes m a b)
             -> [MiniProtocol muxMode (ExpandedInitiatorContext peerAddr m) responderCtx bytes m a b]
getProtocols :: forall (pt :: ProtocolTemperature) (muxMode :: Mode) responderCtx
       peerAddr bytes (m :: * -> *) a b.
SingProtocolTemperature pt
-> TemperatureBundle
     (ApplicationHandle muxMode responderCtx peerAddr bytes m a b)
-> [MiniProtocol
      muxMode
      (ExpandedInitiatorContext peerAddr m)
      responderCtx
      bytes
      m
      a
      b]
getProtocols SingProtocolTemperature pt
tok TemperatureBundle
  (ApplicationHandle muxMode responderCtx peerAddr bytes m a b)
bundle = ApplicationHandle muxMode responderCtx peerAddr bytes m a b
-> [MiniProtocol
      muxMode
      (ExpandedInitiatorContext peerAddr m)
      responderCtx
      bytes
      m
      a
      b]
forall (muxMode :: Mode) responderCtx peerAddr bytes (m :: * -> *)
       a b.
ApplicationHandle muxMode responderCtx peerAddr bytes m a b
-> [MiniProtocol
      muxMode
      (ExpandedInitiatorContext peerAddr m)
      responderCtx
      bytes
      m
      a
      b]
ahApplication (SingProtocolTemperature pt
-> TemperatureBundle
     (ApplicationHandle muxMode responderCtx peerAddr bytes m a b)
-> ApplicationHandle muxMode responderCtx peerAddr bytes m a b
forall (pt :: ProtocolTemperature) a.
SingProtocolTemperature pt -> TemperatureBundle a -> a
projectBundle SingProtocolTemperature pt
tok TemperatureBundle
  (ApplicationHandle muxMode responderCtx peerAddr bytes m a b)
bundle)

getMiniProtocolsVar :: SingProtocolTemperature pt
                    -> TemperatureBundle (ApplicationHandle muxMode responderCtx peerAddr bytes m a b)
                    -> StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))
getMiniProtocolsVar :: forall (pt :: ProtocolTemperature) (muxMode :: Mode) responderCtx
       peerAddr bytes (m :: * -> *) a b.
SingProtocolTemperature pt
-> TemperatureBundle
     (ApplicationHandle muxMode responderCtx peerAddr bytes m a b)
-> StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))
getMiniProtocolsVar SingProtocolTemperature pt
tok = ApplicationHandle muxMode responderCtx peerAddr bytes m a b
-> StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))
forall (muxMode :: Mode) responderCtx peerAddr bytes (m :: * -> *)
       a b.
ApplicationHandle muxMode responderCtx peerAddr bytes m a b
-> StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))
ahMiniProtocolResults (ApplicationHandle muxMode responderCtx peerAddr bytes m a b
 -> StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a))))
-> (TemperatureBundle
      (ApplicationHandle muxMode responderCtx peerAddr bytes m a b)
    -> ApplicationHandle muxMode responderCtx peerAddr bytes m a b)
-> TemperatureBundle
     (ApplicationHandle muxMode responderCtx peerAddr 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 bytes m a b)
-> ApplicationHandle muxMode responderCtx peerAddr 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 bytes m a b)
                 -> STM m FirstToFinishResult
awaitFirstResult :: forall (m :: * -> *) (pt :: ProtocolTemperature) (muxMode :: Mode)
       responderCtx peerAddr bytes a b.
MonadSTM m =>
SingProtocolTemperature pt
-> TemperatureBundle
     (ApplicationHandle muxMode responderCtx peerAddr bytes m a b)
-> STM m FirstToFinishResult
awaitFirstResult SingProtocolTemperature pt
tok TemperatureBundle
  (ApplicationHandle muxMode responderCtx peerAddr 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 bytes m a b)
-> StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))
forall (pt :: ProtocolTemperature) (muxMode :: Mode) responderCtx
       peerAddr bytes (m :: * -> *) a b.
SingProtocolTemperature pt
-> TemperatureBundle
     (ApplicationHandle muxMode responderCtx peerAddr bytes m a b)
-> StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))
getMiniProtocolsVar SingProtocolTemperature pt
tok TemperatureBundle
  (ApplicationHandle muxMode responderCtx peerAddr 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 bytes m a b)
                -> STM m (LastToFinishResult a)
awaitAllResults :: forall (m :: * -> *) (pt :: ProtocolTemperature) (muxMude :: Mode)
       responderCtx peerAddr bytes a b.
MonadSTM m =>
SingProtocolTemperature pt
-> TemperatureBundle
     (ApplicationHandle muxMude responderCtx peerAddr bytes m a b)
-> STM m (LastToFinishResult a)
awaitAllResults SingProtocolTemperature pt
tok TemperatureBundle
  (ApplicationHandle muxMude responderCtx peerAddr 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 bytes m a b)
-> StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))
forall (pt :: ProtocolTemperature) (muxMode :: Mode) responderCtx
       peerAddr bytes (m :: * -> *) a b.
SingProtocolTemperature pt
-> TemperatureBundle
     (ApplicationHandle muxMode responderCtx peerAddr bytes m a b)
-> StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))
getMiniProtocolsVar SingProtocolTemperature pt
tok TemperatureBundle
  (ApplicationHandle muxMude responderCtx peerAddr 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 versionData bytes m a b = PeerConnectionHandle {
    forall (muxMode :: Mode) responderCtx peerAddr versionData bytes
       (m :: * -> *) a b.
PeerConnectionHandle
  muxMode responderCtx peerAddr versionData bytes m a b
-> ConnectionId peerAddr
pchConnectionId :: ConnectionId peerAddr,
    forall (muxMode :: Mode) responderCtx peerAddr versionData bytes
       (m :: * -> *) a b.
PeerConnectionHandle
  muxMode responderCtx peerAddr versionData bytes m a b
-> StrictTVar m PeerStatus
pchPeerStatus   :: StrictTVar m PeerStatus,
    forall (muxMode :: Mode) responderCtx peerAddr versionData bytes
       (m :: * -> *) a b.
PeerConnectionHandle
  muxMode responderCtx peerAddr versionData bytes m a b
-> Mux muxMode m
pchMux          :: Mux.Mux muxMode m,
    forall (muxMode :: Mode) responderCtx peerAddr versionData bytes
       (m :: * -> *) a b.
PeerConnectionHandle
  muxMode responderCtx peerAddr versionData bytes m a b
-> TemperatureBundle
     (ApplicationHandle muxMode responderCtx peerAddr bytes m a b)
pchAppHandles   :: TemperatureBundle (ApplicationHandle muxMode responderCtx peerAddr bytes m a b),
    forall (muxMode :: Mode) responderCtx peerAddr versionData bytes
       (m :: * -> *) a b.
PeerConnectionHandle
  muxMode responderCtx peerAddr versionData bytes m a b
-> versionData
pchVersionData  :: !versionData
  }

mkInitiatorContext :: MonadSTM m
                   => SingProtocolTemperature pt
                   -> IsBigLedgerPeer
                   -> PeerConnectionHandle muxMode responderCtx peerAddr versionDat bytes m a b
                   -> ExpandedInitiatorContext peerAddr m
mkInitiatorContext :: forall (m :: * -> *) (pt :: ProtocolTemperature) (muxMode :: Mode)
       responderCtx peerAddr versionDat bytes a b.
MonadSTM m =>
SingProtocolTemperature pt
-> IsBigLedgerPeer
-> PeerConnectionHandle
     muxMode responderCtx peerAddr versionDat bytes m a b
-> ExpandedInitiatorContext peerAddr m
mkInitiatorContext SingProtocolTemperature pt
tok IsBigLedgerPeer
isBigLedgerPeer
                   PeerConnectionHandle {
                       pchConnectionId :: forall (muxMode :: Mode) responderCtx peerAddr versionData bytes
       (m :: * -> *) a b.
PeerConnectionHandle
  muxMode responderCtx peerAddr versionData bytes m a b
-> ConnectionId peerAddr
pchConnectionId = ConnectionId peerAddr
connectionId,
                       pchAppHandles :: forall (muxMode :: Mode) responderCtx peerAddr versionData bytes
       (m :: * -> *) a b.
PeerConnectionHandle
  muxMode responderCtx peerAddr versionData bytes m a b
-> TemperatureBundle
     (ApplicationHandle muxMode responderCtx peerAddr bytes m a b)
pchAppHandles   = TemperatureBundle
  (ApplicationHandle muxMode responderCtx peerAddr 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 bytes m a b)
-> StrictTVar m ControlMessage
forall (pt :: ProtocolTemperature) (muxMode :: Mode) responderCtx
       peerAddr bytes (m :: * -> *) a b.
SingProtocolTemperature pt
-> TemperatureBundle
     (ApplicationHandle muxMode responderCtx peerAddr bytes m a b)
-> StrictTVar m ControlMessage
getControlVar SingProtocolTemperature pt
tok TemperatureBundle
  (ApplicationHandle muxMode responderCtx peerAddr bytes m a b)
appHandles),
                       eicIsBigLedgerPeer :: IsBigLedgerPeer
eicIsBigLedgerPeer = IsBigLedgerPeer
isBigLedgerPeer
                     }


instance (Show peerAddr, Show versionData)
      => Show (PeerConnectionHandle muxMode responderCtx peerAddr versionData bytes m a b) where
    show :: PeerConnectionHandle
  muxMode responderCtx peerAddr versionData bytes m a b
-> String
show PeerConnectionHandle { ConnectionId peerAddr
pchConnectionId :: forall (muxMode :: Mode) responderCtx peerAddr versionData bytes
       (m :: * -> *) a b.
PeerConnectionHandle
  muxMode responderCtx peerAddr versionData bytes m a b
-> ConnectionId peerAddr
pchConnectionId :: ConnectionId peerAddr
pchConnectionId, versionData
pchVersionData :: forall (muxMode :: Mode) responderCtx peerAddr versionData bytes
       (m :: * -> *) a b.
PeerConnectionHandle
  muxMode responderCtx peerAddr 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 versionData bytes m a b
               -> PeerSharing
pchPeerSharing :: forall versionData (muxMode :: Mode) responderCtx peerAddr bytes
       (m :: * -> *) a b.
(versionData -> PeerSharing)
-> PeerConnectionHandle
     muxMode responderCtx peerAddr versionData bytes m a b
-> PeerSharing
pchPeerSharing versionData -> PeerSharing
f = versionData -> PeerSharing
f (versionData -> PeerSharing)
-> (PeerConnectionHandle
      muxMode responderCtx peerAddr versionData bytes m a b
    -> versionData)
-> PeerConnectionHandle
     muxMode responderCtx peerAddr versionData bytes m a b
-> PeerSharing
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PeerConnectionHandle
  muxMode responderCtx peerAddr versionData bytes m a b
-> versionData
forall (muxMode :: Mode) responderCtx peerAddr versionData bytes
       (m :: * -> *) a b.
PeerConnectionHandle
  muxMode responderCtx peerAddr 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 versionData versionNumber m a b =
    PeerStateActionsArguments {

      forall (muxMode :: Mode) socket responderCtx peerAddr versionData
       versionNumber (m :: * -> *) a b.
PeerStateActionsArguments
  muxMode
  socket
  responderCtx
  peerAddr
  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 versionData
       versionNumber (m :: * -> *) a b.
PeerStateActionsArguments
  muxMode
  socket
  responderCtx
  peerAddr
  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 versionData
       versionNumber (m :: * -> *) a b.
PeerStateActionsArguments
  muxMode
  socket
  responderCtx
  peerAddr
  versionData
  versionNumber
  m
  a
  b
-> DiffTime
spsCloseConnectionTimeout :: DiffTime,

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

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


withPeerStateActions
    :: forall (muxMode :: Mux.Mode) socket responderCtx peerAddr 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 versionData versionNumber m a b
    -> (PeerStateActions
          peerAddr
          (PeerConnectionHandle muxMode responderCtx peerAddr versionData ByteString m a b)
          m
          -> m x)
    -> m x

withPeerStateActions :: forall (muxMode :: Mode) socket responderCtx peerAddr 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
  versionData
  versionNumber
  m
  a
  b
-> (PeerStateActions
      peerAddr
      (PeerConnectionHandle
         muxMode responderCtx peerAddr versionData ByteString m a b)
      m
    -> m x)
-> m x
withPeerStateActions PeerStateActionsArguments {
                       DiffTime
spsDeactivateTimeout :: forall (muxMode :: Mode) socket responderCtx peerAddr versionData
       versionNumber (m :: * -> *) a b.
PeerStateActionsArguments
  muxMode
  socket
  responderCtx
  peerAddr
  versionData
  versionNumber
  m
  a
  b
-> DiffTime
spsDeactivateTimeout :: DiffTime
spsDeactivateTimeout,
                       DiffTime
spsCloseConnectionTimeout :: forall (muxMode :: Mode) socket responderCtx peerAddr versionData
       versionNumber (m :: * -> *) a b.
PeerStateActionsArguments
  muxMode
  socket
  responderCtx
  peerAddr
  versionData
  versionNumber
  m
  a
  b
-> DiffTime
spsCloseConnectionTimeout :: DiffTime
spsCloseConnectionTimeout,
                       Tracer m (PeerSelectionActionsTrace peerAddr versionNumber)
spsTracer :: forall (muxMode :: Mode) socket responderCtx peerAddr versionData
       versionNumber (m :: * -> *) a b.
PeerStateActionsArguments
  muxMode
  socket
  responderCtx
  peerAddr
  versionData
  versionNumber
  m
  a
  b
-> Tracer m (PeerSelectionActionsTrace peerAddr versionNumber)
spsTracer :: Tracer m (PeerSelectionActionsTrace peerAddr versionNumber)
spsTracer,
                       MuxConnectionManager
  muxMode
  socket
  (ExpandedInitiatorContext peerAddr m)
  responderCtx
  peerAddr
  versionData
  versionNumber
  ByteString
  m
  a
  b
spsConnectionManager :: forall (muxMode :: Mode) socket responderCtx peerAddr versionData
       versionNumber (m :: * -> *) a b.
PeerStateActionsArguments
  muxMode
  socket
  responderCtx
  peerAddr
  versionData
  versionNumber
  m
  a
  b
-> MuxConnectionManager
     muxMode
     socket
     (ExpandedInitiatorContext peerAddr m)
     responderCtx
     peerAddr
     versionData
     versionNumber
     ByteString
     m
     a
     b
spsConnectionManager :: MuxConnectionManager
  muxMode
  socket
  (ExpandedInitiatorContext peerAddr m)
  responderCtx
  peerAddr
  versionData
  versionNumber
  ByteString
  m
  a
  b
spsConnectionManager,
                       ExitPolicy a
spsExitPolicy :: forall (muxMode :: Mode) socket responderCtx peerAddr versionData
       versionNumber (m :: * -> *) a b.
PeerStateActionsArguments
  muxMode
  socket
  responderCtx
  peerAddr
  versionData
  versionNumber
  m
  a
  b
-> ExitPolicy a
spsExitPolicy :: ExitPolicy a
spsExitPolicy,
                       RethrowPolicy
spsRethrowPolicy :: forall (muxMode :: Mode) socket responderCtx peerAddr versionData
       versionNumber (m :: * -> *) a b.
PeerStateActionsArguments
  muxMode
  socket
  responderCtx
  peerAddr
  versionData
  versionNumber
  m
  a
  b
-> RethrowPolicy
spsRethrowPolicy :: RethrowPolicy
spsRethrowPolicy,
                       ThreadId m
spsMainThreadId :: forall (muxMode :: Mode) socket responderCtx peerAddr versionData
       versionNumber (m :: * -> *) a b.
PeerStateActionsArguments
  muxMode
  socket
  responderCtx
  peerAddr
  versionData
  versionNumber
  m
  a
  b
-> ThreadId m
spsMainThreadId :: ThreadId m
spsMainThreadId
                     }
                     PeerStateActions
  peerAddr
  (PeerConnectionHandle
     muxMode responderCtx peerAddr 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
  (PeerConnectionHandle
     muxMode responderCtx peerAddr versionData ByteString m a b)
  m
-> m x
k PeerStateActions {
          establishPeerConnection :: IsBigLedgerPeer
-> peerAddr
-> m (PeerConnectionHandle
        muxMode responderCtx peerAddr versionData ByteString m a b)
establishPeerConnection = JobPool () m (Maybe SomeException)
-> IsBigLedgerPeer
-> peerAddr
-> m (PeerConnectionHandle
        muxMode responderCtx peerAddr versionData ByteString m a b)
establishPeerConnection JobPool () m (Maybe SomeException)
jobPool,
          PeerConnectionHandle
  muxMode responderCtx peerAddr versionData ByteString m a b
-> STM m (PeerStatus, Maybe RepromoteDelay)
monitorPeerConnection :: PeerConnectionHandle
  muxMode responderCtx peerAddr versionData ByteString m a b
-> STM m (PeerStatus, Maybe RepromoteDelay)
monitorPeerConnection :: PeerConnectionHandle
  muxMode responderCtx peerAddr versionData ByteString m a b
-> STM m (PeerStatus, Maybe RepromoteDelay)
monitorPeerConnection,
          IsBigLedgerPeer
-> PeerConnectionHandle
     muxMode responderCtx peerAddr versionData ByteString m a b
-> m ()
activatePeerConnection :: IsBigLedgerPeer
-> PeerConnectionHandle
     muxMode responderCtx peerAddr versionData ByteString m a b
-> m ()
activatePeerConnection :: IsBigLedgerPeer
-> PeerConnectionHandle
     muxMode responderCtx peerAddr versionData ByteString m a b
-> m ()
activatePeerConnection,
          PeerConnectionHandle
  muxMode responderCtx peerAddr versionData ByteString m a b
-> m ()
deactivatePeerConnection :: PeerConnectionHandle
  muxMode responderCtx peerAddr versionData ByteString m a b
-> m ()
deactivatePeerConnection :: PeerConnectionHandle
  muxMode responderCtx peerAddr versionData ByteString m a b
-> m ()
deactivatePeerConnection,
          closePeerConnection :: PeerConnectionHandle
  muxMode responderCtx peerAddr versionData ByteString m a b
-> m ()
closePeerConnection = m Bool -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m Bool -> m ())
-> (PeerConnectionHandle
      muxMode responderCtx peerAddr versionData ByteString m a b
    -> m Bool)
-> PeerConnectionHandle
     muxMode responderCtx peerAddr versionData ByteString m a b
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PeerConnectionHandle
  muxMode responderCtx peerAddr versionData ByteString m a b
-> m Bool
closePeerConnection
        }

  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

    isNotCoolingOrCold :: StrictTVar m PeerStatus -> STM m Bool
    isNotCoolingOrCold :: StrictTVar m PeerStatus -> STM m Bool
isNotCoolingOrCold StrictTVar m PeerStatus
stateVar =
      (PeerStatus -> PeerStatus -> Bool
forall a. Ord a => a -> a -> Bool
> PeerStatus
PeerCooling) (PeerStatus -> Bool) -> STM m PeerStatus -> STM m Bool
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
stateVar

    peerMonitoringLoop
      :: PeerConnectionHandle muxMode responderCtx peerAddr versionData ByteString m a b
      -> m ()
    peerMonitoringLoop :: PeerConnectionHandle
  muxMode responderCtx peerAddr versionData ByteString m a b
-> m ()
peerMonitoringLoop pch :: PeerConnectionHandle
  muxMode responderCtx peerAddr versionData ByteString m a b
pch@PeerConnectionHandle { ConnectionId peerAddr
pchConnectionId :: forall (muxMode :: Mode) responderCtx peerAddr versionData bytes
       (m :: * -> *) a b.
PeerConnectionHandle
  muxMode responderCtx peerAddr versionData bytes m a b
-> ConnectionId peerAddr
pchConnectionId :: ConnectionId peerAddr
pchConnectionId, StrictTVar m PeerStatus
pchPeerStatus :: forall (muxMode :: Mode) responderCtx peerAddr versionData bytes
       (m :: * -> *) a b.
PeerConnectionHandle
  muxMode responderCtx peerAddr versionData bytes m a b
-> StrictTVar m PeerStatus
pchPeerStatus :: StrictTVar m PeerStatus
pchPeerStatus, TemperatureBundle
  (ApplicationHandle muxMode responderCtx peerAddr ByteString m a b)
pchAppHandles :: forall (muxMode :: Mode) responderCtx peerAddr versionData bytes
       (m :: * -> *) a b.
PeerConnectionHandle
  muxMode responderCtx peerAddr versionData bytes m a b
-> TemperatureBundle
     (ApplicationHandle muxMode responderCtx peerAddr bytes m a b)
pchAppHandles :: TemperatureBundle
  (ApplicationHandle muxMode responderCtx peerAddr 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 m)
  responderCtx
  peerAddr
  versionData
  versionNumber
  ByteString
  m
  a
  b
-> peerAddr -> STM m ()
forall (muxMode :: Mode) socket peerAddr handle handleError
       (m :: * -> *).
ConnectionManager muxMode socket peerAddr handle handleError m
-> peerAddr -> STM m ()
waitForOutboundDemotion MuxConnectionManager
  muxMode
  socket
  (ExpandedInitiatorContext peerAddr m)
  responderCtx
  peerAddr
  versionData
  versionNumber
  ByteString
  m
  a
  b
spsConnectionManager (ConnectionId peerAddr -> peerAddr
forall addr. ConnectionId addr -> addr
remoteAddress 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 ByteString m a b)
-> STM m FirstToFinishResult
forall (m :: * -> *) (pt :: ProtocolTemperature) (muxMode :: Mode)
       responderCtx peerAddr bytes a b.
MonadSTM m =>
SingProtocolTemperature pt
-> TemperatureBundle
     (ApplicationHandle muxMode responderCtx peerAddr bytes m a b)
-> STM m FirstToFinishResult
awaitFirstResult SingProtocolTemperature 'Established
SingEstablished TemperatureBundle
  (ApplicationHandle muxMode responderCtx peerAddr 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 ByteString m a b)
-> STM m FirstToFinishResult
forall (m :: * -> *) (pt :: ProtocolTemperature) (muxMode :: Mode)
       responderCtx peerAddr bytes a b.
MonadSTM m =>
SingProtocolTemperature pt
-> TemperatureBundle
     (ApplicationHandle muxMode responderCtx peerAddr bytes m a b)
-> STM m FirstToFinishResult
awaitFirstResult SingProtocolTemperature 'Warm
SingWarm TemperatureBundle
  (ApplicationHandle muxMode responderCtx peerAddr 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 ByteString m a b)
-> STM m FirstToFinishResult
forall (m :: * -> *) (pt :: ProtocolTemperature) (muxMode :: Mode)
       responderCtx peerAddr bytes a b.
MonadSTM m =>
SingProtocolTemperature pt
-> TemperatureBundle
     (ApplicationHandle muxMode responderCtx peerAddr bytes m a b)
-> STM m FirstToFinishResult
awaitFirstResult SingProtocolTemperature 'Hot
SingHot TemperatureBundle
  (ApplicationHandle muxMode responderCtx peerAddr 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 versionData ByteString m a b
-> m ()
peerMonitoringLoop PeerConnectionHandle
  muxMode responderCtx peerAddr 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 versionData ByteString m a b
-> m ()
deactivatePeerConnection PeerConnectionHandle
  muxMode responderCtx peerAddr versionData ByteString m a b
pch
            PeerConnectionHandle
  muxMode responderCtx peerAddr versionData ByteString m a b
-> m ()
peerMonitoringLoop PeerConnectionHandle
  muxMode responderCtx peerAddr 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
            isCooling <- PeerConnectionHandle
  muxMode responderCtx peerAddr versionData ByteString m a b
-> m Bool
closePeerConnection PeerConnectionHandle
  muxMode responderCtx peerAddr versionData ByteString m a b
pch
            if isCooling
                then peerMonitoringLoop pch
                else return ()
          Just (WithSomeProtocolTemperature (WithEstablished MiniProtocolSuccess {})) -> do
            isCooling <- PeerConnectionHandle
  muxMode responderCtx peerAddr versionData ByteString m a b
-> m Bool
closePeerConnection PeerConnectionHandle
  muxMode responderCtx peerAddr versionData ByteString m a b
pch
            if isCooling
                then peerMonitoringLoop pch
                else return ()

          Maybe (WithSomeProtocolTemperature FirstToFinishResult)
Nothing ->
            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
                            -> peerAddr
                            -> m (PeerConnectionHandle muxMode responderCtx peerAddr versionData ByteString m a b)
    establishPeerConnection :: JobPool () m (Maybe SomeException)
-> IsBigLedgerPeer
-> peerAddr
-> m (PeerConnectionHandle
        muxMode responderCtx peerAddr versionData ByteString m a b)
establishPeerConnection JobPool () m (Maybe SomeException)
jobPool IsBigLedgerPeer
isBigLedgerPeer peerAddr
remotePeerAddr =
      -- 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 versionData ByteString m a b))
-> m (PeerConnectionHandle
        muxMode responderCtx peerAddr 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 versionData ByteString m a b))
 -> m (PeerConnectionHandle
         muxMode responderCtx peerAddr versionData ByteString m a b))
-> (StrictTVar m PeerStatus
    -> m (PeerConnectionHandle
            muxMode responderCtx peerAddr versionData ByteString m a b))
-> m (PeerConnectionHandle
        muxMode responderCtx peerAddr 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 m)
        responderCtx
        versionData
        ByteString
        m
        a
        b)
     (HandleError muxMode versionNumber))
-> m (Either
        SomeException
        (Connected
           peerAddr
           (Handle
              muxMode
              (ExpandedInitiatorContext peerAddr m)
              responderCtx
              versionData
              ByteString
              m
              a
              b)
           (HandleError muxMode 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 m)
         responderCtx
         versionData
         ByteString
         m
         a
         b)
      (HandleError muxMode versionNumber))
 -> m (Either
         SomeException
         (Connected
            peerAddr
            (Handle
               muxMode
               (ExpandedInitiatorContext peerAddr m)
               responderCtx
               versionData
               ByteString
               m
               a
               b)
            (HandleError muxMode versionNumber))))
-> m (Connected
        peerAddr
        (Handle
           muxMode
           (ExpandedInitiatorContext peerAddr m)
           responderCtx
           versionData
           ByteString
           m
           a
           b)
        (HandleError muxMode versionNumber))
-> m (Either
        SomeException
        (Connected
           peerAddr
           (Handle
              muxMode
              (ExpandedInitiatorContext peerAddr m)
              responderCtx
              versionData
              ByteString
              m
              a
              b)
           (HandleError muxMode versionNumber)))
forall a b. (a -> b) -> a -> b
$ MuxConnectionManager
  muxMode
  socket
  (ExpandedInitiatorContext peerAddr m)
  responderCtx
  peerAddr
  versionData
  versionNumber
  ByteString
  m
  a
  b
-> AcquireOutboundConnection
     peerAddr
     (Handle
        muxMode
        (ExpandedInitiatorContext peerAddr m)
        responderCtx
        versionData
        ByteString
        m
        a
        b)
     (HandleError muxMode 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 m)
  responderCtx
  peerAddr
  versionData
  versionNumber
  ByteString
  m
  a
  b
spsConnectionManager peerAddr
remotePeerAddr
          case res of
            Left SomeException
e -> 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 (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 versionData ByteString m a b)
-> m (PeerConnectionHandle
        muxMode responderCtx peerAddr 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 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 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 connectionId :: ConnectionId peerAddr
connectionId@ConnectionId { peerAddr
localAddress :: peerAddr
localAddress :: forall addr. ConnectionId addr -> addr
localAddress, peerAddr
remoteAddress :: forall addr. ConnectionId addr -> addr
remoteAddress :: peerAddr
remoteAddress }
                             DataFlow
_dataFlow
                            (Handle Mux muxMode m
mux OuroborosBundle
  muxMode
  (ExpandedInitiatorContext peerAddr 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 m)
  responderCtx
  ByteString
  m
  a
  b
-> STM
     m
     (TemperatureBundle
        (StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))))
mkAwaitVars OuroborosBundle
  muxMode
  (ExpandedInitiatorContext peerAddr m)
  responderCtx
  ByteString
  m
  a
  b
muxBundle

              let connHandle =
                    PeerConnectionHandle {
                        pchConnectionId :: ConnectionId peerAddr
pchConnectionId = ConnectionId peerAddr
connectionId,
                        pchPeerStatus :: StrictTVar m PeerStatus
pchPeerStatus   = StrictTVar m PeerStatus
peerStateVar,
                        pchMux :: Mux muxMode m
pchMux          = Mux muxMode m
mux,
                        pchAppHandles :: TemperatureBundle
  (ApplicationHandle muxMode responderCtx peerAddr ByteString m a b)
pchAppHandles   = OuroborosBundle
  muxMode
  (ExpandedInitiatorContext peerAddr m)
  responderCtx
  ByteString
  m
  a
  b
-> TemperatureBundle (StrictTVar m ControlMessage)
-> TemperatureBundle
     (StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a))))
-> TemperatureBundle
     (ApplicationHandle muxMode responderCtx peerAddr ByteString m a b)
forall (muxMode :: Mode) responderCtx peerAddr bytes (m :: * -> *)
       a b.
OuroborosBundle
  muxMode
  (ExpandedInitiatorContext peerAddr m)
  responderCtx
  bytes
  m
  a
  b
-> TemperatureBundle (StrictTVar m ControlMessage)
-> TemperatureBundle
     (StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a))))
-> TemperatureBundle
     (ApplicationHandle muxMode responderCtx peerAddr bytes m a b)
mkApplicationHandleBundle
                                            OuroborosBundle
  muxMode
  (ExpandedInitiatorContext peerAddr 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
                      }

              startProtocols SingWarm isBigLedgerPeer connHandle
              startProtocols SingEstablished isBigLedgerPeer 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 (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
                                          MuxConnectionManager
  muxMode
  socket
  (ExpandedInitiatorContext peerAddr m)
  responderCtx
  peerAddr
  versionData
  versionNumber
  ByteString
  m
  a
  b
-> peerAddr -> STM m ()
forall (muxMode :: Mode) socket peerAddr handle handleError
       (m :: * -> *).
ConnectionManager muxMode socket peerAddr handle handleError m
-> peerAddr -> STM m ()
waitForOutboundDemotion MuxConnectionManager
  muxMode
  socket
  (ExpandedInitiatorContext peerAddr m)
  responderCtx
  peerAddr
  versionData
  versionNumber
  ByteString
  m
  a
  b
spsConnectionManager peerAddr
remoteAddress
                                          StrictTVar m PeerStatus -> PeerStatus -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m PeerStatus
peerStateVar PeerStatus
PeerCold
                                        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
connectionId 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
_ Maybe (HandleError muxMode versionNumber)
Nothing) ->
              -- Disconnected in 'TerminatingState' or 'TerminatedState' without
              -- an exception.
              IOError
-> m (PeerConnectionHandle
        muxMode responderCtx peerAddr 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 (IOError
 -> m (PeerConnectionHandle
         muxMode responderCtx peerAddr versionData ByteString m a b))
-> IOError
-> m (PeerConnectionHandle
        muxMode responderCtx peerAddr versionData ByteString m a b)
forall a b. (a -> b) -> a -> b
$ String -> IOError
userError String
"establishPeerConnection: Disconnected"
            Right (Disconnected ConnectionId peerAddr
_ (Just HandleError muxMode versionNumber
reason)) ->
              case HandleError muxMode versionNumber
reason 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 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 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)

                HandleError 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 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
      where
        mkAwaitVars :: OuroborosBundle muxMode (ExpandedInitiatorContext peerAddr m)
                                               responderCtx ByteString m a b
                    -> STM m (TemperatureBundle
                               (StrictTVar m
                                 (Map MiniProtocolNum
                                   (STM m (HasReturned a)))))
        mkAwaitVars :: OuroborosBundle
  muxMode
  (ExpandedInitiatorContext peerAddr m)
  responderCtx
  ByteString
  m
  a
  b
-> STM
     m
     (TemperatureBundle
        (StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))))
mkAwaitVars = ([MiniProtocol
    muxMode
    (ExpandedInitiatorContext peerAddr m)
    responderCtx
    ByteString
    m
    a
    b]
 -> STM
      m (StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))))
-> OuroborosBundle
     muxMode
     (ExpandedInitiatorContext peerAddr 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 m)
   responderCtx
   ByteString
   m
   a
   b]
-> STM
     m (StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a))))
f
          where
            f :: [MiniProtocol muxMode (ExpandedInitiatorContext peerAddr m)
                                       responderCtx ByteString m a b]
              -> STM m (StrictTVar m
                         (Map MiniProtocolNum
                           (STM m (HasReturned a))))
            f :: [MiniProtocol
   muxMode
   (ExpandedInitiatorContext peerAddr 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 m)
       responderCtx
       ByteString
       m
       a
       b]
    -> Map MiniProtocolNum (STM m (HasReturned a)))
-> [MiniProtocol
      muxMode
      (ExpandedInitiatorContext peerAddr 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 m)
       responderCtx
       ByteString
       m
       a
       b]
    -> [(MiniProtocolNum, STM m (HasReturned a))])
-> [MiniProtocol
      muxMode
      (ExpandedInitiatorContext peerAddr 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 m)
   responderCtx
   ByteString
   m
   a
   b
 -> (MiniProtocolNum, STM m (HasReturned a)))
-> [MiniProtocol
      muxMode
      (ExpandedInitiatorContext peerAddr 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 versionData ByteString m a b
                          -> STM m (PeerStatus, Maybe RepromoteDelay)
    monitorPeerConnection :: PeerConnectionHandle
  muxMode responderCtx peerAddr versionData ByteString m a b
-> STM m (PeerStatus, Maybe RepromoteDelay)
monitorPeerConnection PeerConnectionHandle { StrictTVar m PeerStatus
pchPeerStatus :: forall (muxMode :: Mode) responderCtx peerAddr versionData bytes
       (m :: * -> *) a b.
PeerConnectionHandle
  muxMode responderCtx peerAddr versionData bytes m a b
-> StrictTVar m PeerStatus
pchPeerStatus :: StrictTVar m PeerStatus
pchPeerStatus, TemperatureBundle
  (ApplicationHandle muxMode responderCtx peerAddr ByteString m a b)
pchAppHandles :: forall (muxMode :: Mode) responderCtx peerAddr versionData bytes
       (m :: * -> *) a b.
PeerConnectionHandle
  muxMode responderCtx peerAddr versionData bytes m a b
-> TemperatureBundle
     (ApplicationHandle muxMode responderCtx peerAddr bytes m a b)
pchAppHandles :: TemperatureBundle
  (ApplicationHandle muxMode responderCtx peerAddr 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 ByteString m a b
 -> STM m (Map MiniProtocolNum (Maybe (HasReturned a))))
-> TemperatureBundle
     (ApplicationHandle muxMode responderCtx peerAddr 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 ByteString m a b
-> STM m (Map MiniProtocolNum (Maybe (HasReturned a)))
f TemperatureBundle
  (ApplicationHandle muxMode responderCtx peerAddr 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 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 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 ByteString m a b
    -> STM m (Map MiniProtocolNum (STM m (HasReturned a))))
-> ApplicationHandle muxMode responderCtx peerAddr 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 ByteString m a b
    -> StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a))))
-> ApplicationHandle muxMode responderCtx peerAddr 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 ByteString m a b
-> StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))
forall (muxMode :: Mode) responderCtx peerAddr bytes (m :: * -> *)
       a b.
ApplicationHandle muxMode responderCtx peerAddr 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
                           -> PeerConnectionHandle muxMode responderCtx peerAddr versionData ByteString m a b
                           -> m ()
    activatePeerConnection :: IsBigLedgerPeer
-> PeerConnectionHandle
     muxMode responderCtx peerAddr versionData ByteString m a b
-> m ()
activatePeerConnection
        IsBigLedgerPeer
isBigLedgerPeer
        connHandle :: PeerConnectionHandle
  muxMode responderCtx peerAddr versionData ByteString m a b
connHandle@PeerConnectionHandle {
            ConnectionId peerAddr
pchConnectionId :: forall (muxMode :: Mode) responderCtx peerAddr versionData bytes
       (m :: * -> *) a b.
PeerConnectionHandle
  muxMode responderCtx peerAddr versionData bytes m a b
-> ConnectionId peerAddr
pchConnectionId :: ConnectionId peerAddr
pchConnectionId,
            StrictTVar m PeerStatus
pchPeerStatus :: forall (muxMode :: Mode) responderCtx peerAddr versionData bytes
       (m :: * -> *) a b.
PeerConnectionHandle
  muxMode responderCtx peerAddr versionData bytes m a b
-> StrictTVar m PeerStatus
pchPeerStatus :: StrictTVar m PeerStatus
pchPeerStatus,
            TemperatureBundle
  (ApplicationHandle muxMode responderCtx peerAddr ByteString m a b)
pchAppHandles :: forall (muxMode :: Mode) responderCtx peerAddr versionData bytes
       (m :: * -> *) a b.
PeerConnectionHandle
  muxMode responderCtx peerAddr versionData bytes m a b
-> TemperatureBundle
     (ApplicationHandle muxMode responderCtx peerAddr bytes m a b)
pchAppHandles :: TemperatureBundle
  (ApplicationHandle muxMode responderCtx peerAddr ByteString m a b)
pchAppHandles } = do
      -- quiesce warm peer protocols and set hot ones in 'Continue' mode.
      wasWarm <- 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
$ do
        -- if the peer is cold we can't activate it.
        notCold <- StrictTVar m PeerStatus -> STM m Bool
isNotCoolingOrCold StrictTVar m PeerStatus
pchPeerStatus
        when notCold $ do
          writeTVar (getControlVar SingHot pchAppHandles) Continue
          writeTVar (getControlVar SingWarm pchAppHandles) Quiesce
        return notCold
      when (not wasWarm) $ do
        traceWith spsTracer (PeerStatusChangeFailure
                              (WarmToHot pchConnectionId)
                              ActiveCold)
        throwIO $ ColdActivationException pchConnectionId

      -- start hot peer protocols
      startProtocols SingHot isBigLedgerPeer connHandle

      -- Only set the status to PeerHot if the peer isn't PeerCold.
      -- This can happen asynchronously between the check above and now.
      wasWarm' <- atomically $ updateUnlessCoolingOrCold pchPeerStatus PeerHot
      if wasWarm'
         then traceWith spsTracer (PeerStatusChanged (WarmToHot pchConnectionId))
         else do
           traceWith spsTracer (PeerStatusChangeFailure
                                 (WarmToHot pchConnectionId)
                                 ActiveCold)
           throwIO $ ColdActivationException pchConnectionId


    -- Take a hot peer and demote it to a warm one.
    deactivatePeerConnection :: PeerConnectionHandle muxMode responderCtx peerAddr versionData ByteString m a b -> m ()
    deactivatePeerConnection :: PeerConnectionHandle
  muxMode responderCtx peerAddr versionData ByteString m a b
-> m ()
deactivatePeerConnection
        PeerConnectionHandle {
            ConnectionId peerAddr
pchConnectionId :: forall (muxMode :: Mode) responderCtx peerAddr versionData bytes
       (m :: * -> *) a b.
PeerConnectionHandle
  muxMode responderCtx peerAddr versionData bytes m a b
-> ConnectionId peerAddr
pchConnectionId :: ConnectionId peerAddr
pchConnectionId,
            StrictTVar m PeerStatus
pchPeerStatus :: forall (muxMode :: Mode) responderCtx peerAddr versionData bytes
       (m :: * -> *) a b.
PeerConnectionHandle
  muxMode responderCtx peerAddr versionData bytes m a b
-> StrictTVar m PeerStatus
pchPeerStatus :: StrictTVar m PeerStatus
pchPeerStatus,
            Mux muxMode m
pchMux :: forall (muxMode :: Mode) responderCtx peerAddr versionData bytes
       (m :: * -> *) a b.
PeerConnectionHandle
  muxMode responderCtx peerAddr versionData bytes m a b
-> Mux muxMode m
pchMux :: Mux muxMode m
pchMux,
            TemperatureBundle
  (ApplicationHandle muxMode responderCtx peerAddr ByteString m a b)
pchAppHandles :: forall (muxMode :: Mode) responderCtx peerAddr versionData bytes
       (m :: * -> *) a b.
PeerConnectionHandle
  muxMode responderCtx peerAddr versionData bytes m a b
-> TemperatureBundle
     (ApplicationHandle muxMode responderCtx peerAddr bytes m a b)
pchAppHandles :: TemperatureBundle
  (ApplicationHandle muxMode responderCtx peerAddr ByteString m a b)
pchAppHandles
          } = do
      wasCold <- 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
$ do
        notCold <- StrictTVar m PeerStatus -> STM m Bool
isNotCoolingOrCold StrictTVar m PeerStatus
pchPeerStatus
        when notCold $ do
          writeTVar (getControlVar SingHot pchAppHandles) Terminate
          writeTVar (getControlVar SingWarm pchAppHandles) Continue
        return (not notCold)
      when wasCold $ do
        -- The governor attempted to demote an already cold peer.
        traceWith spsTracer (PeerStatusChangeFailure
                             (HotToWarm pchConnectionId)
                             ActiveCold)
        throwIO $ ColdDeactivationException pchConnectionId


      -- Hot protocols should stop within 'spsDeactivateTimeout'.
      res <-
        timeout spsDeactivateTimeout
                (atomically $ awaitAllResults SingHot pchAppHandles)
      case res of
        Maybe (LastToFinishResult a)
Nothing -> do
          Mux muxMode m -> m ()
forall (m :: * -> *) (mode :: Mode).
MonadSTM m =>
Mux mode m -> m ()
Mux.stop Mux muxMode m
pchMux
          STM m () -> m ()
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 ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m PeerStatus
pchPeerStatus PeerStatus
PeerCooling)
          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)
                                FailureType versionNumber
forall versionNumber. FailureType versionNumber
TimeoutError)
          PeerSelectionTimeoutException peerAddr -> m ()
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (ConnectionId peerAddr -> PeerSelectionTimeoutException peerAddr
forall peerAddr.
ConnectionId peerAddr -> PeerSelectionTimeoutException peerAddr
DeactivationTimeout ConnectionId peerAddr
pchConnectionId)

        -- some of the hot mini-protocols errored
        Just (SomeErrored [MiniProtocolException]
errs) -> do
          -- we don't need to notify the connection manager, we can instead
          -- relay on mux property: if any of the mini-protocols errors, mux
          -- throws an exception as well.
          STM m () -> m ()
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 ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m PeerStatus
pchPeerStatus PeerStatus
PeerCooling)
          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))
          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)

        -- all hot mini-protocols succeeded
        Just (AllSucceeded Map MiniProtocolNum a
results) -> do
          -- we don't notify the connection manager as this connection is still
          -- useful to the outbound governor (warm peer).
          wasWarm <- 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
$ do
            -- Only set the status to PeerWarm if the peer isn't cold
            -- (can happen asynchronously).
            notCold <- StrictTVar m PeerStatus -> PeerStatus -> STM m Bool
updateUnlessCoolingOrCold StrictTVar m PeerStatus
pchPeerStatus PeerStatus
PeerWarm
            when notCold $ do
              -- We need to update hot protocols to indicate that they are not
              -- running. Preserve the results returned by their previous
              -- execution.
              modifyTVar (getMiniProtocolsVar SingHot 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)
            return notCold

          if wasWarm
             then traceWith spsTracer (PeerStatusChanged (HotToWarm pchConnectionId))
             else do
                 traceWith spsTracer (PeerStatusChangeFailure
                                      (WarmToHot pchConnectionId)
                                      ActiveCold)
                 throwIO $ ColdDeactivationException pchConnectionId


    closePeerConnection :: PeerConnectionHandle muxMode responderCtx peerAddr versionData ByteString m a b
                        -> m Bool
    closePeerConnection :: PeerConnectionHandle
  muxMode responderCtx peerAddr versionData ByteString m a b
-> m Bool
closePeerConnection
        PeerConnectionHandle {
            ConnectionId peerAddr
pchConnectionId :: forall (muxMode :: Mode) responderCtx peerAddr versionData bytes
       (m :: * -> *) a b.
PeerConnectionHandle
  muxMode responderCtx peerAddr versionData bytes m a b
-> ConnectionId peerAddr
pchConnectionId :: ConnectionId peerAddr
pchConnectionId,
            StrictTVar m PeerStatus
pchPeerStatus :: forall (muxMode :: Mode) responderCtx peerAddr versionData bytes
       (m :: * -> *) a b.
PeerConnectionHandle
  muxMode responderCtx peerAddr versionData bytes m a b
-> StrictTVar m PeerStatus
pchPeerStatus :: StrictTVar m PeerStatus
pchPeerStatus,
            TemperatureBundle
  (ApplicationHandle muxMode responderCtx peerAddr ByteString m a b)
pchAppHandles :: forall (muxMode :: Mode) responderCtx peerAddr versionData bytes
       (m :: * -> *) a b.
PeerConnectionHandle
  muxMode responderCtx peerAddr versionData bytes m a b
-> TemperatureBundle
     (ApplicationHandle muxMode responderCtx peerAddr bytes m a b)
pchAppHandles :: TemperatureBundle
  (ApplicationHandle muxMode responderCtx peerAddr ByteString m a b)
pchAppHandles,
            Mux muxMode m
pchMux :: forall (muxMode :: Mode) responderCtx peerAddr versionData bytes
       (m :: * -> *) a b.
PeerConnectionHandle
  muxMode responderCtx peerAddr versionData bytes m a b
-> Mux muxMode m
pchMux :: Mux muxMode m
pchMux
          } = 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 'Warm
-> TemperatureBundle
     (ApplicationHandle muxMode responderCtx peerAddr ByteString m a b)
-> StrictTVar m ControlMessage
forall (pt :: ProtocolTemperature) (muxMode :: Mode) responderCtx
       peerAddr bytes (m :: * -> *) a b.
SingProtocolTemperature pt
-> TemperatureBundle
     (ApplicationHandle muxMode responderCtx peerAddr bytes m a b)
-> StrictTVar m ControlMessage
getControlVar SingProtocolTemperature 'Warm
SingWarm TemperatureBundle
  (ApplicationHandle muxMode responderCtx peerAddr 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 ByteString m a b)
-> StrictTVar m ControlMessage
forall (pt :: ProtocolTemperature) (muxMode :: Mode) responderCtx
       peerAddr bytes (m :: * -> *) a b.
SingProtocolTemperature pt
-> TemperatureBundle
     (ApplicationHandle muxMode responderCtx peerAddr bytes m a b)
-> StrictTVar m ControlMessage
getControlVar SingProtocolTemperature 'Established
SingEstablished TemperatureBundle
  (ApplicationHandle muxMode responderCtx peerAddr 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 ByteString m a b)
-> StrictTVar m ControlMessage
forall (pt :: ProtocolTemperature) (muxMode :: Mode) responderCtx
       peerAddr bytes (m :: * -> *) a b.
SingProtocolTemperature pt
-> TemperatureBundle
     (ApplicationHandle muxMode responderCtx peerAddr bytes m a b)
-> StrictTVar m ControlMessage
getControlVar SingProtocolTemperature 'Hot
SingHot TemperatureBundle
  (ApplicationHandle muxMode responderCtx peerAddr ByteString m a b)
pchAppHandles) ControlMessage
Terminate

      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 ByteString m a b)
-> STM m (LastToFinishResult a)
forall (m :: * -> *) (pt :: ProtocolTemperature) (muxMude :: Mode)
       responderCtx peerAddr bytes a b.
MonadSTM m =>
SingProtocolTemperature pt
-> TemperatureBundle
     (ApplicationHandle muxMude responderCtx peerAddr bytes m a b)
-> STM m (LastToFinishResult a)
awaitAllResults SingProtocolTemperature 'Hot
SingHot TemperatureBundle
  (ApplicationHandle muxMode responderCtx peerAddr 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 ByteString m a b)
-> STM m (LastToFinishResult a)
forall (m :: * -> *) (pt :: ProtocolTemperature) (muxMude :: Mode)
       responderCtx peerAddr bytes a b.
MonadSTM m =>
SingProtocolTemperature pt
-> TemperatureBundle
     (ApplicationHandle muxMude responderCtx peerAddr bytes m a b)
-> STM m (LastToFinishResult a)
awaitAllResults SingProtocolTemperature 'Warm
SingWarm TemperatureBundle
  (ApplicationHandle muxMode responderCtx peerAddr 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 ByteString m a b)
-> STM m (LastToFinishResult a)
forall (m :: * -> *) (pt :: ProtocolTemperature) (muxMude :: Mode)
       responderCtx peerAddr bytes a b.
MonadSTM m =>
SingProtocolTemperature pt
-> TemperatureBundle
     (ApplicationHandle muxMude responderCtx peerAddr bytes m a b)
-> STM m (LastToFinishResult a)
awaitAllResults SingProtocolTemperature 'Established
SingEstablished TemperatureBundle
  (ApplicationHandle muxMode responderCtx peerAddr ByteString m a b)
pchAppHandles)
      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
          wasWarm <- 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)
          when wasWarm $
            traceWith spsTracer (PeerStatusChangeFailure
                                  (WarmToCooling pchConnectionId)
                                  TimeoutError)
          return wasWarm

        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.
          wasWarm <- 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)
          when wasWarm $
            traceWith spsTracer (PeerStatusChangeFailure
                                  (WarmToCooling pchConnectionId)
                                  (ApplicationFailure errs))
          throwIO (MiniProtocolExceptions 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 m)
  responderCtx
  peerAddr
  versionData
  versionNumber
  ByteString
  m
  a
  b
-> peerAddr -> m (OperationResult AbstractState)
forall (muxMode :: Mode) socket peerAddr handle handleError
       (m :: * -> *).
(HasInitiator muxMode ~ 'True) =>
ConnectionManager muxMode socket peerAddr handle handleError m
-> peerAddr -> m (OperationResult AbstractState)
releaseOutboundConnection MuxConnectionManager
  muxMode
  socket
  (ExpandedInitiatorContext peerAddr m)
  responderCtx
  peerAddr
  versionData
  versionNumber
  ByteString
  m
  a
  b
spsConnectionManager (ConnectionId peerAddr -> peerAddr
forall addr. ConnectionId addr -> addr
remoteAddress ConnectionId peerAddr
pchConnectionId)
          wasWarm <- atomically (updateUnlessCoolingOrCold pchPeerStatus PeerCooling)
          when wasWarm $
            traceWith spsTracer (PeerStatusChanged (WarmToCooling pchConnectionId))
          return wasWarm

--
-- Utilities
--


-- | Smart constructor for 'ApplicationHandle'.
--
mkApplicationHandleBundle
    :: forall (muxMode :: Mux.Mode) responderCtx peerAddr bytes m a b.
       OuroborosBundle muxMode (ExpandedInitiatorContext peerAddr 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 bytes m a b)
mkApplicationHandleBundle :: forall (muxMode :: Mode) responderCtx peerAddr bytes (m :: * -> *)
       a b.
OuroborosBundle
  muxMode
  (ExpandedInitiatorContext peerAddr m)
  responderCtx
  bytes
  m
  a
  b
-> TemperatureBundle (StrictTVar m ControlMessage)
-> TemperatureBundle
     (StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a))))
-> TemperatureBundle
     (ApplicationHandle muxMode responderCtx peerAddr bytes m a b)
mkApplicationHandleBundle OuroborosBundle
  muxMode
  (ExpandedInitiatorContext peerAddr 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 bytes m a b)
-> WithProtocolTemperature
     'Warm (ApplicationHandle muxMode responderCtx peerAddr bytes m a b)
-> WithProtocolTemperature
     'Established
     (ApplicationHandle muxMode responderCtx peerAddr bytes m a b)
-> TemperatureBundle
     (ApplicationHandle muxMode responderCtx peerAddr 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 bytes m a b)
forall (pt :: ProtocolTemperature).
SingProtocolTemperature pt
-> WithProtocolTemperature
     pt (ApplicationHandle muxMode responderCtx peerAddr bytes m a b)
mkApplication SingProtocolTemperature 'Hot
SingHot)
      (SingProtocolTemperature 'Warm
-> WithProtocolTemperature
     'Warm (ApplicationHandle muxMode responderCtx peerAddr bytes m a b)
forall (pt :: ProtocolTemperature).
SingProtocolTemperature pt
-> WithProtocolTemperature
     pt (ApplicationHandle muxMode responderCtx peerAddr bytes m a b)
mkApplication SingProtocolTemperature 'Warm
SingWarm)
      (SingProtocolTemperature 'Established
-> WithProtocolTemperature
     'Established
     (ApplicationHandle muxMode responderCtx peerAddr bytes m a b)
forall (pt :: ProtocolTemperature).
SingProtocolTemperature pt
-> WithProtocolTemperature
     pt (ApplicationHandle muxMode responderCtx peerAddr bytes m a b)
mkApplication SingProtocolTemperature 'Established
SingEstablished)
  where
    mkApplication :: SingProtocolTemperature pt
                  -> WithProtocolTemperature pt (ApplicationHandle muxMode responderCtx peerAddr bytes m a b)
    mkApplication :: forall (pt :: ProtocolTemperature).
SingProtocolTemperature pt
-> WithProtocolTemperature
     pt (ApplicationHandle muxMode responderCtx peerAddr bytes m a b)
mkApplication SingProtocolTemperature pt
tok =
      let app :: ApplicationHandle muxMode responderCtx peerAddr bytes m a b
app =
            ApplicationHandle {
              ahApplication :: [MiniProtocol
   muxMode
   (ExpandedInitiatorContext peerAddr m)
   responderCtx
   bytes
   m
   a
   b]
ahApplication         = SingProtocolTemperature pt
-> OuroborosBundle
     muxMode
     (ExpandedInitiatorContext peerAddr m)
     responderCtx
     bytes
     m
     a
     b
-> [MiniProtocol
      muxMode
      (ExpandedInitiatorContext peerAddr m)
      responderCtx
      bytes
      m
      a
      b]
forall (pt :: ProtocolTemperature) a.
SingProtocolTemperature pt -> TemperatureBundle a -> a
projectBundle SingProtocolTemperature pt
tok OuroborosBundle
  muxMode
  (ExpandedInitiatorContext peerAddr 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 bytes m a b
-> WithProtocolTemperature
     'Hot (ApplicationHandle muxMode responderCtx peerAddr bytes m a b)
forall a. a -> WithProtocolTemperature 'Hot a
WithHot ApplicationHandle muxMode responderCtx peerAddr bytes m a b
app
          SingProtocolTemperature pt
SingWarm        -> ApplicationHandle muxMode responderCtx peerAddr bytes m a b
-> WithProtocolTemperature
     'Warm (ApplicationHandle muxMode responderCtx peerAddr bytes m a b)
forall a. a -> WithProtocolTemperature 'Warm a
WithWarm ApplicationHandle muxMode responderCtx peerAddr bytes m a b
app
          SingProtocolTemperature pt
SingEstablished -> ApplicationHandle muxMode responderCtx peerAddr bytes m a b
-> WithProtocolTemperature
     'Established
     (ApplicationHandle muxMode responderCtx peerAddr bytes m a b)
forall a. a -> WithProtocolTemperature 'Established a
WithEstablished ApplicationHandle muxMode responderCtx peerAddr 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 versionData m a b.
                  ( Alternative (STM m)
                  , MonadAsync m
                  , MonadCatch m
                  , MonadThrow (STM m)
                  , HasInitiator muxMode ~ True
                  )
               => SingProtocolTemperature pt
               -> IsBigLedgerPeer
               -> PeerConnectionHandle muxMode responderCtx peerAddr versionData ByteString m a b
               -> m ()
startProtocols :: forall (muxMode :: Mode) (pt :: ProtocolTemperature) responderCtx
       peerAddr versionData (m :: * -> *) a b.
(Alternative (STM m), MonadAsync m, MonadCatch m,
 MonadThrow (STM m), HasInitiator muxMode ~ 'True) =>
SingProtocolTemperature pt
-> IsBigLedgerPeer
-> PeerConnectionHandle
     muxMode responderCtx peerAddr versionData ByteString m a b
-> m ()
startProtocols SingProtocolTemperature pt
tok IsBigLedgerPeer
isBigLedgerPeer connHandle :: PeerConnectionHandle
  muxMode responderCtx peerAddr versionData ByteString m a b
connHandle@PeerConnectionHandle { Mux muxMode m
pchMux :: forall (muxMode :: Mode) responderCtx peerAddr versionData bytes
       (m :: * -> *) a b.
PeerConnectionHandle
  muxMode responderCtx peerAddr versionData bytes m a b
-> Mux muxMode m
pchMux :: Mux muxMode m
pchMux, TemperatureBundle
  (ApplicationHandle muxMode responderCtx peerAddr ByteString m a b)
pchAppHandles :: forall (muxMode :: Mode) responderCtx peerAddr versionData bytes
       (m :: * -> *) a b.
PeerConnectionHandle
  muxMode responderCtx peerAddr versionData bytes m a b
-> TemperatureBundle
     (ApplicationHandle muxMode responderCtx peerAddr bytes m a b)
pchAppHandles :: TemperatureBundle
  (ApplicationHandle muxMode responderCtx peerAddr ByteString m a b)
pchAppHandles } = do
    let ptcls :: [MiniProtocol
   muxMode
   (ExpandedInitiatorContext peerAddr m)
   responderCtx
   ByteString
   m
   a
   b]
ptcls = SingProtocolTemperature pt
-> TemperatureBundle
     (ApplicationHandle muxMode responderCtx peerAddr ByteString m a b)
-> [MiniProtocol
      muxMode
      (ExpandedInitiatorContext peerAddr m)
      responderCtx
      ByteString
      m
      a
      b]
forall (pt :: ProtocolTemperature) (muxMode :: Mode) responderCtx
       peerAddr bytes (m :: * -> *) a b.
SingProtocolTemperature pt
-> TemperatureBundle
     (ApplicationHandle muxMode responderCtx peerAddr bytes m a b)
-> [MiniProtocol
      muxMode
      (ExpandedInitiatorContext peerAddr m)
      responderCtx
      bytes
      m
      a
      b]
getProtocols SingProtocolTemperature pt
tok TemperatureBundle
  (ApplicationHandle muxMode responderCtx peerAddr ByteString m a b)
pchAppHandles
    as <- (MiniProtocol
   muxMode
   (ExpandedInitiatorContext peerAddr m)
   responderCtx
   ByteString
   m
   a
   b
 -> m (STM m (Either SomeException a)))
-> [MiniProtocol
      muxMode
      (ExpandedInitiatorContext peerAddr 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 m)
  responderCtx
  ByteString
  m
  a
  b
-> m (STM m (Either SomeException a))
runInitiator [MiniProtocol
   muxMode
   (ExpandedInitiatorContext peerAddr 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 m)
                                         responderCtx ByteString m a b
                 -> m (STM m (Either SomeException a))
    runInitiator :: MiniProtocol
  muxMode
  (ExpandedInitiatorContext peerAddr 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 m)
  responderCtx
  ByteString
  m
  a
  b
miniProtocolRun :: RunMiniProtocol
  muxMode
  (ExpandedInitiatorContext peerAddr 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 m)
  responderCtx
  ByteString
  m
  a
  b
miniProtocolRun of
          InitiatorProtocolOnly MiniProtocolCb (ExpandedInitiatorContext peerAddr 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 m) ByteString m a
-> ExpandedInitiatorContext peerAddr 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 m) ByteString m a
initiator ExpandedInitiatorContext peerAddr m
context)
          InitiatorAndResponderProtocol MiniProtocolCb (ExpandedInitiatorContext peerAddr 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 m) ByteString m a
-> ExpandedInitiatorContext peerAddr 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 m) ByteString m a
initiator ExpandedInitiatorContext peerAddr m
context)
      where
        context :: ExpandedInitiatorContext peerAddr m
        context :: ExpandedInitiatorContext peerAddr m
context = SingProtocolTemperature pt
-> IsBigLedgerPeer
-> PeerConnectionHandle
     muxMode responderCtx peerAddr versionData ByteString m a b
-> ExpandedInitiatorContext peerAddr m
forall (m :: * -> *) (pt :: ProtocolTemperature) (muxMode :: Mode)
       responderCtx peerAddr versionDat bytes a b.
MonadSTM m =>
SingProtocolTemperature pt
-> IsBigLedgerPeer
-> PeerConnectionHandle
     muxMode responderCtx peerAddr versionDat bytes m a b
-> ExpandedInitiatorContext peerAddr m
mkInitiatorContext SingProtocolTemperature pt
tok IsBigLedgerPeer
isBigLedgerPeer PeerConnectionHandle
  muxMode responderCtx peerAddr 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
    | 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
  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