{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE KindSignatures      #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving  #-}
{-# LANGUAGE TupleSections       #-}

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

import           Control.Exception (SomeAsyncException (..))
import           Control.Monad (when)
import           Control.Monad.Class.MonadAsync
import           Control.Monad.Class.MonadSTM.Strict
import           Control.Monad.Class.MonadThrow
import           Control.Monad.Class.MonadTimer

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

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

import qualified Network.Mux as Mux

import           Ouroboros.Network.Channel (fromChannel)
import           Ouroboros.Network.ConnectionId
import           Ouroboros.Network.Mux
import           Ouroboros.Network.PeerSelection.Governor
                     (PeerStateActions (..))
import           Ouroboros.Network.PeerSelection.Types (PeerStatus (..))
import           Ouroboros.Network.Protocol.Handshake (HandshakeException)

import           Ouroboros.Network.ConnectionHandler (Handle (..),
                     HandleError (..), MuxConnectionManager)
import           Ouroboros.Network.ConnectionManager.Types

-- $doc
-- = Introduction
--
-- This module implements 'PeerStateActions', which provide the following
-- capabilities::
--
-- [synchronous promotions / demotions]:
--
--      * 'establishPeerConnection'
--      * 'activatePeerConnection'
--      * 'deactivatePeerConnection'
--      * 'closePeerConnection'
--
-- [asynchronous demotions]:
--
-- Monitor mini-protocols and act on mini-protocol state changes done via
-- 'monitorPeerConnection'.
--
--
-- = Synchronous promotions / demotions
--
-- Synchronous promotions / demotions are directly 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 quiesce 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
--    transfers 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.  Except termination of a hot
-- protocols we shall close the connection.  When one of the hot protocols
-- terminates we trigger a synchronous /hot → warm/ transition.
--
-- 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
-- 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.
--
--
-- Bellow 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        - 'pchPeerState' '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 'pchPeerState' 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.
  | NotRunning

hasReturnedFromEither :: Either SomeException a -> HasReturned a
hasReturnedFromEither :: 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
showList :: [MiniProtocolException] -> ShowS
$cshowList :: [MiniProtocolException] -> ShowS
show :: MiniProtocolException -> String
$cshow :: MiniProtocolException -> String
showsPrec :: Int -> MiniProtocolException -> ShowS
$cshowsPrec :: Int -> 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
showList :: [MiniProtocolExceptions] -> ShowS
$cshowList :: [MiniProtocolExceptions] -> ShowS
show :: MiniProtocolExceptions -> String
$cshow :: MiniProtocolExceptions -> String
showsPrec :: Int -> MiniProtocolExceptions -> ShowS
$cshowsPrec :: Int -> 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 bytes m a b = ApplicationHandle {
    -- | List of applications for the given peer temperature.
    --
    ApplicationHandle muxMode bytes m a b
-> [MiniProtocol muxMode bytes m a b]
ahApplication         :: [MiniProtocol muxMode bytes m a b],

    -- | 'ControlMessage' 'TVar' for the given peer temperature.
    --
    ApplicationHandle muxMode bytes m a b
-> StrictTVar m ControlMessage
ahControlVar          :: StrictTVar m ControlMessage,

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


--
-- Useful accessors
--

getControlVar :: TokProtocolTemperature pt
              -> Bundle (ApplicationHandle muxMode bytes m a b)
              -> StrictTVar m ControlMessage
getControlVar :: TokProtocolTemperature pt
-> Bundle (ApplicationHandle muxMode bytes m a b)
-> StrictTVar m ControlMessage
getControlVar TokProtocolTemperature pt
tok = ApplicationHandle muxMode bytes m a b
-> StrictTVar m ControlMessage
forall (muxMode :: MuxMode) bytes (m :: * -> *) a b.
ApplicationHandle muxMode bytes m a b
-> StrictTVar m ControlMessage
ahControlVar (ApplicationHandle muxMode bytes m a b
 -> StrictTVar m ControlMessage)
-> (Bundle (ApplicationHandle muxMode bytes m a b)
    -> ApplicationHandle muxMode bytes m a b)
-> Bundle (ApplicationHandle muxMode bytes m a b)
-> StrictTVar m ControlMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TokProtocolTemperature pt
-> Bundle (ApplicationHandle muxMode bytes m a b)
-> ApplicationHandle muxMode bytes m a b
forall (pt :: ProtocolTemperature) a.
TokProtocolTemperature pt -> Bundle a -> a
projectBundle TokProtocolTemperature pt
tok

getProtocols :: TokProtocolTemperature pt
             -> Bundle (ApplicationHandle muxMode bytes m a b)
             -> [MiniProtocol muxMode bytes m a b]
getProtocols :: TokProtocolTemperature pt
-> Bundle (ApplicationHandle muxMode bytes m a b)
-> [MiniProtocol muxMode bytes m a b]
getProtocols TokProtocolTemperature pt
tok Bundle (ApplicationHandle muxMode bytes m a b)
bundle = ApplicationHandle muxMode bytes m a b
-> [MiniProtocol muxMode bytes m a b]
forall (muxMode :: MuxMode) bytes (m :: * -> *) a b.
ApplicationHandle muxMode bytes m a b
-> [MiniProtocol muxMode bytes m a b]
ahApplication (TokProtocolTemperature pt
-> Bundle (ApplicationHandle muxMode bytes m a b)
-> ApplicationHandle muxMode bytes m a b
forall (pt :: ProtocolTemperature) a.
TokProtocolTemperature pt -> Bundle a -> a
projectBundle TokProtocolTemperature pt
tok Bundle (ApplicationHandle muxMode bytes m a b)
bundle)

getMiniProtocolsVar :: TokProtocolTemperature pt
                    -> Bundle (ApplicationHandle muxMode bytes m a b)
                    -> StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))
getMiniProtocolsVar :: TokProtocolTemperature pt
-> Bundle (ApplicationHandle muxMode bytes m a b)
-> StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))
getMiniProtocolsVar TokProtocolTemperature pt
tok = ApplicationHandle muxMode bytes m a b
-> StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))
forall (muxMode :: MuxMode) bytes (m :: * -> *) a b.
ApplicationHandle muxMode bytes m a b
-> StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))
ahMiniProtocolResults (ApplicationHandle muxMode bytes m a b
 -> StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a))))
-> (Bundle (ApplicationHandle muxMode bytes m a b)
    -> ApplicationHandle muxMode bytes m a b)
-> Bundle (ApplicationHandle muxMode bytes m a b)
-> StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TokProtocolTemperature pt
-> Bundle (ApplicationHandle muxMode bytes m a b)
-> ApplicationHandle muxMode bytes m a b
forall (pt :: ProtocolTemperature) a.
TokProtocolTemperature pt -> Bundle a -> a
projectBundle TokProtocolTemperature 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 sucessfuly.
    --
    -- 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
showList :: [FirstToFinishResult] -> ShowS
$cshowList :: [FirstToFinishResult] -> ShowS
show :: FirstToFinishResult -> String
$cshow :: FirstToFinishResult -> String
showsPrec :: Int -> FirstToFinishResult -> ShowS
$cshowsPrec :: Int -> 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 for first result from any of any of the protocols which belongs to
-- the indicated bundle.
--
awaitFirstResult :: MonadSTM m
                 => TokProtocolTemperature pt
                 -> Bundle (ApplicationHandle muxMode bytes m a b)
                 -> STM m FirstToFinishResult
awaitFirstResult :: TokProtocolTemperature pt
-> Bundle (ApplicationHandle muxMode bytes m a b)
-> STM m FirstToFinishResult
awaitFirstResult TokProtocolTemperature pt
tok Bundle (ApplicationHandle muxMode bytes m a b)
bundle = do
    Map MiniProtocolNum (STM m (HasReturned a))
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 (TokProtocolTemperature pt
-> Bundle (ApplicationHandle muxMode bytes m a b)
-> StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))
forall (pt :: ProtocolTemperature) (muxMode :: MuxMode) bytes
       (m :: * -> *) a b.
TokProtocolTemperature pt
-> Bundle (ApplicationHandle muxMode bytes m a b)
-> StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))
getMiniProtocolsVar TokProtocolTemperature pt
tok Bundle (ApplicationHandle muxMode bytes m a b)
bundle)
    (MiniProtocolNum
miniProtocolNum, HasReturned a
result)
      <- (MiniProtocolNum
 -> STM m (HasReturned a)
 -> STM m (MiniProtocolNum, HasReturned a)
 -> STM m (MiniProtocolNum, HasReturned a))
-> STM m (MiniProtocolNum, HasReturned a)
-> Map MiniProtocolNum (STM m (HasReturned a))
-> STM m (MiniProtocolNum, HasReturned a)
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
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 (m :: * -> *) a. MonadSTM m => STM m a -> STM m a -> STM m a
`orElse` STM m (MiniProtocolNum, HasReturned a)
acc)
                          STM m (MiniProtocolNum, HasReturned a)
forall (m :: * -> *) a. MonadSTM m => STM m a
retry Map MiniProtocolNum (STM m (HasReturned a))
d
    case HasReturned a
result of
      Errored  SomeException
e -> FirstToFinishResult -> STM m FirstToFinishResult
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 (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.
      HasReturned a
NotRunning -> STM m FirstToFinishResult
forall (m :: * -> *) a. MonadSTM m => STM m a
retry


-- | Data structure used in last-to-finish synchronisation 'awaitAll'.
--
data LastToFinishResult =
    AllSucceeded
  | SomeErrored ![MiniProtocolException]

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

instance Monoid LastToFinishResult where
    mempty :: LastToFinishResult
mempty = LastToFinishResult
AllSucceeded


-- | Last to finish synchronisation for mini-protocols of a given protocol
-- temperature.
--
awaitAllResults :: MonadSTM m
                => TokProtocolTemperature pt
                -> Bundle (ApplicationHandle muxMude bytes m a b)
                -> STM m LastToFinishResult
awaitAllResults :: TokProtocolTemperature pt
-> Bundle (ApplicationHandle muxMude bytes m a b)
-> STM m LastToFinishResult
awaitAllResults TokProtocolTemperature pt
tok Bundle (ApplicationHandle muxMude bytes m a b)
bundle = do
    Map MiniProtocolNum (HasReturned a)
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 (TokProtocolTemperature pt
-> Bundle (ApplicationHandle muxMude bytes m a b)
-> StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))
forall (pt :: ProtocolTemperature) (muxMode :: MuxMode) bytes
       (m :: * -> *) a b.
TokProtocolTemperature pt
-> Bundle (ApplicationHandle muxMode bytes m a b)
-> StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))
getMiniProtocolsVar TokProtocolTemperature pt
tok Bundle (ApplicationHandle muxMude 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 (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)
sequence
    LastToFinishResult -> STM m LastToFinishResult
forall (m :: * -> *) a. Monad m => a -> m a
return (LastToFinishResult -> STM m LastToFinishResult)
-> LastToFinishResult -> STM m LastToFinishResult
forall a b. (a -> b) -> a -> b
$ (MiniProtocolNum -> HasReturned a -> LastToFinishResult)
-> Map MiniProtocolNum (HasReturned a) -> LastToFinishResult
forall m k a. Monoid m => (k -> a -> m) -> Map k a -> m
Map.foldMapWithKey
               (\MiniProtocolNum
num HasReturned a
r -> case HasReturned a
r of
                          Errored  SomeException
e -> [MiniProtocolException] -> LastToFinishResult
SomeErrored [MiniProtocolNum -> SomeException -> MiniProtocolException
MiniProtocolException MiniProtocolNum
num SomeException
e]
                          Returned a
_ -> LastToFinishResult
AllSucceeded
                          HasReturned a
NotRunning -> LastToFinishResult
AllSucceeded)
               Map MiniProtocolNum (HasReturned a)
results


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


data PeerState
  = PeerStatus      !PeerStatus
  | PromotingToWarm
  | PromotingToHot
  | DemotingToWarm
  | DemotingToCold  !PeerStatus
  -- ^ 'DemotingToCold' also contains the initial state of the peer.
  deriving PeerState -> PeerState -> Bool
(PeerState -> PeerState -> Bool)
-> (PeerState -> PeerState -> Bool) -> Eq PeerState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PeerState -> PeerState -> Bool
$c/= :: PeerState -> PeerState -> Bool
== :: PeerState -> PeerState -> Bool
$c== :: PeerState -> PeerState -> Bool
Eq


-- | Return the current state of the peer, as it should be viewed by the
-- governor.
--
getCurrentState :: PeerState -> PeerStatus
getCurrentState :: PeerState -> PeerStatus
getCurrentState (PeerStatus PeerStatus
peerStatus)     = PeerStatus
peerStatus
getCurrentState PeerState
PromotingToWarm             = PeerStatus
PeerCold
getCurrentState PeerState
PromotingToHot              = PeerStatus
PeerWarm
getCurrentState PeerState
DemotingToWarm              = PeerStatus
PeerHot
getCurrentState (DemotingToCold PeerStatus
peerStatus) = PeerStatus
peerStatus


-- |  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 :: MuxMode) peerAddr bytes m a b = PeerConnectionHandle {
    PeerConnectionHandle muxMode peerAddr bytes m a b
-> ConnectionId peerAddr
pchConnectionId :: ConnectionId peerAddr,
    PeerConnectionHandle muxMode peerAddr bytes m a b
-> StrictTVar m PeerState
pchPeerState    :: StrictTVar m PeerState,
    PeerConnectionHandle muxMode peerAddr bytes m a b -> Mux muxMode m
pchMux          :: Mux.Mux muxMode m,
    PeerConnectionHandle muxMode peerAddr bytes m a b
-> Bundle (ApplicationHandle muxMode bytes m a b)
pchAppHandles   :: Bundle (ApplicationHandle muxMode bytes m a b)
  }

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

--
-- 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 :: 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 :: SomeException -> Maybe e
peerSelectionActionExceptionFromException SomeException
x = do
    PeerSelectionActionException e
e <- SomeException -> Maybe PeerSelectionActionException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
x
    e -> Maybe e
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast e
e


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
showList :: [EstablishConnectionException versionNumber] -> ShowS
$cshowList :: forall versionNumber.
Show versionNumber =>
[EstablishConnectionException versionNumber] -> ShowS
show :: EstablishConnectionException versionNumber -> String
$cshow :: forall versionNumber.
Show versionNumber =>
EstablishConnectionException versionNumber -> String
showsPrec :: Int -> EstablishConnectionException versionNumber -> ShowS
$cshowsPrec :: forall versionNumber.
Show versionNumber =>
Int -> 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)
    | CloseConnectionTimeout !(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
showList :: [PeerSelectionTimeoutException peerAddr] -> ShowS
$cshowList :: forall peerAddr.
Show peerAddr =>
[PeerSelectionTimeoutException peerAddr] -> ShowS
show :: PeerSelectionTimeoutException peerAddr -> String
$cshow :: forall peerAddr.
Show peerAddr =>
PeerSelectionTimeoutException peerAddr -> String
showsPrec :: Int -> PeerSelectionTimeoutException peerAddr -> ShowS
$cshowsPrec :: forall peerAddr.
Show peerAddr =>
Int -> 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
showList :: [ColdActionException peerAddr] -> ShowS
$cshowList :: forall peerAddr.
Show peerAddr =>
[ColdActionException peerAddr] -> ShowS
show :: ColdActionException peerAddr -> String
$cshow :: forall peerAddr.
Show peerAddr =>
ColdActionException peerAddr -> String
showsPrec :: Int -> ColdActionException peerAddr -> ShowS
$cshowsPrec :: forall peerAddr.
Show peerAddr =>
Int -> 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 peerAddr versionNumber m a b =
    PeerStateActionsArguments {

      PeerStateActionsArguments
  muxMode socket peerAddr versionNumber m a b
-> Tracer m (PeerSelectionActionsTrace peerAddr)
spsTracer                 :: Tracer m (PeerSelectionActionsTrace peerAddr),

      -- | Peer deactivation timeout: timeouts stopping hot protocols.
      --
      PeerStateActionsArguments
  muxMode socket peerAddr versionNumber m a b
-> DiffTime
spsDeactivateTimeout      :: DiffTime,

      -- | Timeout on closing connection: timeouts stopping established and warm
      -- peer protocols.
      --
      PeerStateActionsArguments
  muxMode socket peerAddr versionNumber m a b
-> DiffTime
spsCloseConnectionTimeout :: DiffTime,

      PeerStateActionsArguments
  muxMode socket peerAddr versionNumber m a b
-> MuxConnectionManager
     muxMode socket peerAddr versionNumber ByteString m a b
spsConnectionManager      :: MuxConnectionManager muxMode socket peerAddr versionNumber ByteString m a b
    }


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

withPeerStateActions :: PeerStateActionsArguments
  muxMode socket peerAddr versionNumber m a b
-> (PeerStateActions
      peerAddr (PeerConnectionHandle muxMode peerAddr ByteString m a b) m
    -> m x)
-> m x
withPeerStateActions PeerStateActionsArguments {
                       DiffTime
spsDeactivateTimeout :: DiffTime
spsDeactivateTimeout :: forall (muxMode :: MuxMode) socket peerAddr versionNumber
       (m :: * -> *) a b.
PeerStateActionsArguments
  muxMode socket peerAddr versionNumber m a b
-> DiffTime
spsDeactivateTimeout,
                       DiffTime
spsCloseConnectionTimeout :: DiffTime
spsCloseConnectionTimeout :: forall (muxMode :: MuxMode) socket peerAddr versionNumber
       (m :: * -> *) a b.
PeerStateActionsArguments
  muxMode socket peerAddr versionNumber m a b
-> DiffTime
spsCloseConnectionTimeout,
                       Tracer m (PeerSelectionActionsTrace peerAddr)
spsTracer :: Tracer m (PeerSelectionActionsTrace peerAddr)
spsTracer :: forall (muxMode :: MuxMode) socket peerAddr versionNumber
       (m :: * -> *) a b.
PeerStateActionsArguments
  muxMode socket peerAddr versionNumber m a b
-> Tracer m (PeerSelectionActionsTrace peerAddr)
spsTracer,
                       MuxConnectionManager
  muxMode socket peerAddr versionNumber ByteString m a b
spsConnectionManager :: MuxConnectionManager
  muxMode socket peerAddr versionNumber ByteString m a b
spsConnectionManager :: forall (muxMode :: MuxMode) socket peerAddr versionNumber
       (m :: * -> *) a b.
PeerStateActionsArguments
  muxMode socket peerAddr versionNumber m a b
-> MuxConnectionManager
     muxMode socket peerAddr versionNumber ByteString m a b
spsConnectionManager
                     }
                     PeerStateActions
  peerAddr (PeerConnectionHandle muxMode peerAddr ByteString m a b) m
-> m x
k = do
    (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 peerAddr ByteString m a b) m
-> m x
k PeerStateActions :: forall peeraddr peerconn (m :: * -> *).
(peerconn -> STM m PeerStatus)
-> (peeraddr -> m peerconn)
-> (peerconn -> m ())
-> (peerconn -> m ())
-> (peerconn -> m ())
-> PeerStateActions peeraddr peerconn m
PeerStateActions {
          establishPeerConnection :: peerAddr
-> m (PeerConnectionHandle muxMode peerAddr ByteString m a b)
establishPeerConnection = JobPool () m (Maybe SomeException)
-> peerAddr
-> m (PeerConnectionHandle muxMode peerAddr ByteString m a b)
establishPeerConnection JobPool () m (Maybe SomeException)
jobPool,
          PeerConnectionHandle muxMode peerAddr ByteString m a b
-> STM m PeerStatus
monitorPeerConnection :: PeerConnectionHandle muxMode peerAddr ByteString m a b
-> STM m PeerStatus
monitorPeerConnection :: PeerConnectionHandle muxMode peerAddr ByteString m a b
-> STM m PeerStatus
monitorPeerConnection,
          PeerConnectionHandle muxMode peerAddr ByteString m a b -> m ()
activatePeerConnection :: PeerConnectionHandle muxMode peerAddr ByteString m a b -> m ()
activatePeerConnection :: PeerConnectionHandle muxMode peerAddr ByteString m a b -> m ()
activatePeerConnection,
          PeerConnectionHandle muxMode peerAddr ByteString m a b -> m ()
deactivatePeerConnection :: PeerConnectionHandle muxMode peerAddr ByteString m a b -> m ()
deactivatePeerConnection :: PeerConnectionHandle muxMode peerAddr ByteString m a b -> m ()
deactivatePeerConnection,
          PeerConnectionHandle muxMode peerAddr ByteString m a b -> m ()
closePeerConnection :: PeerConnectionHandle muxMode peerAddr ByteString m a b -> m ()
closePeerConnection :: PeerConnectionHandle muxMode peerAddr ByteString m a b -> m ()
closePeerConnection
        }

  where

    -- Update PeerState with the new state only if the current state isn't
    -- cold. Returns True if the state wasn't PeerCold
    updateUnlessCold :: StrictTVar m PeerState -> PeerState -> STM m Bool
    updateUnlessCold :: StrictTVar m PeerState -> PeerState -> STM m Bool
updateUnlessCold StrictTVar m PeerState
stateVar PeerState
newState = do
      PeerStatus
status <- PeerState -> PeerStatus
getCurrentState (PeerState -> PeerStatus) -> STM m PeerState -> STM m PeerStatus
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar m PeerState -> STM m PeerState
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m PeerState
stateVar
      if PeerStatus
status PeerStatus -> PeerStatus -> Bool
forall a. Eq a => a -> a -> Bool
== PeerStatus
PeerCold
         then Bool -> STM m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
         else StrictTVar m PeerState -> PeerState -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m PeerState
stateVar PeerState
newState STM m () -> STM m Bool -> STM m Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> STM m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True


    peerMonitoringLoop
      :: PeerConnectionHandle muxMode peerAddr ByteString m a b
      -> m ()
    peerMonitoringLoop :: PeerConnectionHandle muxMode peerAddr ByteString m a b -> m ()
peerMonitoringLoop pch :: PeerConnectionHandle muxMode peerAddr ByteString m a b
pch@PeerConnectionHandle { ConnectionId peerAddr
pchConnectionId :: ConnectionId peerAddr
pchConnectionId :: forall (muxMode :: MuxMode) peerAddr bytes (m :: * -> *) a b.
PeerConnectionHandle muxMode peerAddr bytes m a b
-> ConnectionId peerAddr
pchConnectionId, StrictTVar m PeerState
pchPeerState :: StrictTVar m PeerState
pchPeerState :: forall (muxMode :: MuxMode) peerAddr bytes (m :: * -> *) a b.
PeerConnectionHandle muxMode peerAddr bytes m a b
-> StrictTVar m PeerState
pchPeerState, Bundle (ApplicationHandle muxMode ByteString m a b)
pchAppHandles :: Bundle (ApplicationHandle muxMode ByteString m a b)
pchAppHandles :: forall (muxMode :: MuxMode) peerAddr bytes (m :: * -> *) a b.
PeerConnectionHandle muxMode peerAddr bytes m a b
-> Bundle (ApplicationHandle muxMode bytes 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.
        WithSomeProtocolTemperature FirstToFinishResult
r <-
          STM m (WithSomeProtocolTemperature FirstToFinishResult)
-> m (WithSomeProtocolTemperature FirstToFinishResult)
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (WithSomeProtocolTemperature FirstToFinishResult)
 -> m (WithSomeProtocolTemperature FirstToFinishResult))
-> STM m (WithSomeProtocolTemperature FirstToFinishResult)
-> m (WithSomeProtocolTemperature FirstToFinishResult)
forall a b. (a -> b) -> a -> b
$
            (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
 -> WithSomeProtocolTemperature FirstToFinishResult)
-> STM m FirstToFinishResult
-> STM m (WithSomeProtocolTemperature FirstToFinishResult)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TokProtocolTemperature 'Established
-> Bundle (ApplicationHandle muxMode ByteString m a b)
-> STM m FirstToFinishResult
forall (m :: * -> *) (pt :: ProtocolTemperature)
       (muxMode :: MuxMode) bytes a b.
MonadSTM m =>
TokProtocolTemperature pt
-> Bundle (ApplicationHandle muxMode bytes m a b)
-> STM m FirstToFinishResult
awaitFirstResult TokProtocolTemperature 'Established
TokEstablished Bundle (ApplicationHandle muxMode ByteString m a b)
pchAppHandles)
          STM m (WithSomeProtocolTemperature FirstToFinishResult)
-> STM m (WithSomeProtocolTemperature FirstToFinishResult)
-> STM m (WithSomeProtocolTemperature FirstToFinishResult)
forall (m :: * -> *) a. MonadSTM m => STM m a -> STM m a -> STM m a
`orElse`
            (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
 -> WithSomeProtocolTemperature FirstToFinishResult)
-> STM m FirstToFinishResult
-> STM m (WithSomeProtocolTemperature FirstToFinishResult)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TokProtocolTemperature 'Warm
-> Bundle (ApplicationHandle muxMode ByteString m a b)
-> STM m FirstToFinishResult
forall (m :: * -> *) (pt :: ProtocolTemperature)
       (muxMode :: MuxMode) bytes a b.
MonadSTM m =>
TokProtocolTemperature pt
-> Bundle (ApplicationHandle muxMode bytes m a b)
-> STM m FirstToFinishResult
awaitFirstResult TokProtocolTemperature 'Warm
TokWarm Bundle (ApplicationHandle muxMode ByteString m a b)
pchAppHandles)
          STM m (WithSomeProtocolTemperature FirstToFinishResult)
-> STM m (WithSomeProtocolTemperature FirstToFinishResult)
-> STM m (WithSomeProtocolTemperature FirstToFinishResult)
forall (m :: * -> *) a. MonadSTM m => STM m a -> STM m a -> STM m a
`orElse`
            (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
 -> WithSomeProtocolTemperature FirstToFinishResult)
-> STM m FirstToFinishResult
-> STM m (WithSomeProtocolTemperature FirstToFinishResult)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TokProtocolTemperature 'Hot
-> Bundle (ApplicationHandle muxMode ByteString m a b)
-> STM m FirstToFinishResult
forall (m :: * -> *) (pt :: ProtocolTemperature)
       (muxMode :: MuxMode) bytes a b.
MonadSTM m =>
TokProtocolTemperature pt
-> Bundle (ApplicationHandle muxMode bytes m a b)
-> STM m FirstToFinishResult
awaitFirstResult TokProtocolTemperature 'Hot
TokHot Bundle (ApplicationHandle muxMode ByteString m a b)
pchAppHandles)

        Tracer m (PeerSelectionActionsTrace peerAddr)
-> PeerSelectionActionsTrace peerAddr -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (PeerSelectionActionsTrace peerAddr)
spsTracer (ConnectionId peerAddr
-> WithSomeProtocolTemperature FirstToFinishResult
-> PeerSelectionActionsTrace peerAddr
forall peerAddr.
ConnectionId peerAddr
-> WithSomeProtocolTemperature FirstToFinishResult
-> PeerSelectionActionsTrace peerAddr
PeerMonitoringResult ConnectionId peerAddr
pchConnectionId WithSomeProtocolTemperature FirstToFinishResult
r)
        case WithSomeProtocolTemperature FirstToFinishResult
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.
          --
          WithSomeProtocolTemperature (WithHot MiniProtocolError{}) -> do
            Tracer m (PeerSelectionActionsTrace peerAddr)
-> PeerSelectionActionsTrace peerAddr -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (PeerSelectionActionsTrace peerAddr)
spsTracer (PeerStatusChangeType peerAddr -> PeerSelectionActionsTrace peerAddr
forall peerAddr.
PeerStatusChangeType peerAddr -> PeerSelectionActionsTrace peerAddr
PeerStatusChanged (ConnectionId peerAddr -> PeerStatusChangeType peerAddr
forall peerAddr.
ConnectionId peerAddr -> PeerStatusChangeType peerAddr
HotToCold ConnectionId peerAddr
pchConnectionId))
            STM m () -> m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (StrictTVar m PeerState -> PeerState -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m PeerState
pchPeerState (PeerStatus -> PeerState
PeerStatus PeerStatus
PeerCold))
          WithSomeProtocolTemperature (WithWarm MiniProtocolError{}) -> do
            Tracer m (PeerSelectionActionsTrace peerAddr)
-> PeerSelectionActionsTrace peerAddr -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (PeerSelectionActionsTrace peerAddr)
spsTracer (PeerStatusChangeType peerAddr -> PeerSelectionActionsTrace peerAddr
forall peerAddr.
PeerStatusChangeType peerAddr -> PeerSelectionActionsTrace peerAddr
PeerStatusChanged (ConnectionId peerAddr -> PeerStatusChangeType peerAddr
forall peerAddr.
ConnectionId peerAddr -> PeerStatusChangeType peerAddr
WarmToCold ConnectionId peerAddr
pchConnectionId))
            STM m () -> m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (StrictTVar m PeerState -> PeerState -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m PeerState
pchPeerState (PeerStatus -> PeerState
PeerStatus PeerStatus
PeerCold))
          WithSomeProtocolTemperature (WithEstablished MiniProtocolError{}) -> do
            -- update 'pchPeerState' and log (as the two other transition to
            -- cold state.
            PeerState
state <- STM m PeerState -> m PeerState
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m PeerState -> m PeerState) -> STM m PeerState -> m PeerState
forall a b. (a -> b) -> a -> b
$ do
              PeerState
peerState <- StrictTVar m PeerState -> STM m PeerState
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m PeerState
pchPeerState
              StrictTVar m PeerState -> PeerState -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m PeerState
pchPeerState (PeerStatus -> PeerState
PeerStatus PeerStatus
PeerCold)
              PeerState -> STM m PeerState
forall (f :: * -> *) a. Applicative f => a -> f a
pure PeerState
peerState
            case PeerState -> PeerStatus
getCurrentState PeerState
state of
              PeerStatus
PeerCold -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
              PeerStatus
PeerWarm -> Tracer m (PeerSelectionActionsTrace peerAddr)
-> PeerSelectionActionsTrace peerAddr -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (PeerSelectionActionsTrace peerAddr)
spsTracer (PeerStatusChangeType peerAddr -> PeerSelectionActionsTrace peerAddr
forall peerAddr.
PeerStatusChangeType peerAddr -> PeerSelectionActionsTrace peerAddr
PeerStatusChanged (ConnectionId peerAddr -> PeerStatusChangeType peerAddr
forall peerAddr.
ConnectionId peerAddr -> PeerStatusChangeType peerAddr
WarmToCold ConnectionId peerAddr
pchConnectionId))
              PeerStatus
PeerHot  -> Tracer m (PeerSelectionActionsTrace peerAddr)
-> PeerSelectionActionsTrace peerAddr -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (PeerSelectionActionsTrace peerAddr)
spsTracer (PeerStatusChangeType peerAddr -> PeerSelectionActionsTrace peerAddr
forall peerAddr.
PeerStatusChangeType peerAddr -> PeerSelectionActionsTrace peerAddr
PeerStatusChanged (ConnectionId peerAddr -> PeerStatusChangeType peerAddr
forall peerAddr.
ConnectionId peerAddr -> PeerStatusChangeType peerAddr
HotToCold ConnectionId peerAddr
pchConnectionId))

          --
          -- Successful termination
          --

          -- A /hot/ protocol terminated, we deactivate the connection and keep
          -- monitoring /warm/ and /established/ protocols.
          WithSomeProtocolTemperature (WithHot MiniProtocolSuccess {}) -> do
            PeerConnectionHandle muxMode peerAddr ByteString m a b -> m ()
deactivatePeerConnection PeerConnectionHandle muxMode peerAddr ByteString m a b
pch m () -> [Handler m ()] -> m ()
forall (m :: * -> *) a. MonadCatch m => m a -> [Handler m a] -> m a
`catches` [Handler m ()]
handlers
            PeerConnectionHandle muxMode peerAddr ByteString m a b -> m ()
peerMonitoringLoop PeerConnectionHandle muxMode peerAddr ByteString m a b
pch

          -- If an /established/ or /warm/ we demote the peer to 'PeerCold'.
          -- Warm protocols are quieced 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).
          WithSomeProtocolTemperature (WithWarm MiniProtocolSuccess {}) ->
            PeerConnectionHandle muxMode peerAddr ByteString m a b -> m ()
closePeerConnection PeerConnectionHandle muxMode peerAddr ByteString m a b
pch m () -> [Handler m ()] -> m ()
forall (m :: * -> *) a. MonadCatch m => m a -> [Handler m a] -> m a
`catches` [Handler m ()]
handlers
          WithSomeProtocolTemperature (WithEstablished MiniProtocolSuccess {}) ->
            PeerConnectionHandle muxMode peerAddr ByteString m a b -> m ()
closePeerConnection PeerConnectionHandle muxMode peerAddr ByteString m a b
pch m () -> [Handler m ()] -> m ()
forall (m :: * -> *) a. MonadCatch m => m a -> [Handler m a] -> m a
`catches` [Handler m ()]
handlers

      where
        -- 'closePeerConnection' and 'deactivatePeerConnection' actions can
        -- throw exceptions, but they maintain consistency of 'peerStateVar',
        -- that's why these handlers are trivial.
        handlers :: [Handler m ()]
        handlers :: [Handler m ()]
handlers =
          [ (PeerSelectionActionException -> m ()) -> Handler m ()
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler (\(PeerSelectionActionException
_ :: PeerSelectionActionException)               -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()),
            (EstablishConnectionException versionNumber -> m ())
-> Handler m ()
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler (\(EstablishConnectionException versionNumber
_ :: EstablishConnectionException versionNumber) -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()),
            (PeerSelectionTimeoutException peerAddr -> m ()) -> Handler m ()
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler (\(PeerSelectionTimeoutException peerAddr
_ :: PeerSelectionTimeoutException peerAddr)     -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
          ]



    establishPeerConnection :: JobPool () m (Maybe SomeException)
                            -> peerAddr
                            -> m (PeerConnectionHandle muxMode peerAddr ByteString m a b)
    establishPeerConnection :: JobPool () m (Maybe SomeException)
-> peerAddr
-> m (PeerConnectionHandle muxMode peerAddr ByteString m a b)
establishPeerConnection JobPool () m (Maybe SomeException)
jobPool peerAddr
remotePeerAddr =
      -- Protect consistency of the peer state with 'bracketOnError' if
      -- opening a connection fails.
      m (StrictTVar m PeerState)
-> (StrictTVar m PeerState -> m ())
-> (StrictTVar m PeerState
    -> m (PeerConnectionHandle muxMode peerAddr ByteString m a b))
-> m (PeerConnectionHandle muxMode peerAddr ByteString m a b)
forall (m :: * -> *) a b c.
MonadCatch m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracketOnError
        (PeerState -> m (StrictTVar m PeerState)
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
newTVarIO PeerState
PromotingToWarm)
        (\StrictTVar m PeerState
peerStateVar -> STM m () -> m ()
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 PeerState -> PeerState -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m PeerState
peerStateVar (PeerStatus -> PeerState
PeerStatus PeerStatus
PeerCold))
        ((StrictTVar m PeerState
  -> m (PeerConnectionHandle muxMode peerAddr ByteString m a b))
 -> m (PeerConnectionHandle muxMode peerAddr ByteString m a b))
-> (StrictTVar m PeerState
    -> m (PeerConnectionHandle muxMode peerAddr ByteString m a b))
-> m (PeerConnectionHandle muxMode peerAddr ByteString m a b)
forall a b. (a -> b) -> a -> b
$ \StrictTVar m PeerState
peerStateVar -> do
          Connected
  peerAddr
  (Handle muxMode peerAddr ByteString m a b)
  (HandleError muxMode versionNumber)
res <- MuxConnectionManager
  muxMode socket peerAddr versionNumber ByteString m a b
-> RequestOutboundConnection
     peerAddr
     (Handle muxMode peerAddr ByteString m a b)
     (HandleError muxMode versionNumber)
     m
forall (muxMode :: MuxMode) socket peerAddr handle handleError
       (m :: * -> *).
(HasInitiator muxMode ~ 'True) =>
ConnectionManager muxMode socket peerAddr handle handleError m
-> RequestOutboundConnection peerAddr handle handleError m
requestOutboundConnection MuxConnectionManager
  muxMode socket peerAddr versionNumber ByteString m a b
spsConnectionManager peerAddr
remotePeerAddr
          case Connected
  peerAddr
  (Handle muxMode peerAddr ByteString m a b)
  (HandleError muxMode versionNumber)
res of
            Connected connectionId :: ConnectionId peerAddr
connectionId@ConnectionId { peerAddr
localAddress :: forall addr. ConnectionId addr -> addr
localAddress :: peerAddr
localAddress, peerAddr
remoteAddress :: forall addr. ConnectionId addr -> addr
remoteAddress :: peerAddr
remoteAddress }
                      DataFlow
_dataFlow
                      (Handle Mux muxMode m
mux MuxBundle muxMode ByteString m a b
muxBundle Bundle (StrictTVar m ControlMessage)
controlMessageBundle) -> do

              STM m () -> m ()
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, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar (TokProtocolTemperature 'Hot
-> Bundle (StrictTVar m ControlMessage)
-> StrictTVar m ControlMessage
forall (pt :: ProtocolTemperature) a.
TokProtocolTemperature pt -> Bundle a -> a
projectBundle TokProtocolTemperature 'Hot
TokHot         Bundle (StrictTVar m ControlMessage)
controlMessageBundle) ControlMessage
Terminate
                StrictTVar m ControlMessage -> ControlMessage -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar (TokProtocolTemperature 'Warm
-> Bundle (StrictTVar m ControlMessage)
-> StrictTVar m ControlMessage
forall (pt :: ProtocolTemperature) a.
TokProtocolTemperature pt -> Bundle a -> a
projectBundle TokProtocolTemperature 'Warm
TokWarm        Bundle (StrictTVar m ControlMessage)
controlMessageBundle) ControlMessage
Continue
                StrictTVar m ControlMessage -> ControlMessage -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar (TokProtocolTemperature 'Established
-> Bundle (StrictTVar m ControlMessage)
-> StrictTVar m ControlMessage
forall (pt :: ProtocolTemperature) a.
TokProtocolTemperature pt -> Bundle a -> a
projectBundle TokProtocolTemperature 'Established
TokEstablished Bundle (StrictTVar m ControlMessage)
controlMessageBundle) ControlMessage
Continue

              Bundle (StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a))))
awaitVarBundle <- STM
  m
  (Bundle
     (StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))))
-> m (Bundle
        (StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))))
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM
   m
   (Bundle
      (StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))))
 -> m (Bundle
         (StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a))))))
-> STM
     m
     (Bundle
        (StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))))
-> m (Bundle
        (StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))))
forall a b. (a -> b) -> a -> b
$ MuxBundle muxMode ByteString m a b
-> STM
     m
     (Bundle
        (StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))))
mkAwaitVars MuxBundle muxMode ByteString m a b
muxBundle

              let connHandle :: PeerConnectionHandle muxMode peerAddr ByteString m a b
connHandle =
                    PeerConnectionHandle :: forall (muxMode :: MuxMode) peerAddr bytes (m :: * -> *) a b.
ConnectionId peerAddr
-> StrictTVar m PeerState
-> Mux muxMode m
-> Bundle (ApplicationHandle muxMode bytes m a b)
-> PeerConnectionHandle muxMode peerAddr bytes m a b
PeerConnectionHandle {
                        pchConnectionId :: ConnectionId peerAddr
pchConnectionId = ConnectionId peerAddr
connectionId,
                        pchPeerState :: StrictTVar m PeerState
pchPeerState    = StrictTVar m PeerState
peerStateVar,
                        pchMux :: Mux muxMode m
pchMux          = Mux muxMode m
mux,
                        pchAppHandles :: Bundle (ApplicationHandle muxMode ByteString m a b)
pchAppHandles   = MuxBundle muxMode ByteString m a b
-> Bundle (StrictTVar m ControlMessage)
-> Bundle
     (StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a))))
-> Bundle (ApplicationHandle muxMode ByteString m a b)
forall (muxMode :: MuxMode) bytes (m :: * -> *) a b.
MuxBundle muxMode bytes m a b
-> Bundle (StrictTVar m ControlMessage)
-> Bundle
     (StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a))))
-> Bundle (ApplicationHandle muxMode bytes m a b)
mkApplicationHandleBundle
                                            MuxBundle muxMode ByteString m a b
muxBundle
                                            Bundle (StrictTVar m ControlMessage)
controlMessageBundle
                                            Bundle (StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a))))
awaitVarBundle
                      }

              TokProtocolTemperature 'Warm
-> PeerConnectionHandle muxMode peerAddr ByteString m a b -> m ()
forall (muxMode :: MuxMode) (pt :: ProtocolTemperature) peerAddr
       (m :: * -> *) a b.
(MonadAsync m, MonadCatch m, MonadThrow (STM m),
 HasInitiator muxMode ~ 'True) =>
TokProtocolTemperature pt
-> PeerConnectionHandle muxMode peerAddr ByteString m a b -> m ()
startProtocols TokProtocolTemperature 'Warm
TokWarm PeerConnectionHandle muxMode peerAddr ByteString m a b
connHandle
              TokProtocolTemperature 'Established
-> PeerConnectionHandle muxMode peerAddr ByteString m a b -> m ()
forall (muxMode :: MuxMode) (pt :: ProtocolTemperature) peerAddr
       (m :: * -> *) a b.
(MonadAsync m, MonadCatch m, MonadThrow (STM m),
 HasInitiator muxMode ~ 'True) =>
TokProtocolTemperature pt
-> PeerConnectionHandle muxMode peerAddr ByteString m a b -> m ()
startProtocols TokProtocolTemperature 'Established
TokEstablished PeerConnectionHandle muxMode peerAddr ByteString m a b
connHandle
              STM m () -> m ()
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 PeerState -> PeerState -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m PeerState
peerStateVar (PeerStatus -> PeerState
PeerStatus PeerStatus
PeerWarm)
              Tracer m (PeerSelectionActionsTrace peerAddr)
-> PeerSelectionActionsTrace peerAddr -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (PeerSelectionActionsTrace peerAddr)
spsTracer (PeerStatusChangeType peerAddr -> PeerSelectionActionsTrace peerAddr
forall peerAddr.
PeerStatusChangeType peerAddr -> PeerSelectionActionsTrace peerAddr
PeerStatusChanged
                                    (Maybe peerAddr -> peerAddr -> PeerStatusChangeType peerAddr
forall peerAddr.
Maybe peerAddr -> peerAddr -> PeerStatusChangeType peerAddr
ColdToWarm
                                      (peerAddr -> Maybe peerAddr
forall a. a -> Maybe a
Just peerAddr
localAddress)
                                      peerAddr
remoteAddress))

              JobPool () m (Maybe SomeException)
-> Job () m (Maybe SomeException) -> m ()
forall group (m :: * -> *) a.
(MonadAsync m, MonadMask m, Ord group) =>
JobPool group m a -> Job group m a -> m ()
JobPool.forkJob JobPool () m (Maybe SomeException)
jobPool
                              (m (Maybe SomeException)
-> (SomeException -> m (Maybe SomeException))
-> ()
-> String
-> Job () m (Maybe SomeException)
forall group (m :: * -> *) a.
m a -> (SomeException -> m a) -> group -> String -> Job group m a
Job ((SomeException -> Maybe SomeException)
-> (SomeException -> m (Maybe SomeException))
-> m (Maybe SomeException)
-> m (Maybe SomeException)
forall (m :: * -> *) e b a.
(MonadCatch m, Exception e) =>
(e -> Maybe b) -> (b -> m a) -> m a -> m a
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
                                        Tracer m (PeerSelectionActionsTrace peerAddr)
-> PeerSelectionActionsTrace peerAddr -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (PeerSelectionActionsTrace peerAddr)
spsTracer (ConnectionId peerAddr
-> SomeException -> PeerSelectionActionsTrace peerAddr
forall peerAddr.
ConnectionId peerAddr
-> SomeException -> PeerSelectionActionsTrace peerAddr
PeerMonitoringError ConnectionId peerAddr
connectionId SomeException
e)
                                        SomeException -> m (Maybe SomeException)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO SomeException
e)
                                     (PeerConnectionHandle muxMode peerAddr ByteString m a b -> m ()
peerMonitoringLoop PeerConnectionHandle muxMode peerAddr ByteString m a b
connHandle m () -> Maybe SomeException -> m (Maybe SomeException)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Maybe SomeException
forall a. Maybe a
Nothing))
                                   (Maybe SomeException -> m (Maybe SomeException)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SomeException -> m (Maybe SomeException))
-> (SomeException -> Maybe SomeException)
-> SomeException
-> m (Maybe SomeException)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just)
                                   ()
                                   (String
"peerMonitoringLoop " String -> ShowS
forall a. [a] -> [a] -> [a]
++ peerAddr -> String
forall a. Show a => a -> String
show peerAddr
remoteAddress))
              PeerConnectionHandle muxMode peerAddr ByteString m a b
-> m (PeerConnectionHandle muxMode peerAddr ByteString m a b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure PeerConnectionHandle muxMode peerAddr ByteString m a b
connHandle

            Disconnected ConnectionId peerAddr
_ Maybe (HandleError muxMode versionNumber)
Nothing ->
              -- Disconnected in 'TerminatingState' or 'TerminatedState' without
              -- an exception.
              IOError
-> m (PeerConnectionHandle muxMode peerAddr ByteString m a b)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (IOError
 -> m (PeerConnectionHandle muxMode peerAddr ByteString m a b))
-> IOError
-> m (PeerConnectionHandle muxMode peerAddr ByteString m a b)
forall a b. (a -> b) -> a -> b
$ String -> IOError
userError String
"establishPeerConnection: Disconnected"
            Disconnected ConnectionId peerAddr
_ (Just HandleError muxMode versionNumber
reason) ->
              case HandleError muxMode versionNumber
reason of
                HandleHandshakeClientError HandshakeException versionNumber
err -> do
                  Tracer m (PeerSelectionActionsTrace peerAddr)
-> PeerSelectionActionsTrace peerAddr -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (PeerSelectionActionsTrace peerAddr)
spsTracer (PeerStatusChangeType peerAddr
-> FailureType -> PeerSelectionActionsTrace peerAddr
forall peerAddr.
PeerStatusChangeType peerAddr
-> FailureType -> PeerSelectionActionsTrace peerAddr
PeerStatusChangeFailure
                                        (Maybe peerAddr -> peerAddr -> PeerStatusChangeType peerAddr
forall peerAddr.
Maybe peerAddr -> peerAddr -> PeerStatusChangeType peerAddr
ColdToWarm Maybe peerAddr
forall a. Maybe a
Nothing peerAddr
remotePeerAddr)
                                        FailureType
HandshakeClientFailure)
                  EstablishConnectionException versionNumber
-> m (PeerConnectionHandle muxMode peerAddr ByteString m a b)
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)
-> PeerSelectionActionsTrace peerAddr -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (PeerSelectionActionsTrace peerAddr)
spsTracer (PeerStatusChangeType peerAddr
-> FailureType -> PeerSelectionActionsTrace peerAddr
forall peerAddr.
PeerStatusChangeType peerAddr
-> FailureType -> PeerSelectionActionsTrace peerAddr
PeerStatusChangeFailure
                                        (Maybe peerAddr -> peerAddr -> PeerStatusChangeType peerAddr
forall peerAddr.
Maybe peerAddr -> peerAddr -> PeerStatusChangeType peerAddr
ColdToWarm Maybe peerAddr
forall a. Maybe a
Nothing peerAddr
remotePeerAddr)
                                        FailureType
HandshakeServerFailure)
                  EstablishConnectionException versionNumber
-> m (PeerConnectionHandle muxMode peerAddr ByteString m a b)
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)
-> PeerSelectionActionsTrace peerAddr -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (PeerSelectionActionsTrace peerAddr)
spsTracer (PeerStatusChangeType peerAddr
-> FailureType -> PeerSelectionActionsTrace peerAddr
forall peerAddr.
PeerStatusChangeType peerAddr
-> FailureType -> PeerSelectionActionsTrace peerAddr
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
HandleFailure SomeException
err))
                  SomeException
-> m (PeerConnectionHandle muxMode peerAddr ByteString m a b)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO SomeException
err
      where
        mkAwaitVars :: MuxBundle muxMode ByteString m a b
                    -> STM m (Bundle
                               (StrictTVar m
                                 (Map MiniProtocolNum
                                   (STM m (HasReturned a)))))
        mkAwaitVars :: MuxBundle muxMode ByteString m a b
-> STM
     m
     (Bundle
        (StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))))
mkAwaitVars = ([MiniProtocol muxMode ByteString m a b]
 -> STM
      m (StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))))
-> MuxBundle muxMode ByteString m a b
-> STM
     m
     (Bundle
        (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)
traverse [MiniProtocol muxMode ByteString m a b]
-> STM
     m (StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a))))
f
          where
            f :: [MiniProtocol muxMode ByteString m a b]
              -> STM m (StrictTVar m
                         (Map MiniProtocolNum
                           (STM m (HasReturned a))))
            f :: [MiniProtocol muxMode 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 ByteString m a b]
    -> Map MiniProtocolNum (STM m (HasReturned a)))
-> [MiniProtocol muxMode 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 ByteString m a b]
    -> [(MiniProtocolNum, STM m (HasReturned a))])
-> [MiniProtocol muxMode ByteString m a b]
-> Map MiniProtocolNum (STM m (HasReturned a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MiniProtocol muxMode ByteString m a b
 -> (MiniProtocolNum, STM m (HasReturned a)))
-> [MiniProtocol muxMode ByteString m a b]
-> [(MiniProtocolNum, STM m (HasReturned a))]
forall a b. (a -> b) -> [a] -> [b]
map (\MiniProtocol { MiniProtocolNum
miniProtocolNum :: forall (mode :: MuxMode) bytes (m :: * -> *) a b.
MiniProtocol mode bytes m a b -> MiniProtocolNum
miniProtocolNum :: 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 (f :: * -> *) a. Applicative f => a -> f a
pure HasReturned a
forall a. HasReturned a
NotRunning
                      ))


    -- 'monitorPeerConnection' is only used against established connections
    monitorPeerConnection :: PeerConnectionHandle muxMode peerAddr ByteString m a b
                          -> STM m PeerStatus
    monitorPeerConnection :: PeerConnectionHandle muxMode peerAddr ByteString m a b
-> STM m PeerStatus
monitorPeerConnection PeerConnectionHandle { StrictTVar m PeerState
pchPeerState :: StrictTVar m PeerState
pchPeerState :: forall (muxMode :: MuxMode) peerAddr bytes (m :: * -> *) a b.
PeerConnectionHandle muxMode peerAddr bytes m a b
-> StrictTVar m PeerState
pchPeerState } =
      PeerState -> PeerStatus
getCurrentState (PeerState -> PeerStatus) -> STM m PeerState -> STM m PeerStatus
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar m PeerState -> STM m PeerState
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m PeerState
pchPeerState


    -- 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 :: PeerConnectionHandle muxMode peerAddr ByteString m a b
                           -> m ()
    activatePeerConnection :: PeerConnectionHandle muxMode peerAddr ByteString m a b -> m ()
activatePeerConnection
        connHandle :: PeerConnectionHandle muxMode peerAddr ByteString m a b
connHandle@PeerConnectionHandle {
            ConnectionId peerAddr
pchConnectionId :: ConnectionId peerAddr
pchConnectionId :: forall (muxMode :: MuxMode) peerAddr bytes (m :: * -> *) a b.
PeerConnectionHandle muxMode peerAddr bytes m a b
-> ConnectionId peerAddr
pchConnectionId,
            StrictTVar m PeerState
pchPeerState :: StrictTVar m PeerState
pchPeerState :: forall (muxMode :: MuxMode) peerAddr bytes (m :: * -> *) a b.
PeerConnectionHandle muxMode peerAddr bytes m a b
-> StrictTVar m PeerState
pchPeerState,
            Bundle (ApplicationHandle muxMode ByteString m a b)
pchAppHandles :: Bundle (ApplicationHandle muxMode ByteString m a b)
pchAppHandles :: forall (muxMode :: MuxMode) peerAddr bytes (m :: * -> *) a b.
PeerConnectionHandle muxMode peerAddr bytes m a b
-> Bundle (ApplicationHandle muxMode bytes m a b)
pchAppHandles } = do
      -- quiesce warm peer protocols and set hot ones in 'Continue' mode.
      Bool
wasWarm <- STM m Bool -> m Bool
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.
        Bool
notCold <- StrictTVar m PeerState -> PeerState -> STM m Bool
updateUnlessCold StrictTVar m PeerState
pchPeerState PeerState
PromotingToHot
        Bool -> STM m () -> STM m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
notCold (STM m () -> STM m ()) -> STM m () -> STM m ()
forall a b. (a -> b) -> a -> b
$ do
          StrictTVar m ControlMessage -> ControlMessage -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar (TokProtocolTemperature 'Hot
-> Bundle (ApplicationHandle muxMode ByteString m a b)
-> StrictTVar m ControlMessage
forall (pt :: ProtocolTemperature) (muxMode :: MuxMode) bytes
       (m :: * -> *) a b.
TokProtocolTemperature pt
-> Bundle (ApplicationHandle muxMode bytes m a b)
-> StrictTVar m ControlMessage
getControlVar TokProtocolTemperature 'Hot
TokHot Bundle (ApplicationHandle muxMode ByteString m a b)
pchAppHandles) ControlMessage
Continue
          StrictTVar m ControlMessage -> ControlMessage -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar (TokProtocolTemperature 'Warm
-> Bundle (ApplicationHandle muxMode ByteString m a b)
-> StrictTVar m ControlMessage
forall (pt :: ProtocolTemperature) (muxMode :: MuxMode) bytes
       (m :: * -> *) a b.
TokProtocolTemperature pt
-> Bundle (ApplicationHandle muxMode bytes m a b)
-> StrictTVar m ControlMessage
getControlVar TokProtocolTemperature 'Warm
TokWarm Bundle (ApplicationHandle muxMode ByteString m a b)
pchAppHandles) ControlMessage
Quiesce
        Bool -> STM m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
notCold
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
wasWarm) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        Tracer m (PeerSelectionActionsTrace peerAddr)
-> PeerSelectionActionsTrace peerAddr -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (PeerSelectionActionsTrace peerAddr)
spsTracer (PeerStatusChangeType peerAddr
-> FailureType -> PeerSelectionActionsTrace peerAddr
forall peerAddr.
PeerStatusChangeType peerAddr
-> FailureType -> PeerSelectionActionsTrace peerAddr
PeerStatusChangeFailure
                              (ConnectionId peerAddr -> PeerStatusChangeType peerAddr
forall peerAddr.
ConnectionId peerAddr -> PeerStatusChangeType peerAddr
WarmToHot ConnectionId peerAddr
pchConnectionId)
                              FailureType
ActiveCold)
        ColdActionException peerAddr -> m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (ColdActionException peerAddr -> m ())
-> ColdActionException peerAddr -> m ()
forall a b. (a -> b) -> a -> b
$ ConnectionId peerAddr -> ColdActionException peerAddr
forall peerAddr.
ConnectionId peerAddr -> ColdActionException peerAddr
ColdActivationException ConnectionId peerAddr
pchConnectionId

      -- start hot peer protocols
      TokProtocolTemperature 'Hot
-> PeerConnectionHandle muxMode peerAddr ByteString m a b -> m ()
forall (muxMode :: MuxMode) (pt :: ProtocolTemperature) peerAddr
       (m :: * -> *) a b.
(MonadAsync m, MonadCatch m, MonadThrow (STM m),
 HasInitiator muxMode ~ 'True) =>
TokProtocolTemperature pt
-> PeerConnectionHandle muxMode peerAddr ByteString m a b -> m ()
startProtocols TokProtocolTemperature 'Hot
TokHot PeerConnectionHandle muxMode peerAddr ByteString m a b
connHandle

      -- Only set the status to PeerHot if the peer isn't PeerCold.
      -- This can happen asynchronously between the check above and now.
      Bool
wasWarm' <- STM m Bool -> m Bool
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m Bool -> m Bool) -> STM m Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ StrictTVar m PeerState -> PeerState -> STM m Bool
updateUnlessCold StrictTVar m PeerState
pchPeerState (PeerStatus -> PeerState
PeerStatus PeerStatus
PeerHot)
      if Bool
wasWarm'
         then Tracer m (PeerSelectionActionsTrace peerAddr)
-> PeerSelectionActionsTrace peerAddr -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (PeerSelectionActionsTrace peerAddr)
spsTracer (PeerStatusChangeType peerAddr -> PeerSelectionActionsTrace peerAddr
forall peerAddr.
PeerStatusChangeType peerAddr -> PeerSelectionActionsTrace peerAddr
PeerStatusChanged (ConnectionId peerAddr -> PeerStatusChangeType peerAddr
forall peerAddr.
ConnectionId peerAddr -> PeerStatusChangeType peerAddr
WarmToHot ConnectionId peerAddr
pchConnectionId))
         else do
           Tracer m (PeerSelectionActionsTrace peerAddr)
-> PeerSelectionActionsTrace peerAddr -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (PeerSelectionActionsTrace peerAddr)
spsTracer (PeerStatusChangeType peerAddr
-> FailureType -> PeerSelectionActionsTrace peerAddr
forall peerAddr.
PeerStatusChangeType peerAddr
-> FailureType -> PeerSelectionActionsTrace peerAddr
PeerStatusChangeFailure
                                 (ConnectionId peerAddr -> PeerStatusChangeType peerAddr
forall peerAddr.
ConnectionId peerAddr -> PeerStatusChangeType peerAddr
WarmToHot ConnectionId peerAddr
pchConnectionId)
                                 FailureType
ActiveCold)
           ColdActionException peerAddr -> m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (ColdActionException peerAddr -> m ())
-> ColdActionException peerAddr -> m ()
forall a b. (a -> b) -> a -> b
$ ConnectionId peerAddr -> ColdActionException peerAddr
forall peerAddr.
ConnectionId peerAddr -> ColdActionException peerAddr
ColdActivationException ConnectionId peerAddr
pchConnectionId


    -- Take a hot peer and demote it to a warm one.
    deactivatePeerConnection :: PeerConnectionHandle muxMode peerAddr ByteString m a b -> m ()
    deactivatePeerConnection :: PeerConnectionHandle muxMode peerAddr ByteString m a b -> m ()
deactivatePeerConnection
        PeerConnectionHandle {
            ConnectionId peerAddr
pchConnectionId :: ConnectionId peerAddr
pchConnectionId :: forall (muxMode :: MuxMode) peerAddr bytes (m :: * -> *) a b.
PeerConnectionHandle muxMode peerAddr bytes m a b
-> ConnectionId peerAddr
pchConnectionId,
            StrictTVar m PeerState
pchPeerState :: StrictTVar m PeerState
pchPeerState :: forall (muxMode :: MuxMode) peerAddr bytes (m :: * -> *) a b.
PeerConnectionHandle muxMode peerAddr bytes m a b
-> StrictTVar m PeerState
pchPeerState,
            Mux muxMode m
pchMux :: Mux muxMode m
pchMux :: forall (muxMode :: MuxMode) peerAddr bytes (m :: * -> *) a b.
PeerConnectionHandle muxMode peerAddr bytes m a b -> Mux muxMode m
pchMux,
            Bundle (ApplicationHandle muxMode ByteString m a b)
pchAppHandles :: Bundle (ApplicationHandle muxMode ByteString m a b)
pchAppHandles :: forall (muxMode :: MuxMode) peerAddr bytes (m :: * -> *) a b.
PeerConnectionHandle muxMode peerAddr bytes m a b
-> Bundle (ApplicationHandle muxMode bytes m a b)
pchAppHandles
          } = do
      Bool
wasWarm <- STM m Bool -> m Bool
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
        Bool
notCold <- StrictTVar m PeerState -> PeerState -> STM m Bool
updateUnlessCold StrictTVar m PeerState
pchPeerState PeerState
DemotingToWarm
        Bool -> STM m () -> STM m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
notCold (STM m () -> STM m ()) -> STM m () -> STM m ()
forall a b. (a -> b) -> a -> b
$ do
          StrictTVar m ControlMessage -> ControlMessage -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar (TokProtocolTemperature 'Hot
-> Bundle (ApplicationHandle muxMode ByteString m a b)
-> StrictTVar m ControlMessage
forall (pt :: ProtocolTemperature) (muxMode :: MuxMode) bytes
       (m :: * -> *) a b.
TokProtocolTemperature pt
-> Bundle (ApplicationHandle muxMode bytes m a b)
-> StrictTVar m ControlMessage
getControlVar TokProtocolTemperature 'Hot
TokHot Bundle (ApplicationHandle muxMode ByteString m a b)
pchAppHandles) ControlMessage
Terminate
          StrictTVar m ControlMessage -> ControlMessage -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar (TokProtocolTemperature 'Warm
-> Bundle (ApplicationHandle muxMode ByteString m a b)
-> StrictTVar m ControlMessage
forall (pt :: ProtocolTemperature) (muxMode :: MuxMode) bytes
       (m :: * -> *) a b.
TokProtocolTemperature pt
-> Bundle (ApplicationHandle muxMode bytes m a b)
-> StrictTVar m ControlMessage
getControlVar TokProtocolTemperature 'Warm
TokWarm Bundle (ApplicationHandle muxMode ByteString m a b)
pchAppHandles) ControlMessage
Continue
        Bool -> STM m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
notCold
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
wasWarm) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        -- The governor attempted to demote an already cold peer.
        Tracer m (PeerSelectionActionsTrace peerAddr)
-> PeerSelectionActionsTrace peerAddr -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (PeerSelectionActionsTrace peerAddr)
spsTracer (PeerStatusChangeType peerAddr
-> FailureType -> PeerSelectionActionsTrace peerAddr
forall peerAddr.
PeerStatusChangeType peerAddr
-> FailureType -> PeerSelectionActionsTrace peerAddr
PeerStatusChangeFailure
                             (ConnectionId peerAddr -> PeerStatusChangeType peerAddr
forall peerAddr.
ConnectionId peerAddr -> PeerStatusChangeType peerAddr
HotToWarm ConnectionId peerAddr
pchConnectionId)
                             FailureType
ActiveCold)
        ColdActionException peerAddr -> m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (ColdActionException peerAddr -> m ())
-> ColdActionException peerAddr -> m ()
forall a b. (a -> b) -> a -> b
$ ConnectionId peerAddr -> ColdActionException peerAddr
forall peerAddr.
ConnectionId peerAddr -> ColdActionException peerAddr
ColdDeactivationException ConnectionId peerAddr
pchConnectionId


      -- Hot protocols should stop within 'spsDeactivateTimeout'.
      Maybe LastToFinishResult
res <-
        DiffTime -> m LastToFinishResult -> m (Maybe LastToFinishResult)
forall (m :: * -> *) a.
MonadTimer m =>
DiffTime -> m a -> m (Maybe a)
timeout DiffTime
spsDeactivateTimeout
                (STM m LastToFinishResult -> m LastToFinishResult
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m LastToFinishResult -> m LastToFinishResult)
-> STM m LastToFinishResult -> m LastToFinishResult
forall a b. (a -> b) -> a -> b
$ TokProtocolTemperature 'Hot
-> Bundle (ApplicationHandle muxMode ByteString m a b)
-> STM m LastToFinishResult
forall (m :: * -> *) (pt :: ProtocolTemperature)
       (muxMude :: MuxMode) bytes a b.
MonadSTM m =>
TokProtocolTemperature pt
-> Bundle (ApplicationHandle muxMude bytes m a b)
-> STM m LastToFinishResult
awaitAllResults TokProtocolTemperature 'Hot
TokHot Bundle (ApplicationHandle muxMode ByteString m a b)
pchAppHandles)
      case Maybe LastToFinishResult
res of
        Maybe LastToFinishResult
Nothing -> do
          Mux muxMode m -> m ()
forall (m :: * -> *) (mode :: MuxMode).
MonadSTM m =>
Mux mode m -> m ()
Mux.stopMux Mux muxMode m
pchMux
          STM m () -> m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (StrictTVar m PeerState -> PeerState -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m PeerState
pchPeerState (PeerStatus -> PeerState
PeerStatus PeerStatus
PeerCold))
          Tracer m (PeerSelectionActionsTrace peerAddr)
-> PeerSelectionActionsTrace peerAddr -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (PeerSelectionActionsTrace peerAddr)
spsTracer (PeerStatusChangeType peerAddr
-> FailureType -> PeerSelectionActionsTrace peerAddr
forall peerAddr.
PeerStatusChangeType peerAddr
-> FailureType -> PeerSelectionActionsTrace peerAddr
PeerStatusChangeFailure
                                (ConnectionId peerAddr -> PeerStatusChangeType peerAddr
forall peerAddr.
ConnectionId peerAddr -> PeerStatusChangeType peerAddr
HotToWarm ConnectionId peerAddr
pchConnectionId)
                                FailureType
TimeoutError)
          PeerSelectionTimeoutException peerAddr -> m ()
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)

        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 (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (StrictTVar m PeerState -> PeerState -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m PeerState
pchPeerState (PeerStatus -> PeerState
PeerStatus PeerStatus
PeerCold))
          Tracer m (PeerSelectionActionsTrace peerAddr)
-> PeerSelectionActionsTrace peerAddr -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (PeerSelectionActionsTrace peerAddr)
spsTracer (PeerStatusChangeType peerAddr
-> FailureType -> PeerSelectionActionsTrace peerAddr
forall peerAddr.
PeerStatusChangeType peerAddr
-> FailureType -> PeerSelectionActionsTrace peerAddr
PeerStatusChangeFailure
                                (ConnectionId peerAddr -> PeerStatusChangeType peerAddr
forall peerAddr.
ConnectionId peerAddr -> PeerStatusChangeType peerAddr
HotToCold ConnectionId peerAddr
pchConnectionId)
                                ([MiniProtocolException] -> FailureType
ApplicationFailure [MiniProtocolException]
errs))
          MiniProtocolExceptions -> m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO ([MiniProtocolException] -> MiniProtocolExceptions
MiniProtocolExceptions [MiniProtocolException]
errs)

        Just LastToFinishResult
AllSucceeded -> do
          -- we don't notify the connection manager as this connection is still
          -- useful to the outbound governor (warm peer).
          Bool
wasWarm' <- STM m Bool -> m Bool
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 PeerCold
            -- (can happen asynchronously).
            Bool
notCold <- StrictTVar m PeerState -> PeerState -> STM m Bool
updateUnlessCold StrictTVar m PeerState
pchPeerState (PeerStatus -> PeerState
PeerStatus PeerStatus
PeerWarm)
            Bool -> STM m () -> STM m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
notCold (STM m () -> STM m ()) -> STM m () -> STM m ()
forall a b. (a -> b) -> a -> b
$ do
              -- We need to update hot protocols to indicate that they are not
              -- running.
              StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))
-> (Map MiniProtocolNum (STM m (HasReturned a))
    -> ((), Map MiniProtocolNum (STM m (HasReturned a))))
-> STM m ()
forall (m :: * -> *) s a.
MonadSTM m =>
StrictTVar m s -> (s -> (a, s)) -> STM m a
stateTVar (TokProtocolTemperature 'Hot
-> Bundle (ApplicationHandle muxMode ByteString m a b)
-> StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))
forall (pt :: ProtocolTemperature) (muxMode :: MuxMode) bytes
       (m :: * -> *) a b.
TokProtocolTemperature pt
-> Bundle (ApplicationHandle muxMode bytes m a b)
-> StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))
getMiniProtocolsVar TokProtocolTemperature 'Hot
TokHot Bundle (ApplicationHandle muxMode ByteString m a b)
pchAppHandles)
                        (\Map MiniProtocolNum (STM m (HasReturned a))
a -> ( ()
                               , (STM m (HasReturned a) -> STM m (HasReturned a))
-> Map MiniProtocolNum (STM m (HasReturned a))
-> Map MiniProtocolNum (STM m (HasReturned a))
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (STM m (HasReturned a)
-> STM m (HasReturned a) -> STM m (HasReturned a)
forall a b. a -> b -> a
const (HasReturned a -> STM m (HasReturned a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure HasReturned a
forall a. HasReturned a
NotRunning)) Map MiniProtocolNum (STM m (HasReturned a))
a
                               ))
            Bool -> STM m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
notCold

          if Bool
wasWarm'
             then Tracer m (PeerSelectionActionsTrace peerAddr)
-> PeerSelectionActionsTrace peerAddr -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (PeerSelectionActionsTrace peerAddr)
spsTracer (PeerStatusChangeType peerAddr -> PeerSelectionActionsTrace peerAddr
forall peerAddr.
PeerStatusChangeType peerAddr -> PeerSelectionActionsTrace peerAddr
PeerStatusChanged (ConnectionId peerAddr -> PeerStatusChangeType peerAddr
forall peerAddr.
ConnectionId peerAddr -> PeerStatusChangeType peerAddr
HotToWarm ConnectionId peerAddr
pchConnectionId))
             else do
                 Tracer m (PeerSelectionActionsTrace peerAddr)
-> PeerSelectionActionsTrace peerAddr -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (PeerSelectionActionsTrace peerAddr)
spsTracer (PeerStatusChangeType peerAddr
-> FailureType -> PeerSelectionActionsTrace peerAddr
forall peerAddr.
PeerStatusChangeType peerAddr
-> FailureType -> PeerSelectionActionsTrace peerAddr
PeerStatusChangeFailure
                                      (ConnectionId peerAddr -> PeerStatusChangeType peerAddr
forall peerAddr.
ConnectionId peerAddr -> PeerStatusChangeType peerAddr
WarmToHot ConnectionId peerAddr
pchConnectionId)
                                      FailureType
ActiveCold)
                 ColdActionException peerAddr -> m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (ColdActionException peerAddr -> m ())
-> ColdActionException peerAddr -> m ()
forall a b. (a -> b) -> a -> b
$ ConnectionId peerAddr -> ColdActionException peerAddr
forall peerAddr.
ConnectionId peerAddr -> ColdActionException peerAddr
ColdDeactivationException ConnectionId peerAddr
pchConnectionId


    closePeerConnection :: PeerConnectionHandle muxMode peerAddr ByteString m a b
                        -> m ()
    closePeerConnection :: PeerConnectionHandle muxMode peerAddr ByteString m a b -> m ()
closePeerConnection
        PeerConnectionHandle {
            ConnectionId peerAddr
pchConnectionId :: ConnectionId peerAddr
pchConnectionId :: forall (muxMode :: MuxMode) peerAddr bytes (m :: * -> *) a b.
PeerConnectionHandle muxMode peerAddr bytes m a b
-> ConnectionId peerAddr
pchConnectionId,
            StrictTVar m PeerState
pchPeerState :: StrictTVar m PeerState
pchPeerState :: forall (muxMode :: MuxMode) peerAddr bytes (m :: * -> *) a b.
PeerConnectionHandle muxMode peerAddr bytes m a b
-> StrictTVar m PeerState
pchPeerState,
            Bundle (ApplicationHandle muxMode ByteString m a b)
pchAppHandles :: Bundle (ApplicationHandle muxMode ByteString m a b)
pchAppHandles :: forall (muxMode :: MuxMode) peerAddr bytes (m :: * -> *) a b.
PeerConnectionHandle muxMode peerAddr bytes m a b
-> Bundle (ApplicationHandle muxMode bytes m a b)
pchAppHandles,
            Mux muxMode m
pchMux :: Mux muxMode m
pchMux :: forall (muxMode :: MuxMode) peerAddr bytes (m :: * -> *) a b.
PeerConnectionHandle muxMode peerAddr bytes m a b -> Mux muxMode m
pchMux
          } = do
      STM m () -> m ()
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
        PeerStatus
currentState <- PeerState -> PeerStatus
getCurrentState (PeerState -> PeerStatus) -> STM m PeerState -> STM m PeerStatus
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar m PeerState -> STM m PeerState
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m PeerState
pchPeerState
        StrictTVar m PeerState -> PeerState -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m PeerState
pchPeerState (PeerStatus -> PeerState
DemotingToCold PeerStatus
currentState)
        StrictTVar m ControlMessage -> ControlMessage -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar (TokProtocolTemperature 'Warm
-> Bundle (ApplicationHandle muxMode ByteString m a b)
-> StrictTVar m ControlMessage
forall (pt :: ProtocolTemperature) (muxMode :: MuxMode) bytes
       (m :: * -> *) a b.
TokProtocolTemperature pt
-> Bundle (ApplicationHandle muxMode bytes m a b)
-> StrictTVar m ControlMessage
getControlVar TokProtocolTemperature 'Warm
TokWarm Bundle (ApplicationHandle muxMode ByteString m a b)
pchAppHandles) ControlMessage
Terminate
        StrictTVar m ControlMessage -> ControlMessage -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar (TokProtocolTemperature 'Established
-> Bundle (ApplicationHandle muxMode ByteString m a b)
-> StrictTVar m ControlMessage
forall (pt :: ProtocolTemperature) (muxMode :: MuxMode) bytes
       (m :: * -> *) a b.
TokProtocolTemperature pt
-> Bundle (ApplicationHandle muxMode bytes m a b)
-> StrictTVar m ControlMessage
getControlVar TokProtocolTemperature 'Established
TokEstablished Bundle (ApplicationHandle muxMode ByteString m a b)
pchAppHandles) ControlMessage
Terminate
        StrictTVar m ControlMessage -> ControlMessage -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar (TokProtocolTemperature 'Hot
-> Bundle (ApplicationHandle muxMode ByteString m a b)
-> StrictTVar m ControlMessage
forall (pt :: ProtocolTemperature) (muxMode :: MuxMode) bytes
       (m :: * -> *) a b.
TokProtocolTemperature pt
-> Bundle (ApplicationHandle muxMode bytes m a b)
-> StrictTVar m ControlMessage
getControlVar TokProtocolTemperature 'Hot
TokHot Bundle (ApplicationHandle muxMode ByteString m a b)
pchAppHandles) ControlMessage
Terminate

      Maybe LastToFinishResult
res <-
        DiffTime -> m LastToFinishResult -> m (Maybe LastToFinishResult)
forall (m :: * -> *) a.
MonadTimer m =>
DiffTime -> m a -> m (Maybe a)
timeout DiffTime
spsCloseConnectionTimeout
                (STM m LastToFinishResult -> m LastToFinishResult
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m LastToFinishResult -> m LastToFinishResult)
-> STM m LastToFinishResult -> m LastToFinishResult
forall a b. (a -> b) -> a -> b
$
                  (\LastToFinishResult
a LastToFinishResult
b LastToFinishResult
c -> LastToFinishResult
a LastToFinishResult -> LastToFinishResult -> LastToFinishResult
forall a. Semigroup a => a -> a -> a
<> LastToFinishResult
b LastToFinishResult -> LastToFinishResult -> LastToFinishResult
forall a. Semigroup a => a -> a -> a
<> LastToFinishResult
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
 -> LastToFinishResult -> LastToFinishResult -> LastToFinishResult)
-> STM m LastToFinishResult
-> STM
     m (LastToFinishResult -> LastToFinishResult -> LastToFinishResult)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TokProtocolTemperature 'Hot
-> Bundle (ApplicationHandle muxMode ByteString m a b)
-> STM m LastToFinishResult
forall (m :: * -> *) (pt :: ProtocolTemperature)
       (muxMude :: MuxMode) bytes a b.
MonadSTM m =>
TokProtocolTemperature pt
-> Bundle (ApplicationHandle muxMude bytes m a b)
-> STM m LastToFinishResult
awaitAllResults TokProtocolTemperature 'Hot
TokHot Bundle (ApplicationHandle muxMode ByteString m a b)
pchAppHandles
                    STM
  m (LastToFinishResult -> LastToFinishResult -> LastToFinishResult)
-> STM m LastToFinishResult
-> STM m (LastToFinishResult -> LastToFinishResult)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TokProtocolTemperature 'Warm
-> Bundle (ApplicationHandle muxMode ByteString m a b)
-> STM m LastToFinishResult
forall (m :: * -> *) (pt :: ProtocolTemperature)
       (muxMude :: MuxMode) bytes a b.
MonadSTM m =>
TokProtocolTemperature pt
-> Bundle (ApplicationHandle muxMude bytes m a b)
-> STM m LastToFinishResult
awaitAllResults TokProtocolTemperature 'Warm
TokWarm Bundle (ApplicationHandle muxMode ByteString m a b)
pchAppHandles
                    STM m (LastToFinishResult -> LastToFinishResult)
-> STM m LastToFinishResult -> STM m LastToFinishResult
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TokProtocolTemperature 'Established
-> Bundle (ApplicationHandle muxMode ByteString m a b)
-> STM m LastToFinishResult
forall (m :: * -> *) (pt :: ProtocolTemperature)
       (muxMude :: MuxMode) bytes a b.
MonadSTM m =>
TokProtocolTemperature pt
-> Bundle (ApplicationHandle muxMude bytes m a b)
-> STM m LastToFinishResult
awaitAllResults TokProtocolTemperature 'Established
TokEstablished Bundle (ApplicationHandle muxMode ByteString m a b)
pchAppHandles)
      -- 'unregisterOutboundConnection' could only fail to demote the peer if
      -- connection manager would simultanously promoted it, but this is not
      -- posible.
      case Maybe LastToFinishResult
res of
        Maybe LastToFinishResult
Nothing -> do
          -- timeout fired
          Mux muxMode m -> m ()
forall (m :: * -> *) (mode :: MuxMode).
MonadSTM m =>
Mux mode m -> m ()
Mux.stopMux Mux muxMode m
pchMux
          STM m () -> m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (StrictTVar m PeerState -> PeerState -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m PeerState
pchPeerState (PeerStatus -> PeerState
PeerStatus PeerStatus
PeerCold))
          Tracer m (PeerSelectionActionsTrace peerAddr)
-> PeerSelectionActionsTrace peerAddr -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (PeerSelectionActionsTrace peerAddr)
spsTracer (PeerStatusChangeType peerAddr
-> FailureType -> PeerSelectionActionsTrace peerAddr
forall peerAddr.
PeerStatusChangeType peerAddr
-> FailureType -> PeerSelectionActionsTrace peerAddr
PeerStatusChangeFailure
                                (ConnectionId peerAddr -> PeerStatusChangeType peerAddr
forall peerAddr.
ConnectionId peerAddr -> PeerStatusChangeType peerAddr
WarmToCold ConnectionId peerAddr
pchConnectionId)
                                FailureType
TimeoutError)

        Just (SomeErrored [MiniProtocolException]
errs) -> do
          -- some mini-protocol errored
          --
          -- 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 (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (StrictTVar m PeerState -> PeerState -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m PeerState
pchPeerState (PeerStatus -> PeerState
PeerStatus PeerStatus
PeerCold))
          Tracer m (PeerSelectionActionsTrace peerAddr)
-> PeerSelectionActionsTrace peerAddr -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (PeerSelectionActionsTrace peerAddr)
spsTracer (PeerStatusChangeType peerAddr
-> FailureType -> PeerSelectionActionsTrace peerAddr
forall peerAddr.
PeerStatusChangeType peerAddr
-> FailureType -> PeerSelectionActionsTrace peerAddr
PeerStatusChangeFailure
                                (ConnectionId peerAddr -> PeerStatusChangeType peerAddr
forall peerAddr.
ConnectionId peerAddr -> PeerStatusChangeType peerAddr
WarmToCold ConnectionId peerAddr
pchConnectionId)
                                ([MiniProtocolException] -> FailureType
ApplicationFailure [MiniProtocolException]
errs))
          MiniProtocolExceptions -> m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO ([MiniProtocolException] -> MiniProtocolExceptions
MiniProtocolExceptions [MiniProtocolException]
errs)

        Just LastToFinishResult
AllSucceeded -> do
          -- all mini-protocols terminated cleanly
          OperationResult AbstractState
_ <- MuxConnectionManager
  muxMode socket peerAddr versionNumber ByteString m a b
-> peerAddr -> m (OperationResult AbstractState)
forall (muxMode :: MuxMode) socket peerAddr handle handleError
       (m :: * -> *).
(HasInitiator muxMode ~ 'True) =>
ConnectionManager muxMode socket peerAddr handle handleError m
-> peerAddr -> m (OperationResult AbstractState)
unregisterOutboundConnection MuxConnectionManager
  muxMode socket peerAddr versionNumber ByteString m a b
spsConnectionManager (ConnectionId peerAddr -> peerAddr
forall addr. ConnectionId addr -> addr
remoteAddress ConnectionId peerAddr
pchConnectionId)
          STM m () -> m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (StrictTVar m PeerState -> PeerState -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m PeerState
pchPeerState (PeerStatus -> PeerState
PeerStatus PeerStatus
PeerCold))
          Tracer m (PeerSelectionActionsTrace peerAddr)
-> PeerSelectionActionsTrace peerAddr -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (PeerSelectionActionsTrace peerAddr)
spsTracer (PeerStatusChangeType peerAddr -> PeerSelectionActionsTrace peerAddr
forall peerAddr.
PeerStatusChangeType peerAddr -> PeerSelectionActionsTrace peerAddr
PeerStatusChanged (ConnectionId peerAddr -> PeerStatusChangeType peerAddr
forall peerAddr.
ConnectionId peerAddr -> PeerStatusChangeType peerAddr
WarmToCold ConnectionId peerAddr
pchConnectionId))

--
-- Utilities
--


-- | Smart constructor for 'ApplicationHandle'.
--
mkApplicationHandleBundle
    :: forall (muxMode :: MuxMode) bytes m a b.
       MuxBundle muxMode bytes m a b
    -- ^ mux application
    -> Bundle (StrictTVar m ControlMessage)
    -- ^ 'ControlMessage' bundle
    -> Bundle (StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a))))
    -- ^ await for application termination
    -> Bundle (ApplicationHandle muxMode bytes m a b)
mkApplicationHandleBundle :: MuxBundle muxMode bytes m a b
-> Bundle (StrictTVar m ControlMessage)
-> Bundle
     (StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a))))
-> Bundle (ApplicationHandle muxMode bytes m a b)
mkApplicationHandleBundle MuxBundle muxMode bytes m a b
muxBundle Bundle (StrictTVar m ControlMessage)
controlMessageBundle Bundle (StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a))))
awaitVarsBundle =
    WithProtocolTemperature
  'Hot (ApplicationHandle muxMode bytes m a b)
-> WithProtocolTemperature
     'Warm (ApplicationHandle muxMode bytes m a b)
-> WithProtocolTemperature
     'Established (ApplicationHandle muxMode bytes m a b)
-> Bundle (ApplicationHandle muxMode bytes m a b)
forall a.
WithProtocolTemperature 'Hot a
-> WithProtocolTemperature 'Warm a
-> WithProtocolTemperature 'Established a
-> Bundle a
Bundle
      (TokProtocolTemperature 'Hot
-> WithProtocolTemperature
     'Hot (ApplicationHandle muxMode bytes m a b)
forall (pt :: ProtocolTemperature).
TokProtocolTemperature pt
-> WithProtocolTemperature
     pt (ApplicationHandle muxMode bytes m a b)
mkApplication TokProtocolTemperature 'Hot
TokHot)
      (TokProtocolTemperature 'Warm
-> WithProtocolTemperature
     'Warm (ApplicationHandle muxMode bytes m a b)
forall (pt :: ProtocolTemperature).
TokProtocolTemperature pt
-> WithProtocolTemperature
     pt (ApplicationHandle muxMode bytes m a b)
mkApplication TokProtocolTemperature 'Warm
TokWarm)
      (TokProtocolTemperature 'Established
-> WithProtocolTemperature
     'Established (ApplicationHandle muxMode bytes m a b)
forall (pt :: ProtocolTemperature).
TokProtocolTemperature pt
-> WithProtocolTemperature
     pt (ApplicationHandle muxMode bytes m a b)
mkApplication TokProtocolTemperature 'Established
TokEstablished)
  where
    mkApplication :: TokProtocolTemperature pt
                  -> WithProtocolTemperature pt (ApplicationHandle muxMode bytes m a b)
    mkApplication :: TokProtocolTemperature pt
-> WithProtocolTemperature
     pt (ApplicationHandle muxMode bytes m a b)
mkApplication TokProtocolTemperature pt
tok =
      let app :: ApplicationHandle muxMode bytes m a b
app =
            ApplicationHandle :: forall (muxMode :: MuxMode) bytes (m :: * -> *) a b.
[MiniProtocol muxMode bytes m a b]
-> StrictTVar m ControlMessage
-> StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))
-> ApplicationHandle muxMode bytes m a b
ApplicationHandle {
              ahApplication :: [MiniProtocol muxMode bytes m a b]
ahApplication         = TokProtocolTemperature pt
-> MuxBundle muxMode bytes m a b
-> [MiniProtocol muxMode bytes m a b]
forall (pt :: ProtocolTemperature) a.
TokProtocolTemperature pt -> Bundle a -> a
projectBundle TokProtocolTemperature pt
tok MuxBundle muxMode bytes m a b
muxBundle,
              ahControlVar :: StrictTVar m ControlMessage
ahControlVar          = TokProtocolTemperature pt
-> Bundle (StrictTVar m ControlMessage)
-> StrictTVar m ControlMessage
forall (pt :: ProtocolTemperature) a.
TokProtocolTemperature pt -> Bundle a -> a
projectBundle TokProtocolTemperature pt
tok Bundle (StrictTVar m ControlMessage)
controlMessageBundle,
              ahMiniProtocolResults :: StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))
ahMiniProtocolResults = TokProtocolTemperature pt
-> Bundle
     (StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a))))
-> StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))
forall (pt :: ProtocolTemperature) a.
TokProtocolTemperature pt -> Bundle a -> a
projectBundle TokProtocolTemperature pt
tok Bundle (StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a))))
awaitVarsBundle
            }
      in case TokProtocolTemperature pt
tok of
          TokProtocolTemperature pt
TokHot         -> ApplicationHandle muxMode bytes m a b
-> WithProtocolTemperature
     'Hot (ApplicationHandle muxMode bytes m a b)
forall a. a -> WithProtocolTemperature 'Hot a
WithHot ApplicationHandle muxMode bytes m a b
app
          TokProtocolTemperature pt
TokWarm        -> ApplicationHandle muxMode bytes m a b
-> WithProtocolTemperature
     'Warm (ApplicationHandle muxMode bytes m a b)
forall a. a -> WithProtocolTemperature 'Warm a
WithWarm ApplicationHandle muxMode bytes m a b
app
          TokProtocolTemperature pt
TokEstablished -> ApplicationHandle muxMode bytes m a b
-> WithProtocolTemperature
     'Established (ApplicationHandle muxMode bytes m a b)
forall a. a -> WithProtocolTemperature 'Established a
WithEstablished ApplicationHandle muxMode bytes m a b
app


-- | Given a singleton 'TokAppKind' and 'PeerConnectionHandle' start the mux
-- protocol bundle indicated by the type of the first argument.
--
startProtocols :: forall (muxMode :: MuxMode) (pt :: ProtocolTemperature) peerAddr m a b.
                  ( MonadAsync m
                  , MonadCatch m
                  , MonadThrow (STM m)
                  , HasInitiator muxMode ~ True
                  )
               => TokProtocolTemperature pt
               -> PeerConnectionHandle muxMode peerAddr ByteString m a b
               -> m ()
startProtocols :: TokProtocolTemperature pt
-> PeerConnectionHandle muxMode peerAddr ByteString m a b -> m ()
startProtocols TokProtocolTemperature pt
tok PeerConnectionHandle { Mux muxMode m
pchMux :: Mux muxMode m
pchMux :: forall (muxMode :: MuxMode) peerAddr bytes (m :: * -> *) a b.
PeerConnectionHandle muxMode peerAddr bytes m a b -> Mux muxMode m
pchMux, Bundle (ApplicationHandle muxMode ByteString m a b)
pchAppHandles :: Bundle (ApplicationHandle muxMode ByteString m a b)
pchAppHandles :: forall (muxMode :: MuxMode) peerAddr bytes (m :: * -> *) a b.
PeerConnectionHandle muxMode peerAddr bytes m a b
-> Bundle (ApplicationHandle muxMode bytes m a b)
pchAppHandles } = do
    let ptcls :: [MiniProtocol muxMode ByteString m a b]
ptcls = TokProtocolTemperature pt
-> Bundle (ApplicationHandle muxMode ByteString m a b)
-> [MiniProtocol muxMode ByteString m a b]
forall (pt :: ProtocolTemperature) (muxMode :: MuxMode) bytes
       (m :: * -> *) a b.
TokProtocolTemperature pt
-> Bundle (ApplicationHandle muxMode bytes m a b)
-> [MiniProtocol muxMode bytes m a b]
getProtocols TokProtocolTemperature pt
tok Bundle (ApplicationHandle muxMode ByteString m a b)
pchAppHandles
    [STM m (Either SomeException a)]
as <- (MiniProtocol muxMode ByteString m a b
 -> m (STM m (Either SomeException a)))
-> [MiniProtocol muxMode 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)
traverse MiniProtocol muxMode ByteString m a b
-> m (STM m (Either SomeException a))
runInitiator [MiniProtocol muxMode ByteString m a b]
ptcls
    STM m () -> m ()
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 (Map MiniProtocolNum (STM m (HasReturned a)))
-> Map MiniProtocolNum (STM m (HasReturned a)) -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar (TokProtocolTemperature pt
-> Bundle (ApplicationHandle muxMode ByteString m a b)
-> StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))
forall (pt :: ProtocolTemperature) (muxMode :: MuxMode) bytes
       (m :: * -> *) a b.
TokProtocolTemperature pt
-> Bundle (ApplicationHandle muxMode bytes m a b)
-> StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))
getMiniProtocolsVar TokProtocolTemperature pt
tok Bundle (ApplicationHandle muxMode ByteString m a b)
pchAppHandles)
                           ([(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)))
-> [(MiniProtocolNum, STM m (Either SomeException a))]
-> Map MiniProtocolNum (STM m (HasReturned a))
forall a b. (a -> b) -> a -> b
$ [MiniProtocolNum]
-> [STM m (Either SomeException a)]
-> [(MiniProtocolNum, STM m (Either SomeException a))]
forall a b. [a] -> [b] -> [(a, b)]
zip (MiniProtocol muxMode ByteString m a b -> MiniProtocolNum
forall (mode :: MuxMode) bytes (m :: * -> *) a b.
MiniProtocol mode bytes m a b -> MiniProtocolNum
miniProtocolNum (MiniProtocol muxMode ByteString m a b -> MiniProtocolNum)
-> [MiniProtocol muxMode ByteString m a b] -> [MiniProtocolNum]
forall a b. (a -> b) -> [a] -> [b]
`map` [MiniProtocol muxMode ByteString m a b]
ptcls) [STM m (Either SomeException a)]
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 (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 ByteString m a b
                 -> m (STM m (Either SomeException a))
    runInitiator :: MiniProtocol muxMode ByteString m a b
-> m (STM m (Either SomeException a))
runInitiator MiniProtocol {
                      MiniProtocolNum
miniProtocolNum :: MiniProtocolNum
miniProtocolNum :: forall (mode :: MuxMode) bytes (m :: * -> *) a b.
MiniProtocol mode bytes m a b -> MiniProtocolNum
miniProtocolNum,
                      RunMiniProtocol muxMode ByteString m a b
miniProtocolRun :: forall (mode :: MuxMode) bytes (m :: * -> *) a b.
MiniProtocol mode bytes m a b -> RunMiniProtocol mode bytes m a b
miniProtocolRun :: RunMiniProtocol muxMode ByteString m a b
miniProtocolRun
                    } = do

      case RunMiniProtocol muxMode ByteString m a b
miniProtocolRun of
        InitiatorProtocolOnly MuxPeer ByteString m a
initiator ->
            Mux muxMode m
-> MiniProtocolNum
-> MiniProtocolDirection muxMode
-> StartOnDemandOrEagerly
-> (Channel m -> m (a, Maybe ByteString))
-> m (STM m (Either SomeException a))
forall (mode :: MuxMode) (m :: * -> *) a.
(MonadSTM m, MonadThrow m, MonadThrow (STM m)) =>
Mux mode m
-> MiniProtocolNum
-> MiniProtocolDirection mode
-> StartOnDemandOrEagerly
-> (Channel 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
              (MuxPeer ByteString m a
-> Channel m ByteString -> m (a, Maybe ByteString)
forall (m :: * -> *) bytes a.
(MonadCatch m, MonadAsync m) =>
MuxPeer bytes m a -> Channel m bytes -> m (a, Maybe bytes)
runMuxPeer MuxPeer ByteString m a
initiator (Channel m ByteString -> m (a, Maybe ByteString))
-> (Channel m -> Channel m ByteString)
-> Channel m
-> m (a, Maybe ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Channel m -> Channel m ByteString
forall (m :: * -> *). Channel m -> Channel m ByteString
fromChannel)
        InitiatorAndResponderProtocol MuxPeer ByteString m a
initiator MuxPeer ByteString m b
_ ->
            Mux muxMode m
-> MiniProtocolNum
-> MiniProtocolDirection muxMode
-> StartOnDemandOrEagerly
-> (Channel m -> m (a, Maybe ByteString))
-> m (STM m (Either SomeException a))
forall (mode :: MuxMode) (m :: * -> *) a.
(MonadSTM m, MonadThrow m, MonadThrow (STM m)) =>
Mux mode m
-> MiniProtocolNum
-> MiniProtocolDirection mode
-> StartOnDemandOrEagerly
-> (Channel 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
              (MuxPeer ByteString m a
-> Channel m ByteString -> m (a, Maybe ByteString)
forall (m :: * -> *) bytes a.
(MonadCatch m, MonadAsync m) =>
MuxPeer bytes m a -> Channel m bytes -> m (a, Maybe bytes)
runMuxPeer MuxPeer ByteString m a
initiator (Channel m ByteString -> m (a, Maybe ByteString))
-> (Channel m -> Channel m ByteString)
-> Channel m
-> m (a, Maybe ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Channel m -> Channel m ByteString
forall (m :: * -> *). Channel m -> Channel m ByteString
fromChannel)

--
-- 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 =
      HandshakeClientFailure
    | HandshakeServerFailure
    | HandleFailure !SomeException
    | MuxStoppedFailure
    | TimeoutError
    | ActiveCold
    | ApplicationFailure ![MiniProtocolException]
  deriving Int -> FailureType -> ShowS
[FailureType] -> ShowS
FailureType -> String
(Int -> FailureType -> ShowS)
-> (FailureType -> String)
-> ([FailureType] -> ShowS)
-> Show FailureType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FailureType] -> ShowS
$cshowList :: [FailureType] -> ShowS
show :: FailureType -> String
$cshow :: FailureType -> String
showsPrec :: Int -> FailureType -> ShowS
$cshowsPrec :: Int -> FailureType -> 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)
    | WarmToCold !(ConnectionId peerAddr)
    | HotToCold  !(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
showList :: [PeerStatusChangeType peerAddr] -> ShowS
$cshowList :: forall peerAddr.
Show peerAddr =>
[PeerStatusChangeType peerAddr] -> ShowS
show :: PeerStatusChangeType peerAddr -> String
$cshow :: forall peerAddr.
Show peerAddr =>
PeerStatusChangeType peerAddr -> String
showsPrec :: Int -> PeerStatusChangeType peerAddr -> ShowS
$cshowsPrec :: forall peerAddr.
Show peerAddr =>
Int -> PeerStatusChangeType peerAddr -> ShowS
Show

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