{-# LANGUAGE BangPatterns              #-}
{-# LANGUAGE DataKinds                 #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts          #-}
{-# LANGUAGE GADTs                     #-}
{-# LANGUAGE KindSignatures            #-}
{-# LANGUAGE LambdaCase                #-}
{-# LANGUAGE NamedFieldPuns            #-}
{-# LANGUAGE RankNTypes                #-}
{-# LANGUAGE ScopedTypeVariables       #-}
{-# LANGUAGE StandaloneDeriving        #-}
{-# LANGUAGE TypeApplications          #-}

-- | Implementation of 'ConnectionHandler'
--
-- While connection manager responsibility is to keep track of resources:
-- sockets and threads running connection and their state changes (including
-- changes imposed by 'ConnectionHandler', e.g. weather a uni- or duplex- data
-- flow was negotiated), the responsibility of 'ConnectionHandler' is to:
--
-- * run handshake protocol on the underlying bearer
-- * start mux
--
-- 'ConnectionHandler' is run on each inbound or outbound connection and returns
-- 'Handle'.  Upon successful handshake negotiation it returns all the
-- necessary information to run mini-protocols.  Note that it is not responsible
-- for running them: that's what a server does or p2p-governor by means of
-- 'PeerStateActions'.
--
module Ouroboros.Network.ConnectionHandler
  ( Handle (..)
  , HandleError (..)
  , classifyHandleError
  , MuxConnectionHandler
  , makeConnectionHandler
  , MuxConnectionManager
    -- * tracing
  , ConnectionHandlerTrace (..)
  ) where

import           Control.Exception (SomeAsyncException)
import           Control.Monad.Class.MonadAsync
import           Control.Monad.Class.MonadFork
import           Control.Monad.Class.MonadSTM.Strict
import           Control.Monad.Class.MonadThrow hiding (handle)
import           Control.Monad.Class.MonadTime
import           Control.Monad.Class.MonadTimer
import           Control.Tracer (Tracer, contramap, traceWith)

import           Data.ByteString.Lazy (ByteString)
import           Data.Typeable (Typeable)

import           Network.Mux hiding (miniProtocolNum)

import           Ouroboros.Network.ConnectionId (ConnectionId (..))
import           Ouroboros.Network.ConnectionManager.Types
import           Ouroboros.Network.Mux
import           Ouroboros.Network.MuxMode
import           Ouroboros.Network.Protocol.Handshake
import           Ouroboros.Network.RethrowPolicy

-- | We place an upper limit of `30s` on the time we wait on receiving an SDU.
-- There is no upper bound on the time we wait when waiting for a new SDU.
-- This makes it possible for mini-protocols to use timeouts that are larger
-- than 30s or wait forever.  `30s` for receiving an SDU corresponds to
-- a minimum speed limit of 17kbps.
--
-- ( 8      -- mux header length
-- + 0xffff -- maximum SDU payload
-- )
-- * 8
-- = 524_344 -- maximum bits in an SDU
--
--  524_344 / 30 / 1024 = 17kbps
--
sduTimeout :: DiffTime
sduTimeout :: DiffTime
sduTimeout = DiffTime
30


-- | For handshake, we put a limit of `10s` for sending or receiving a single
-- `MuxSDU`.
--
sduHandshakeTimeout :: DiffTime
sduHandshakeTimeout :: DiffTime
sduHandshakeTimeout = DiffTime
10


-- | States of the connection handler thread.
--
-- * 'MuxRunning' - successful Handshake, mux started
-- * 'HandleHandshakeClientError'
--                - the connection handler thread was running client side
--                of the handshake negotiation, which failed with
--                a 'HandshakeException'
-- * 'HandleHandshakeServerError'
--                - the connection handler thread was running server side of the
--                handshake protocol, which fail with 'HandshakeException'
-- * 'HandleError'
--                - the multiplexer thrown 'MuxError'.
--
data Handle (muxMode :: MuxMode) peerAddr bytes m a b =
    Handle {
        Handle muxMode peerAddr bytes m a b -> Mux muxMode m
hMux            :: !(Mux muxMode m),
        Handle muxMode peerAddr bytes m a b
-> MuxBundle muxMode bytes m a b
hMuxBundle      :: !(MuxBundle muxMode bytes m a b),
        Handle muxMode peerAddr bytes m a b
-> Bundle (StrictTVar m ControlMessage)
hControlMessage :: !(Bundle (StrictTVar m ControlMessage))
      }


data HandleError (muxMode :: MuxMode) versionNumber where
    HandleHandshakeClientError
      :: HasInitiator muxMode ~ True
      => !(HandshakeException versionNumber)
      -> HandleError muxMode versionNumber

    HandleHandshakeServerError
      :: HasResponder muxMode ~ True
      => !(HandshakeException versionNumber)
      -> HandleError muxMode versionNumber

    HandleError
     :: !SomeException
     -> HandleError muxMode versionNumber

instance Show versionNumber
      => Show (HandleError muxMode versionNumber) where
    show :: HandleError muxMode versionNumber -> String
show (HandleHandshakeServerError HandshakeException versionNumber
err) = String
"HandleHandshakeServerError " String -> ShowS
forall a. [a] -> [a] -> [a]
++ HandshakeException versionNumber -> String
forall a. Show a => a -> String
show HandshakeException versionNumber
err
    show (HandleHandshakeClientError HandshakeException versionNumber
err) = String
"HandleHandshakeClientError " String -> ShowS
forall a. [a] -> [a] -> [a]
++ HandshakeException versionNumber -> String
forall a. Show a => a -> String
show HandshakeException versionNumber
err
    show (HandleError SomeException
err)                = String
"HandleError " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall a. Show a => a -> String
show SomeException
err


classifyHandleError :: HandleError muxMode versionNumber
                    -> HandleErrorType
classifyHandleError :: HandleError muxMode versionNumber -> HandleErrorType
classifyHandleError (HandleHandshakeClientError (HandshakeProtocolLimit ProtocolLimitFailure
_)) =
    HandleErrorType
HandshakeProtocolViolation
-- TODO: 'HandshakeProtocolError' is not a protocol error! It is just
-- a negotiation failure.  It should be renamed.
classifyHandleError (HandleHandshakeClientError (HandshakeProtocolError HandshakeProtocolError versionNumber
_)) =
    HandleErrorType
HandshakeFailure
classifyHandleError (HandleHandshakeServerError (HandshakeProtocolLimit ProtocolLimitFailure
_)) =
    HandleErrorType
HandshakeProtocolViolation
classifyHandleError (HandleHandshakeServerError (HandshakeProtocolError HandshakeProtocolError versionNumber
_)) =
    HandleErrorType
HandshakeFailure
-- any other exception, e.g. MuxError \/ IOError, codec errors, etc.
classifyHandleError (HandleError SomeException
_) =
    HandleErrorType
HandshakeProtocolViolation


-- | Type of 'ConnectionHandler' implemented in this module.
--
type MuxConnectionHandler muxMode socket peerAddr versionNumber versionData bytes m a b =
    ConnectionHandler muxMode
                      (ConnectionHandlerTrace versionNumber versionData)
                      socket
                      peerAddr
                      (Handle muxMode peerAddr bytes m a b)
                      (HandleError muxMode versionNumber)
                      (versionNumber, versionData)
                      m

-- | Type alias for 'ConnectionManager' using 'Handle'.
--
type MuxConnectionManager muxMode socket peerAddr versionNumber bytes m a b =
    ConnectionManager muxMode socket peerAddr
                      (Handle muxMode peerAddr bytes m a b)
                      (HandleError muxMode versionNumber)
                      m

-- | To be used as `makeConnectionHandler` field of 'ConnectionManagerArguments'.
--
-- Note: We need to pass `MiniProtocolBundle` what forces us to have two
-- different `ConnectionManager`s: one for `node-to-client` and another for
-- `node-to-node` connections.  But this is ok, as these resources are
-- independent.
--
makeConnectionHandler
    :: forall peerAddr muxMode socket versionNumber versionData m a b.
       ( MonadAsync m
       , MonadCatch m
       , MonadFork  m
       , MonadLabelledSTM m
       , MonadThrow (STM m)
       , MonadTime  m
       , MonadTimer m
       , MonadMask  m
       , Ord      versionNumber
       , Show     peerAddr
       , Typeable peerAddr
       )
    => Tracer m (WithMuxBearer (ConnectionId peerAddr) MuxTrace)
    -> SingMuxMode muxMode
    -- ^ describe whether this is outbound or inbound connection, and bring
    -- evidence that we can use mux with it.
    -> HandshakeArguments (ConnectionId peerAddr) versionNumber versionData m
    -> Versions versionNumber versionData
                (OuroborosBundle muxMode peerAddr ByteString m a b)
    -> (ThreadId m, RethrowPolicy)
    -- ^ 'ThreadId' and rethrow policy.  Rethrow policy might throw an async
    -- exception to that thread, when trying to terminate the process.
    -> MuxConnectionHandler muxMode socket peerAddr versionNumber versionData ByteString m a b
makeConnectionHandler :: Tracer m (WithMuxBearer (ConnectionId peerAddr) MuxTrace)
-> SingMuxMode muxMode
-> HandshakeArguments
     (ConnectionId peerAddr) versionNumber versionData m
-> Versions
     versionNumber
     versionData
     (OuroborosBundle muxMode peerAddr ByteString m a b)
-> (ThreadId m, RethrowPolicy)
-> MuxConnectionHandler
     muxMode socket peerAddr versionNumber versionData ByteString m a b
makeConnectionHandler Tracer m (WithMuxBearer (ConnectionId peerAddr) MuxTrace)
muxTracer SingMuxMode muxMode
singMuxMode
                      HandshakeArguments
  (ConnectionId peerAddr) versionNumber versionData m
handshakeArguments
                      Versions
  versionNumber
  versionData
  (OuroborosBundle muxMode peerAddr ByteString m a b)
versionedApplication
                      (ThreadId m
mainThreadId, RethrowPolicy
rethrowPolicy) =
    ConnectionHandler :: forall (muxMode :: MuxMode) handlerTrace socket peerAddr handle
       handleError version (m :: * -> *).
WithMuxTuple
  muxMode
  (ConnectionHandlerFn
     handlerTrace socket peerAddr handle handleError version m)
-> ConnectionHandler
     muxMode handlerTrace socket peerAddr handle handleError version m
ConnectionHandler {
        connectionHandler :: WithMuxTuple
  muxMode
  (ConnectionHandlerFn
     (ConnectionHandlerTrace versionNumber versionData)
     socket
     peerAddr
     (Handle muxMode peerAddr ByteString m a b)
     (HandleError muxMode versionNumber)
     (versionNumber, versionData)
     m)
connectionHandler =
          case SingMuxMode muxMode
singMuxMode of
            SingMuxMode muxMode
SingInitiatorMode ->
              ConnectionHandlerFn
  (ConnectionHandlerTrace versionNumber versionData)
  socket
  peerAddr
  (Handle muxMode peerAddr ByteString m a b)
  (HandleError muxMode versionNumber)
  (versionNumber, versionData)
  m
-> WithMuxMode
     'InitiatorMode
     (ConnectionHandlerFn
        (ConnectionHandlerTrace versionNumber versionData)
        socket
        peerAddr
        (Handle muxMode peerAddr ByteString m a b)
        (HandleError muxMode versionNumber)
        (versionNumber, versionData)
        m)
     (ConnectionHandlerFn
        (ConnectionHandlerTrace versionNumber versionData)
        socket
        peerAddr
        (Handle muxMode peerAddr ByteString m a b)
        (HandleError muxMode versionNumber)
        (versionNumber, versionData)
        m)
forall a b. a -> WithMuxMode 'InitiatorMode a b
WithInitiatorMode ConnectionHandlerFn
  (ConnectionHandlerTrace versionNumber versionData)
  socket
  peerAddr
  (Handle muxMode peerAddr ByteString m a b)
  (HandleError muxMode versionNumber)
  (versionNumber, versionData)
  m
(HasInitiator muxMode ~ 'True) =>
ConnectionHandlerFn
  (ConnectionHandlerTrace versionNumber versionData)
  socket
  peerAddr
  (Handle muxMode peerAddr ByteString m a b)
  (HandleError muxMode versionNumber)
  (versionNumber, versionData)
  m
outboundConnectionHandler
            SingMuxMode muxMode
SingResponderMode ->
              ConnectionHandlerFn
  (ConnectionHandlerTrace versionNumber versionData)
  socket
  peerAddr
  (Handle muxMode peerAddr ByteString m a b)
  (HandleError muxMode versionNumber)
  (versionNumber, versionData)
  m
-> WithMuxMode
     'ResponderMode
     (ConnectionHandlerFn
        (ConnectionHandlerTrace versionNumber versionData)
        socket
        peerAddr
        (Handle muxMode peerAddr ByteString m a b)
        (HandleError muxMode versionNumber)
        (versionNumber, versionData)
        m)
     (ConnectionHandlerFn
        (ConnectionHandlerTrace versionNumber versionData)
        socket
        peerAddr
        (Handle muxMode peerAddr ByteString m a b)
        (HandleError muxMode versionNumber)
        (versionNumber, versionData)
        m)
forall b a. b -> WithMuxMode 'ResponderMode a b
WithResponderMode ConnectionHandlerFn
  (ConnectionHandlerTrace versionNumber versionData)
  socket
  peerAddr
  (Handle muxMode peerAddr ByteString m a b)
  (HandleError muxMode versionNumber)
  (versionNumber, versionData)
  m
(HasResponder muxMode ~ 'True) =>
ConnectionHandlerFn
  (ConnectionHandlerTrace versionNumber versionData)
  socket
  peerAddr
  (Handle muxMode peerAddr ByteString m a b)
  (HandleError muxMode versionNumber)
  (versionNumber, versionData)
  m
inboundConnectionHandler
            SingMuxMode muxMode
SingInitiatorResponderMode ->
              ConnectionHandlerFn
  (ConnectionHandlerTrace versionNumber versionData)
  socket
  peerAddr
  (Handle muxMode peerAddr ByteString m a b)
  (HandleError muxMode versionNumber)
  (versionNumber, versionData)
  m
-> ConnectionHandlerFn
     (ConnectionHandlerTrace versionNumber versionData)
     socket
     peerAddr
     (Handle muxMode peerAddr ByteString m a b)
     (HandleError muxMode versionNumber)
     (versionNumber, versionData)
     m
-> WithMuxMode
     'InitiatorResponderMode
     (ConnectionHandlerFn
        (ConnectionHandlerTrace versionNumber versionData)
        socket
        peerAddr
        (Handle muxMode peerAddr ByteString m a b)
        (HandleError muxMode versionNumber)
        (versionNumber, versionData)
        m)
     (ConnectionHandlerFn
        (ConnectionHandlerTrace versionNumber versionData)
        socket
        peerAddr
        (Handle muxMode peerAddr ByteString m a b)
        (HandleError muxMode versionNumber)
        (versionNumber, versionData)
        m)
forall a b. a -> b -> WithMuxMode 'InitiatorResponderMode a b
WithInitiatorResponderMode ConnectionHandlerFn
  (ConnectionHandlerTrace versionNumber versionData)
  socket
  peerAddr
  (Handle muxMode peerAddr ByteString m a b)
  (HandleError muxMode versionNumber)
  (versionNumber, versionData)
  m
(HasInitiator muxMode ~ 'True) =>
ConnectionHandlerFn
  (ConnectionHandlerTrace versionNumber versionData)
  socket
  peerAddr
  (Handle muxMode peerAddr ByteString m a b)
  (HandleError muxMode versionNumber)
  (versionNumber, versionData)
  m
outboundConnectionHandler
                                         ConnectionHandlerFn
  (ConnectionHandlerTrace versionNumber versionData)
  socket
  peerAddr
  (Handle muxMode peerAddr ByteString m a b)
  (HandleError muxMode versionNumber)
  (versionNumber, versionData)
  m
(HasResponder muxMode ~ 'True) =>
ConnectionHandlerFn
  (ConnectionHandlerTrace versionNumber versionData)
  socket
  peerAddr
  (Handle muxMode peerAddr ByteString m a b)
  (HandleError muxMode versionNumber)
  (versionNumber, versionData)
  m
inboundConnectionHandler
      }
  where
    -- install classify exception handler
    classifyExceptions :: forall x.
                          Tracer m (ConnectionHandlerTrace versionNumber versionData)
                       -> peerAddr
                       -> ErrorContext
                       -> m x -> m x
    classifyExceptions :: Tracer m (ConnectionHandlerTrace versionNumber versionData)
-> peerAddr -> ErrorContext -> m x -> m x
classifyExceptions Tracer m (ConnectionHandlerTrace versionNumber versionData)
tracer peerAddr
remoteAddress ErrorContext
ctx m x
io =
      -- handle non-async exceptions
      (SomeException -> Maybe SomeException)
-> m x -> (SomeException -> m x) -> m x
forall (m :: * -> *) e b a.
(MonadCatch m, Exception e) =>
(e -> Maybe b) -> m a -> (b -> m a) -> m a
catchJust
        (\SomeException
e -> case SomeException -> Maybe SomeAsyncException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e :: Maybe SomeAsyncException of
                Just SomeAsyncException
_  -> Maybe SomeException
forall a. Maybe a
Nothing
                Maybe SomeAsyncException
Nothing -> SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just SomeException
e)
        m x
io
        ((SomeException -> m x) -> m x) -> (SomeException -> m x) -> m x
forall a b. (a -> b) -> a -> b
$ \SomeException
err -> do
          let cmd :: ErrorCommand
cmd = RethrowPolicy -> RethrowPolicy_
runRethrowPolicy RethrowPolicy
rethrowPolicy ErrorContext
ctx SomeException
err
          Tracer m (ConnectionHandlerTrace versionNumber versionData)
-> ConnectionHandlerTrace versionNumber versionData -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (ConnectionHandlerTrace versionNumber versionData)
tracer (ErrorContext
-> SomeException
-> ErrorCommand
-> ConnectionHandlerTrace versionNumber versionData
forall versionNumber versionData.
ErrorContext
-> SomeException
-> ErrorCommand
-> ConnectionHandlerTrace versionNumber versionData
TrError ErrorContext
ctx SomeException
err ErrorCommand
cmd)
          case ErrorCommand
cmd of
            ErrorCommand
ShutdownNode -> do
              ThreadId m -> ExceptionInHandler peerAddr -> m ()
forall (m :: * -> *) e.
(MonadFork m, Exception e) =>
ThreadId m -> e -> m ()
throwTo ThreadId m
mainThreadId (peerAddr -> SomeException -> ExceptionInHandler peerAddr
forall peerAddr.
peerAddr -> SomeException -> ExceptionInHandler peerAddr
ExceptionInHandler peerAddr
remoteAddress SomeException
err)
              SomeException -> m x
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO SomeException
err
            ErrorCommand
ShutdownPeer ->
              SomeException -> m x
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO SomeException
err

    outboundConnectionHandler
      :: HasInitiator muxMode ~ True
      => ConnectionHandlerFn (ConnectionHandlerTrace versionNumber versionData)
                             socket
                             peerAddr
                             (Handle muxMode peerAddr ByteString m a b)
                             (HandleError muxMode versionNumber)
                             (versionNumber, versionData)
                             m
    outboundConnectionHandler :: ConnectionHandlerFn
  (ConnectionHandlerTrace versionNumber versionData)
  socket
  peerAddr
  (Handle muxMode peerAddr ByteString m a b)
  (HandleError muxMode versionNumber)
  (versionNumber, versionData)
  m
outboundConnectionHandler socket
socket
                              PromiseWriter { Either
  (HandleError muxMode versionNumber)
  (Handle muxMode peerAddr ByteString m a b,
   (versionNumber, versionData))
-> STM m ()
writePromise :: forall (m :: * -> *) a. PromiseWriter m a -> a -> STM m ()
writePromise :: Either
  (HandleError muxMode versionNumber)
  (Handle muxMode peerAddr ByteString m a b,
   (versionNumber, versionData))
-> STM m ()
writePromise }
                              Tracer m (ConnectionHandlerTrace versionNumber versionData)
tracer
                              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 }
                              DiffTime -> socket -> m (MuxBearer m)
mkMuxBearer
        = MaskedAction :: forall (m :: * -> *) a.
((forall x. m x -> m x) -> m a) -> MaskedAction m a
MaskedAction { (forall x. m x -> m x) -> m ()
runWithUnmask :: (forall x. m x -> m x) -> m ()
runWithUnmask :: (forall x. m x -> m x) -> m ()
runWithUnmask }
      where
        runWithUnmask :: (forall x. m x -> m x) -> m ()
        runWithUnmask :: (forall x. m x -> m x) -> m ()
runWithUnmask forall x. m x -> m x
unmask =
          Tracer m (ConnectionHandlerTrace versionNumber versionData)
-> peerAddr -> ErrorContext -> m () -> m ()
forall x.
Tracer m (ConnectionHandlerTrace versionNumber versionData)
-> peerAddr -> ErrorContext -> m x -> m x
classifyExceptions Tracer m (ConnectionHandlerTrace versionNumber versionData)
tracer peerAddr
remoteAddress ErrorContext
OutboundError (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
            String -> m ()
forall (m :: * -> *). MonadThread m => String -> m ()
labelThisThread ([String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"out-conn-hndlr-"
                                    , peerAddr -> String
forall a. Show a => a -> String
show peerAddr
localAddress
                                    , String
"-"
                                    , peerAddr -> String
forall a. Show a => a -> String
show peerAddr
remoteAddress
                                    ])
            MuxBearer m
handshakeBearer <- DiffTime -> socket -> m (MuxBearer m)
mkMuxBearer DiffTime
sduHandshakeTimeout socket
socket
            Either
  (HandshakeException versionNumber)
  (OuroborosBundle muxMode peerAddr ByteString m a b, versionNumber,
   versionData)
hsResult <-
              m (Either
     (HandshakeException versionNumber)
     (OuroborosBundle muxMode peerAddr ByteString m a b, versionNumber,
      versionData))
-> m (Either
        (HandshakeException versionNumber)
        (OuroborosBundle muxMode peerAddr ByteString m a b, versionNumber,
         versionData))
forall x. m x -> m x
unmask (MuxBearer m
-> ConnectionId peerAddr
-> HandshakeArguments
     (ConnectionId peerAddr) versionNumber versionData m
-> Versions
     versionNumber
     versionData
     (OuroborosBundle muxMode peerAddr ByteString m a b)
-> m (Either
        (HandshakeException versionNumber)
        (OuroborosBundle muxMode peerAddr ByteString m a b, versionNumber,
         versionData))
forall (m :: * -> *) vNumber connectionId vData application.
(MonadAsync m, MonadFork m, MonadMonotonicTime m, MonadTimer m,
 MonadMask m, MonadThrow (STM m), Ord vNumber) =>
MuxBearer m
-> connectionId
-> HandshakeArguments connectionId vNumber vData m
-> Versions vNumber vData application
-> m (Either
        (HandshakeException vNumber) (application, vNumber, vData))
runHandshakeClient MuxBearer m
handshakeBearer
                                         ConnectionId peerAddr
connectionId
                                         HandshakeArguments
  (ConnectionId peerAddr) versionNumber versionData m
handshakeArguments
                                         Versions
  versionNumber
  versionData
  (OuroborosBundle muxMode peerAddr ByteString m a b)
versionedApplication)
              -- 'runHandshakeClient' only deals with protocol limit errors or
              -- handshake negotiation failures, but not with 'IOException's or
              -- 'MuxError's.
              m (Either
     (HandshakeException versionNumber)
     (OuroborosBundle muxMode peerAddr ByteString m a b, versionNumber,
      versionData))
-> (SomeException
    -> m (Either
            (HandshakeException versionNumber)
            (OuroborosBundle muxMode peerAddr ByteString m a b, versionNumber,
             versionData)))
-> m (Either
        (HandshakeException versionNumber)
        (OuroborosBundle muxMode peerAddr ByteString m a b, versionNumber,
         versionData))
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \(SomeException
err :: SomeException) -> 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
$ Either
  (HandleError muxMode versionNumber)
  (Handle muxMode peerAddr ByteString m a b,
   (versionNumber, versionData))
-> STM m ()
writePromise (HandleError muxMode versionNumber
-> Either
     (HandleError muxMode versionNumber)
     (Handle muxMode peerAddr ByteString m a b,
      (versionNumber, versionData))
forall a b. a -> Either a b
Left (SomeException -> HandleError muxMode versionNumber
forall (muxMode :: MuxMode) versionNumber.
SomeException -> HandleError muxMode versionNumber
HandleError SomeException
err))
                SomeException
-> m (Either
        (HandshakeException versionNumber)
        (OuroborosBundle muxMode peerAddr ByteString m a b, versionNumber,
         versionData))
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO SomeException
err
            case Either
  (HandshakeException versionNumber)
  (OuroborosBundle muxMode peerAddr ByteString m a b, versionNumber,
   versionData)
hsResult of
              Left !HandshakeException versionNumber
err -> 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
$ Either
  (HandleError muxMode versionNumber)
  (Handle muxMode peerAddr ByteString m a b,
   (versionNumber, versionData))
-> STM m ()
writePromise (HandleError muxMode versionNumber
-> Either
     (HandleError muxMode versionNumber)
     (Handle muxMode peerAddr ByteString m a b,
      (versionNumber, versionData))
forall a b. a -> Either a b
Left (HandshakeException versionNumber
-> HandleError muxMode versionNumber
forall (muxMode :: MuxMode) versionNumber.
(HasInitiator muxMode ~ 'True) =>
HandshakeException versionNumber
-> HandleError muxMode versionNumber
HandleHandshakeClientError HandshakeException versionNumber
err))
                Tracer m (ConnectionHandlerTrace versionNumber versionData)
-> ConnectionHandlerTrace versionNumber versionData -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (ConnectionHandlerTrace versionNumber versionData)
tracer (HandshakeException versionNumber
-> ConnectionHandlerTrace versionNumber versionData
forall versionNumber versionData.
HandshakeException versionNumber
-> ConnectionHandlerTrace versionNumber versionData
TrHandshakeClientError HandshakeException versionNumber
err)

              Right (OuroborosBundle muxMode peerAddr ByteString m a b
app, versionNumber
versionNumber, versionData
agreedOptions) ->
                m () -> m ()
forall x. m x -> m x
unmask (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
                  Tracer m (ConnectionHandlerTrace versionNumber versionData)
-> ConnectionHandlerTrace versionNumber versionData -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (ConnectionHandlerTrace versionNumber versionData)
tracer (versionNumber
-> versionData -> ConnectionHandlerTrace versionNumber versionData
forall versionNumber versionData.
versionNumber
-> versionData -> ConnectionHandlerTrace versionNumber versionData
TrHandshakeSuccess versionNumber
versionNumber versionData
agreedOptions)
                  Bundle (StrictTVar m ControlMessage)
controlMessageBundle
                    <- (\StrictTVar m ControlMessage
a StrictTVar m ControlMessage
b StrictTVar m ControlMessage
c -> WithProtocolTemperature 'Hot (StrictTVar m ControlMessage)
-> WithProtocolTemperature 'Warm (StrictTVar m ControlMessage)
-> WithProtocolTemperature
     'Established (StrictTVar m ControlMessage)
-> Bundle (StrictTVar m ControlMessage)
forall a.
WithProtocolTemperature 'Hot a
-> WithProtocolTemperature 'Warm a
-> WithProtocolTemperature 'Established a
-> Bundle a
Bundle (StrictTVar m ControlMessage
-> WithProtocolTemperature 'Hot (StrictTVar m ControlMessage)
forall a. a -> WithProtocolTemperature 'Hot a
WithHot StrictTVar m ControlMessage
a) (StrictTVar m ControlMessage
-> WithProtocolTemperature 'Warm (StrictTVar m ControlMessage)
forall a. a -> WithProtocolTemperature 'Warm a
WithWarm StrictTVar m ControlMessage
b) (StrictTVar m ControlMessage
-> WithProtocolTemperature
     'Established (StrictTVar m ControlMessage)
forall a. a -> WithProtocolTemperature 'Established a
WithEstablished StrictTVar m ControlMessage
c))
                        (StrictTVar m ControlMessage
 -> StrictTVar m ControlMessage
 -> StrictTVar m ControlMessage
 -> Bundle (StrictTVar m ControlMessage))
-> m (StrictTVar m ControlMessage)
-> m (StrictTVar m ControlMessage
      -> StrictTVar m ControlMessage
      -> Bundle (StrictTVar m ControlMessage))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ControlMessage -> m (StrictTVar m ControlMessage)
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
newTVarIO ControlMessage
Continue
                        m (StrictTVar m ControlMessage
   -> StrictTVar m ControlMessage
   -> Bundle (StrictTVar m ControlMessage))
-> m (StrictTVar m ControlMessage)
-> m (StrictTVar m ControlMessage
      -> Bundle (StrictTVar m ControlMessage))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ControlMessage -> m (StrictTVar m ControlMessage)
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
newTVarIO ControlMessage
Continue
                        m (StrictTVar m ControlMessage
   -> Bundle (StrictTVar m ControlMessage))
-> m (StrictTVar m ControlMessage)
-> m (Bundle (StrictTVar m ControlMessage))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ControlMessage -> m (StrictTVar m ControlMessage)
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
newTVarIO ControlMessage
Continue
                  let muxBundle :: MuxBundle muxMode ByteString m a b
muxBundle
                        = ConnectionId peerAddr
-> Bundle (ControlMessageSTM m)
-> OuroborosBundle muxMode peerAddr ByteString m a b
-> MuxBundle muxMode ByteString m a b
forall (mode :: MuxMode) addr bytes (m :: * -> *) a b.
ConnectionId addr
-> Bundle (ControlMessageSTM m)
-> OuroborosBundle mode addr bytes m a b
-> MuxBundle mode bytes m a b
mkMuxApplicationBundle
                            ConnectionId peerAddr
connectionId
                            (StrictTVar m ControlMessage -> ControlMessageSTM m
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (StrictTVar m ControlMessage -> ControlMessageSTM m)
-> Bundle (StrictTVar m ControlMessage)
-> Bundle (ControlMessageSTM m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bundle (StrictTVar m ControlMessage)
controlMessageBundle)
                            OuroborosBundle muxMode peerAddr ByteString m a b
app
                  Mux muxMode m
mux <- MiniProtocolBundle muxMode -> m (Mux muxMode m)
forall (m :: * -> *) (mode :: MuxMode).
MonadSTM m =>
MiniProtocolBundle mode -> m (Mux mode m)
newMux (MuxBundle muxMode ByteString m a b -> MiniProtocolBundle muxMode
forall (mode :: MuxMode) bytes (m :: * -> *) a b.
MuxBundle mode bytes m a b -> MiniProtocolBundle mode
mkMiniProtocolBundle MuxBundle muxMode ByteString m a b
muxBundle)
                  let !handle :: Handle muxMode peerAddr ByteString m a b
handle = Handle :: forall (muxMode :: MuxMode) peerAddr bytes (m :: * -> *) a b.
Mux muxMode m
-> MuxBundle muxMode bytes m a b
-> Bundle (StrictTVar m ControlMessage)
-> Handle muxMode peerAddr bytes m a b
Handle {
                          hMux :: Mux muxMode m
hMux            = Mux muxMode m
mux,
                          hMuxBundle :: MuxBundle muxMode ByteString m a b
hMuxBundle      = MuxBundle muxMode ByteString m a b
muxBundle,
                          hControlMessage :: Bundle (StrictTVar m ControlMessage)
hControlMessage = Bundle (StrictTVar m ControlMessage)
controlMessageBundle
                        }
                  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
$ Either
  (HandleError muxMode versionNumber)
  (Handle muxMode peerAddr ByteString m a b,
   (versionNumber, versionData))
-> STM m ()
writePromise ((Handle muxMode peerAddr ByteString m a b,
 (versionNumber, versionData))
-> Either
     (HandleError muxMode versionNumber)
     (Handle muxMode peerAddr ByteString m a b,
      (versionNumber, versionData))
forall a b. b -> Either a b
Right (Handle muxMode peerAddr ByteString m a b
handle, (versionNumber
versionNumber, versionData
agreedOptions)))
                  MuxBearer m
bearer <- DiffTime -> socket -> m (MuxBearer m)
mkMuxBearer DiffTime
sduTimeout socket
socket
                  Tracer m MuxTrace -> Mux muxMode m -> MuxBearer m -> m ()
forall (m :: * -> *) (mode :: MuxMode).
(MonadAsync m, MonadCatch m, MonadFork m, MonadLabelledSTM m,
 MonadThrow (STM m), MonadTime m, MonadTimer m, MonadMask m) =>
Tracer m MuxTrace -> Mux mode m -> MuxBearer m -> m ()
runMux (ConnectionId peerAddr
-> MuxTrace -> WithMuxBearer (ConnectionId peerAddr) MuxTrace
forall peerid a. peerid -> a -> WithMuxBearer peerid a
WithMuxBearer ConnectionId peerAddr
connectionId (MuxTrace -> WithMuxBearer (ConnectionId peerAddr) MuxTrace)
-> Tracer m (WithMuxBearer (ConnectionId peerAddr) MuxTrace)
-> Tracer m MuxTrace
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
`contramap` Tracer m (WithMuxBearer (ConnectionId peerAddr) MuxTrace)
muxTracer)
                         Mux muxMode m
mux MuxBearer m
bearer


    inboundConnectionHandler
      :: HasResponder muxMode ~ True
      => ConnectionHandlerFn (ConnectionHandlerTrace versionNumber versionData)
                             socket
                             peerAddr
                             (Handle muxMode peerAddr ByteString m a b)
                             (HandleError muxMode versionNumber)
                             (versionNumber, versionData)
                             m
    inboundConnectionHandler :: ConnectionHandlerFn
  (ConnectionHandlerTrace versionNumber versionData)
  socket
  peerAddr
  (Handle muxMode peerAddr ByteString m a b)
  (HandleError muxMode versionNumber)
  (versionNumber, versionData)
  m
inboundConnectionHandler socket
socket
                             PromiseWriter { Either
  (HandleError muxMode versionNumber)
  (Handle muxMode peerAddr ByteString m a b,
   (versionNumber, versionData))
-> STM m ()
writePromise :: Either
  (HandleError muxMode versionNumber)
  (Handle muxMode peerAddr ByteString m a b,
   (versionNumber, versionData))
-> STM m ()
writePromise :: forall (m :: * -> *) a. PromiseWriter m a -> a -> STM m ()
writePromise }
                             Tracer m (ConnectionHandlerTrace versionNumber versionData)
tracer
                             connectionId :: ConnectionId peerAddr
connectionId@ConnectionId { peerAddr
localAddress :: peerAddr
localAddress :: forall addr. ConnectionId addr -> addr
localAddress
                                                       , peerAddr
remoteAddress :: peerAddr
remoteAddress :: forall addr. ConnectionId addr -> addr
remoteAddress }
                             DiffTime -> socket -> m (MuxBearer m)
mkMuxBearer
        = MaskedAction :: forall (m :: * -> *) a.
((forall x. m x -> m x) -> m a) -> MaskedAction m a
MaskedAction { (forall x. m x -> m x) -> m ()
runWithUnmask :: (forall x. m x -> m x) -> m ()
runWithUnmask :: (forall x. m x -> m x) -> m ()
runWithUnmask }
      where
        runWithUnmask :: (forall x. m x -> m x) -> m ()
        runWithUnmask :: (forall x. m x -> m x) -> m ()
runWithUnmask forall x. m x -> m x
unmask =
          Tracer m (ConnectionHandlerTrace versionNumber versionData)
-> peerAddr -> ErrorContext -> m () -> m ()
forall x.
Tracer m (ConnectionHandlerTrace versionNumber versionData)
-> peerAddr -> ErrorContext -> m x -> m x
classifyExceptions Tracer m (ConnectionHandlerTrace versionNumber versionData)
tracer peerAddr
remoteAddress ErrorContext
InboundError (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
            String -> m ()
forall (m :: * -> *). MonadThread m => String -> m ()
labelThisThread ([String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"in-conn-hndlr-"
                                    , peerAddr -> String
forall a. Show a => a -> String
show peerAddr
localAddress
                                    , String
"-"
                                    , peerAddr -> String
forall a. Show a => a -> String
show peerAddr
remoteAddress
                                    ])
            MuxBearer m
handshakeBearer <- DiffTime -> socket -> m (MuxBearer m)
mkMuxBearer DiffTime
sduHandshakeTimeout socket
socket
            Either
  (HandshakeException versionNumber)
  (OuroborosBundle muxMode peerAddr ByteString m a b, versionNumber,
   versionData)
hsResult <-
              m (Either
     (HandshakeException versionNumber)
     (OuroborosBundle muxMode peerAddr ByteString m a b, versionNumber,
      versionData))
-> m (Either
        (HandshakeException versionNumber)
        (OuroborosBundle muxMode peerAddr ByteString m a b, versionNumber,
         versionData))
forall x. m x -> m x
unmask (MuxBearer m
-> ConnectionId peerAddr
-> HandshakeArguments
     (ConnectionId peerAddr) versionNumber versionData m
-> Versions
     versionNumber
     versionData
     (OuroborosBundle muxMode peerAddr ByteString m a b)
-> m (Either
        (HandshakeException versionNumber)
        (OuroborosBundle muxMode peerAddr ByteString m a b, versionNumber,
         versionData))
forall (m :: * -> *) vNumber connectionId vData application.
(MonadAsync m, MonadFork m, MonadMonotonicTime m, MonadTimer m,
 MonadMask m, MonadThrow (STM m), Ord vNumber) =>
MuxBearer m
-> connectionId
-> HandshakeArguments connectionId vNumber vData m
-> Versions vNumber vData application
-> m (Either
        (HandshakeException vNumber) (application, vNumber, vData))
runHandshakeServer MuxBearer m
handshakeBearer
                                         ConnectionId peerAddr
connectionId
                                         HandshakeArguments
  (ConnectionId peerAddr) versionNumber versionData m
handshakeArguments
                                         Versions
  versionNumber
  versionData
  (OuroborosBundle muxMode peerAddr ByteString m a b)
versionedApplication)
              -- 'runHandshakeServer' only deals with protocol limit errors or
              -- handshake negotiation failures, but not with 'IOException's or
              -- 'MuxError's.
              m (Either
     (HandshakeException versionNumber)
     (OuroborosBundle muxMode peerAddr ByteString m a b, versionNumber,
      versionData))
-> (SomeException
    -> m (Either
            (HandshakeException versionNumber)
            (OuroborosBundle muxMode peerAddr ByteString m a b, versionNumber,
             versionData)))
-> m (Either
        (HandshakeException versionNumber)
        (OuroborosBundle muxMode peerAddr ByteString m a b, versionNumber,
         versionData))
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \(SomeException
err :: SomeException) -> 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
$ Either
  (HandleError muxMode versionNumber)
  (Handle muxMode peerAddr ByteString m a b,
   (versionNumber, versionData))
-> STM m ()
writePromise (HandleError muxMode versionNumber
-> Either
     (HandleError muxMode versionNumber)
     (Handle muxMode peerAddr ByteString m a b,
      (versionNumber, versionData))
forall a b. a -> Either a b
Left (SomeException -> HandleError muxMode versionNumber
forall (muxMode :: MuxMode) versionNumber.
SomeException -> HandleError muxMode versionNumber
HandleError SomeException
err))
                SomeException
-> m (Either
        (HandshakeException versionNumber)
        (OuroborosBundle muxMode peerAddr ByteString m a b, versionNumber,
         versionData))
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO SomeException
err

            case Either
  (HandshakeException versionNumber)
  (OuroborosBundle muxMode peerAddr ByteString m a b, versionNumber,
   versionData)
hsResult of
              Left !HandshakeException versionNumber
err -> 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
$ Either
  (HandleError muxMode versionNumber)
  (Handle muxMode peerAddr ByteString m a b,
   (versionNumber, versionData))
-> STM m ()
writePromise (HandleError muxMode versionNumber
-> Either
     (HandleError muxMode versionNumber)
     (Handle muxMode peerAddr ByteString m a b,
      (versionNumber, versionData))
forall a b. a -> Either a b
Left (HandshakeException versionNumber
-> HandleError muxMode versionNumber
forall (muxMode :: MuxMode) versionNumber.
(HasResponder muxMode ~ 'True) =>
HandshakeException versionNumber
-> HandleError muxMode versionNumber
HandleHandshakeServerError HandshakeException versionNumber
err))
                Tracer m (ConnectionHandlerTrace versionNumber versionData)
-> ConnectionHandlerTrace versionNumber versionData -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (ConnectionHandlerTrace versionNumber versionData)
tracer (HandshakeException versionNumber
-> ConnectionHandlerTrace versionNumber versionData
forall versionNumber versionData.
HandshakeException versionNumber
-> ConnectionHandlerTrace versionNumber versionData
TrHandshakeServerError HandshakeException versionNumber
err)
              Right (OuroborosBundle muxMode peerAddr ByteString m a b
app, versionNumber
versionNumber, versionData
agreedOptions) ->
                m () -> m ()
forall x. m x -> m x
unmask (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
                  Tracer m (ConnectionHandlerTrace versionNumber versionData)
-> ConnectionHandlerTrace versionNumber versionData -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (ConnectionHandlerTrace versionNumber versionData)
tracer (versionNumber
-> versionData -> ConnectionHandlerTrace versionNumber versionData
forall versionNumber versionData.
versionNumber
-> versionData -> ConnectionHandlerTrace versionNumber versionData
TrHandshakeSuccess versionNumber
versionNumber versionData
agreedOptions)
                  Bundle (StrictTVar m ControlMessage)
controlMessageBundle
                    <- (\StrictTVar m ControlMessage
a StrictTVar m ControlMessage
b StrictTVar m ControlMessage
c -> WithProtocolTemperature 'Hot (StrictTVar m ControlMessage)
-> WithProtocolTemperature 'Warm (StrictTVar m ControlMessage)
-> WithProtocolTemperature
     'Established (StrictTVar m ControlMessage)
-> Bundle (StrictTVar m ControlMessage)
forall a.
WithProtocolTemperature 'Hot a
-> WithProtocolTemperature 'Warm a
-> WithProtocolTemperature 'Established a
-> Bundle a
Bundle (StrictTVar m ControlMessage
-> WithProtocolTemperature 'Hot (StrictTVar m ControlMessage)
forall a. a -> WithProtocolTemperature 'Hot a
WithHot StrictTVar m ControlMessage
a) (StrictTVar m ControlMessage
-> WithProtocolTemperature 'Warm (StrictTVar m ControlMessage)
forall a. a -> WithProtocolTemperature 'Warm a
WithWarm StrictTVar m ControlMessage
b) (StrictTVar m ControlMessage
-> WithProtocolTemperature
     'Established (StrictTVar m ControlMessage)
forall a. a -> WithProtocolTemperature 'Established a
WithEstablished StrictTVar m ControlMessage
c))
                        (StrictTVar m ControlMessage
 -> StrictTVar m ControlMessage
 -> StrictTVar m ControlMessage
 -> Bundle (StrictTVar m ControlMessage))
-> m (StrictTVar m ControlMessage)
-> m (StrictTVar m ControlMessage
      -> StrictTVar m ControlMessage
      -> Bundle (StrictTVar m ControlMessage))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ControlMessage -> m (StrictTVar m ControlMessage)
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
newTVarIO ControlMessage
Continue
                        m (StrictTVar m ControlMessage
   -> StrictTVar m ControlMessage
   -> Bundle (StrictTVar m ControlMessage))
-> m (StrictTVar m ControlMessage)
-> m (StrictTVar m ControlMessage
      -> Bundle (StrictTVar m ControlMessage))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ControlMessage -> m (StrictTVar m ControlMessage)
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
newTVarIO ControlMessage
Continue
                        m (StrictTVar m ControlMessage
   -> Bundle (StrictTVar m ControlMessage))
-> m (StrictTVar m ControlMessage)
-> m (Bundle (StrictTVar m ControlMessage))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ControlMessage -> m (StrictTVar m ControlMessage)
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
newTVarIO ControlMessage
Continue
                  let muxBundle :: MuxBundle muxMode ByteString m a b
muxBundle
                        = ConnectionId peerAddr
-> Bundle (ControlMessageSTM m)
-> OuroborosBundle muxMode peerAddr ByteString m a b
-> MuxBundle muxMode ByteString m a b
forall (mode :: MuxMode) addr bytes (m :: * -> *) a b.
ConnectionId addr
-> Bundle (ControlMessageSTM m)
-> OuroborosBundle mode addr bytes m a b
-> MuxBundle mode bytes m a b
mkMuxApplicationBundle
                            ConnectionId peerAddr
connectionId
                            (StrictTVar m ControlMessage -> ControlMessageSTM m
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (StrictTVar m ControlMessage -> ControlMessageSTM m)
-> Bundle (StrictTVar m ControlMessage)
-> Bundle (ControlMessageSTM m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bundle (StrictTVar m ControlMessage)
controlMessageBundle)
                            OuroborosBundle muxMode peerAddr ByteString m a b
app
                  Mux muxMode m
mux <- MiniProtocolBundle muxMode -> m (Mux muxMode m)
forall (m :: * -> *) (mode :: MuxMode).
MonadSTM m =>
MiniProtocolBundle mode -> m (Mux mode m)
newMux (MuxBundle muxMode ByteString m a b -> MiniProtocolBundle muxMode
forall (mode :: MuxMode) bytes (m :: * -> *) a b.
MuxBundle mode bytes m a b -> MiniProtocolBundle mode
mkMiniProtocolBundle MuxBundle muxMode ByteString m a b
muxBundle)
                  let !handle :: Handle muxMode peerAddr ByteString m a b
handle = Handle :: forall (muxMode :: MuxMode) peerAddr bytes (m :: * -> *) a b.
Mux muxMode m
-> MuxBundle muxMode bytes m a b
-> Bundle (StrictTVar m ControlMessage)
-> Handle muxMode peerAddr bytes m a b
Handle {
                          hMux :: Mux muxMode m
hMux            = Mux muxMode m
mux,
                          hMuxBundle :: MuxBundle muxMode ByteString m a b
hMuxBundle      = MuxBundle muxMode ByteString m a b
muxBundle,
                          hControlMessage :: Bundle (StrictTVar m ControlMessage)
hControlMessage = Bundle (StrictTVar m ControlMessage)
controlMessageBundle
                        }
                  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
$ Either
  (HandleError muxMode versionNumber)
  (Handle muxMode peerAddr ByteString m a b,
   (versionNumber, versionData))
-> STM m ()
writePromise ((Handle muxMode peerAddr ByteString m a b,
 (versionNumber, versionData))
-> Either
     (HandleError muxMode versionNumber)
     (Handle muxMode peerAddr ByteString m a b,
      (versionNumber, versionData))
forall a b. b -> Either a b
Right (Handle muxMode peerAddr ByteString m a b
handle, (versionNumber
versionNumber, versionData
agreedOptions)))
                  MuxBearer m
bearer <- DiffTime -> socket -> m (MuxBearer m)
mkMuxBearer DiffTime
sduTimeout socket
socket
                  Tracer m MuxTrace -> Mux muxMode m -> MuxBearer m -> m ()
forall (m :: * -> *) (mode :: MuxMode).
(MonadAsync m, MonadCatch m, MonadFork m, MonadLabelledSTM m,
 MonadThrow (STM m), MonadTime m, MonadTimer m, MonadMask m) =>
Tracer m MuxTrace -> Mux mode m -> MuxBearer m -> m ()
runMux (ConnectionId peerAddr
-> MuxTrace -> WithMuxBearer (ConnectionId peerAddr) MuxTrace
forall peerid a. peerid -> a -> WithMuxBearer peerid a
WithMuxBearer ConnectionId peerAddr
connectionId (MuxTrace -> WithMuxBearer (ConnectionId peerAddr) MuxTrace)
-> Tracer m (WithMuxBearer (ConnectionId peerAddr) MuxTrace)
-> Tracer m MuxTrace
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
`contramap` Tracer m (WithMuxBearer (ConnectionId peerAddr) MuxTrace)
muxTracer)
                             Mux muxMode m
mux MuxBearer m
bearer



--
-- Tracing
--


-- | 'ConnectionHandlerTrace' is embedded into 'ConnectionManagerTrace' with
-- 'Ouroboros.Network.ConnectionManager.Types.ConnectionHandlerTrace'
-- constructor.  It already includes 'ConnectionId' so we don't need to take
-- care of it here.
--
-- TODO: when 'Handshake' will get its own tracer, independent of 'Mux', it
-- should be embedded into 'ConnectionHandlerTrace'.
--
data ConnectionHandlerTrace versionNumber versionData =
      TrHandshakeSuccess versionNumber versionData
    | TrHandshakeClientError
        (HandshakeException versionNumber)
    | TrHandshakeServerError
        (HandshakeException versionNumber)
    | TrError ErrorContext SomeException ErrorCommand
  deriving Int -> ConnectionHandlerTrace versionNumber versionData -> ShowS
[ConnectionHandlerTrace versionNumber versionData] -> ShowS
ConnectionHandlerTrace versionNumber versionData -> String
(Int -> ConnectionHandlerTrace versionNumber versionData -> ShowS)
-> (ConnectionHandlerTrace versionNumber versionData -> String)
-> ([ConnectionHandlerTrace versionNumber versionData] -> ShowS)
-> Show (ConnectionHandlerTrace versionNumber versionData)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall versionNumber versionData.
(Show versionNumber, Show versionData) =>
Int -> ConnectionHandlerTrace versionNumber versionData -> ShowS
forall versionNumber versionData.
(Show versionNumber, Show versionData) =>
[ConnectionHandlerTrace versionNumber versionData] -> ShowS
forall versionNumber versionData.
(Show versionNumber, Show versionData) =>
ConnectionHandlerTrace versionNumber versionData -> String
showList :: [ConnectionHandlerTrace versionNumber versionData] -> ShowS
$cshowList :: forall versionNumber versionData.
(Show versionNumber, Show versionData) =>
[ConnectionHandlerTrace versionNumber versionData] -> ShowS
show :: ConnectionHandlerTrace versionNumber versionData -> String
$cshow :: forall versionNumber versionData.
(Show versionNumber, Show versionData) =>
ConnectionHandlerTrace versionNumber versionData -> String
showsPrec :: Int -> ConnectionHandlerTrace versionNumber versionData -> ShowS
$cshowsPrec :: forall versionNumber versionData.
(Show versionNumber, Show versionData) =>
Int -> ConnectionHandlerTrace versionNumber versionData -> ShowS
Show