{-# LANGUAGE CPP                 #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE KindSignatures      #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators       #-}

-- 'runResponder' is using a redundant constraint.
{-# OPTIONS_GHC -Wno-redundant-constraints #-}

-- | Server implementation based on 'ConnectionManager'
--
-- This module should be imported qualified.
--
module Ouroboros.Network.Server2
  ( Arguments (..)
    -- * Run server
  , with
    -- * Trace
  , Trace (..)
  , AcceptConnectionsPolicyTrace (..)
  , InboundGovernor.RemoteSt (..)
  , InboundGovernor.RemoteTransition
  , InboundGovernor.RemoteTransitionTrace
  , isECONNABORTED
  ) where

import Control.Applicative (Alternative)
import Control.Concurrent.Class.MonadSTM.Strict
import Control.Monad.Class.MonadAsync
import Control.Monad.Class.MonadFork
import Control.Monad.Class.MonadThrow hiding (handle)
import Control.Monad.Class.MonadTime.SI
import Control.Monad.Class.MonadTimer.SI
import Control.Tracer (Tracer, contramap, traceWith)

import Data.ByteString.Lazy (ByteString)
import Data.List as List (foldl')
import Data.List.NonEmpty (NonEmpty)
import Data.List.NonEmpty qualified as NonEmpty
import Data.Void (Void, absurd)
import GHC.IO.Exception
#if !defined(mingw32_HOST_OS)
import Foreign.C.Error
#endif

import Network.Mux qualified as Mx
import Ouroboros.Network.ConnectionHandler
import Ouroboros.Network.ConnectionId (ConnectionId (..))
import Ouroboros.Network.ConnectionManager.InformationChannel
           (InboundGovernorInfoChannel)
import Ouroboros.Network.ConnectionManager.Types
import Ouroboros.Network.Context (ResponderContext)
import Ouroboros.Network.InboundGovernor qualified as InboundGovernor
import Ouroboros.Network.Mux
import Ouroboros.Network.Server.RateLimiting
import Ouroboros.Network.Snocket


--
-- Server API
--


-- | Server static configuration.
--
data Arguments (muxMode  :: Mx.Mode) socket initiatorCtx peerAddr versionData versionNumber bytes m a b =
    Arguments {
      forall (muxMode :: Mode) socket initiatorCtx peerAddr versionData
       versionNumber bytes (m :: * -> *) a b.
Arguments
  muxMode
  socket
  initiatorCtx
  peerAddr
  versionData
  versionNumber
  bytes
  m
  a
  b
-> NonEmpty socket
sockets               :: NonEmpty socket,
      forall (muxMode :: Mode) socket initiatorCtx peerAddr versionData
       versionNumber bytes (m :: * -> *) a b.
Arguments
  muxMode
  socket
  initiatorCtx
  peerAddr
  versionData
  versionNumber
  bytes
  m
  a
  b
-> Snocket m socket peerAddr
snocket               :: Snocket m socket peerAddr,
      forall (muxMode :: Mode) socket initiatorCtx peerAddr versionData
       versionNumber bytes (m :: * -> *) a b.
Arguments
  muxMode
  socket
  initiatorCtx
  peerAddr
  versionData
  versionNumber
  bytes
  m
  a
  b
-> Tracer m (Trace peerAddr)
tracer                :: Tracer m (Trace peerAddr),
      forall (muxMode :: Mode) socket initiatorCtx peerAddr versionData
       versionNumber bytes (m :: * -> *) a b.
Arguments
  muxMode
  socket
  initiatorCtx
  peerAddr
  versionData
  versionNumber
  bytes
  m
  a
  b
-> Tracer m (RemoteTransitionTrace peerAddr)
trTracer              :: Tracer m (InboundGovernor.RemoteTransitionTrace peerAddr),
      forall (muxMode :: Mode) socket initiatorCtx peerAddr versionData
       versionNumber bytes (m :: * -> *) a b.
Arguments
  muxMode
  socket
  initiatorCtx
  peerAddr
  versionData
  versionNumber
  bytes
  m
  a
  b
-> Tracer m (Trace peerAddr)
inboundGovernorTracer :: Tracer m (InboundGovernor.Trace peerAddr),
      forall (muxMode :: Mode) socket initiatorCtx peerAddr versionData
       versionNumber bytes (m :: * -> *) a b.
Arguments
  muxMode
  socket
  initiatorCtx
  peerAddr
  versionData
  versionNumber
  bytes
  m
  a
  b
-> Tracer m (Debug peerAddr versionData)
debugInboundGovernor  :: Tracer m (InboundGovernor.Debug peerAddr versionData),
      forall (muxMode :: Mode) socket initiatorCtx peerAddr versionData
       versionNumber bytes (m :: * -> *) a b.
Arguments
  muxMode
  socket
  initiatorCtx
  peerAddr
  versionData
  versionNumber
  bytes
  m
  a
  b
-> AcceptedConnectionsLimit
connectionLimits      :: AcceptedConnectionsLimit,
      forall (muxMode :: Mode) socket initiatorCtx peerAddr versionData
       versionNumber bytes (m :: * -> *) a b.
Arguments
  muxMode
  socket
  initiatorCtx
  peerAddr
  versionData
  versionNumber
  bytes
  m
  a
  b
-> MuxConnectionManager
     muxMode
     socket
     initiatorCtx
     (ResponderContext peerAddr)
     peerAddr
     versionData
     versionNumber
     bytes
     m
     a
     b
connectionManager     :: MuxConnectionManager muxMode socket initiatorCtx (ResponderContext peerAddr)
                                                          peerAddr versionData versionNumber bytes m a b,

      -- | Time for which all protocols need to be idle to trigger
      -- 'DemotedToCold' transition.
      --
      forall (muxMode :: Mode) socket initiatorCtx peerAddr versionData
       versionNumber bytes (m :: * -> *) a b.
Arguments
  muxMode
  socket
  initiatorCtx
  peerAddr
  versionData
  versionNumber
  bytes
  m
  a
  b
-> Maybe DiffTime
inboundIdleTimeout    :: Maybe DiffTime,

      forall (muxMode :: Mode) socket initiatorCtx peerAddr versionData
       versionNumber bytes (m :: * -> *) a b.
Arguments
  muxMode
  socket
  initiatorCtx
  peerAddr
  versionData
  versionNumber
  bytes
  m
  a
  b
-> versionData -> DataFlow
connectionDataFlow    :: versionData -> DataFlow,

      -- | Server control var is passed as an argument; this allows to use the
      -- server to run and manage responders which needs to be started on
      -- inbound connections.
      --
      forall (muxMode :: Mode) socket initiatorCtx peerAddr versionData
       versionNumber bytes (m :: * -> *) a b.
Arguments
  muxMode
  socket
  initiatorCtx
  peerAddr
  versionData
  versionNumber
  bytes
  m
  a
  b
-> InboundGovernorInfoChannel
     muxMode initiatorCtx peerAddr versionData bytes m a b
inboundInfoChannel    :: InboundGovernorInfoChannel muxMode initiatorCtx peerAddr versionData
                                                                bytes m a b
    }

-- | Server pauses accepting connections after an 'CONNABORTED' error.
--
server_CONNABORTED_DELAY :: DiffTime
server_CONNABORTED_DELAY :: DiffTime
server_CONNABORTED_DELAY = DiffTime
0.5

-- | Run the server, which consists of the following components:
--
-- * /inbound governor/, it corresponds to p2p-governor on outbound side
-- * /accept loop(s)/, one per given ip address.  We support up to one ipv4
--   address and up to one ipv6 address, i.e. an ipv6 enabled node will run two
--   accept loops on listening on different addresses with shared /inbound governor/.
--
-- The server can be run in either of two 'MuxMode'-es:
--
-- * 'InitiatorResponderMode'
-- * 'ResponderMode'
--
-- The first one is used in data diffusion for /Node-To-Node protocol/, while the
-- other is useful for running a server for the /Node-To-Client protocol/.
--
with :: forall muxMode socket initiatorCtx peerAddr versionData versionNumber m a b x.
       ( Alternative (STM m)
       , MonadAsync    m
       , MonadDelay    m
       , MonadCatch    m
       , MonadEvaluate m
       , MonadLabelledSTM  m
       , MonadMask     m
       , MonadThrow   (STM m)
       , MonadTime     m
       , MonadTimer    m
       , HasResponder muxMode ~ True
       , Ord      peerAddr
       , Show     peerAddr
       )
    => Arguments muxMode socket initiatorCtx peerAddr versionData versionNumber ByteString m a b
    -- ^ record which holds all server arguments
    -> (Async m Void -> m (InboundGovernor.PublicState peerAddr versionData) -> m x)
    -- ^ a callback which receives a handle to inbound governor thread and can
    -- read `PublicState`.
    --
    -- Note that as soon as the callback returns, all threads run by the server
    -- will be stopped.
    -> m x
with :: forall (muxMode :: Mode) socket initiatorCtx peerAddr versionData
       versionNumber (m :: * -> *) a b x.
(Alternative (STM m), MonadAsync m, MonadDelay m, MonadCatch m,
 MonadEvaluate m, MonadLabelledSTM m, MonadMask m,
 MonadThrow (STM m), MonadTime m, MonadTimer m,
 HasResponder muxMode ~ 'True, Ord peerAddr, Show peerAddr) =>
Arguments
  muxMode
  socket
  initiatorCtx
  peerAddr
  versionData
  versionNumber
  ByteString
  m
  a
  b
-> (Async m Void -> m (PublicState peerAddr versionData) -> m x)
-> m x
with Arguments {
      sockets :: forall (muxMode :: Mode) socket initiatorCtx peerAddr versionData
       versionNumber bytes (m :: * -> *) a b.
Arguments
  muxMode
  socket
  initiatorCtx
  peerAddr
  versionData
  versionNumber
  bytes
  m
  a
  b
-> NonEmpty socket
sockets = NonEmpty socket
socks,
      Snocket m socket peerAddr
snocket :: forall (muxMode :: Mode) socket initiatorCtx peerAddr versionData
       versionNumber bytes (m :: * -> *) a b.
Arguments
  muxMode
  socket
  initiatorCtx
  peerAddr
  versionData
  versionNumber
  bytes
  m
  a
  b
-> Snocket m socket peerAddr
snocket :: Snocket m socket peerAddr
snocket,
      Tracer m (RemoteTransitionTrace peerAddr)
trTracer :: forall (muxMode :: Mode) socket initiatorCtx peerAddr versionData
       versionNumber bytes (m :: * -> *) a b.
Arguments
  muxMode
  socket
  initiatorCtx
  peerAddr
  versionData
  versionNumber
  bytes
  m
  a
  b
-> Tracer m (RemoteTransitionTrace peerAddr)
trTracer :: Tracer m (RemoteTransitionTrace peerAddr)
trTracer,
      tracer :: forall (muxMode :: Mode) socket initiatorCtx peerAddr versionData
       versionNumber bytes (m :: * -> *) a b.
Arguments
  muxMode
  socket
  initiatorCtx
  peerAddr
  versionData
  versionNumber
  bytes
  m
  a
  b
-> Tracer m (Trace peerAddr)
tracer = Tracer m (Trace peerAddr)
tracer,
      inboundGovernorTracer :: forall (muxMode :: Mode) socket initiatorCtx peerAddr versionData
       versionNumber bytes (m :: * -> *) a b.
Arguments
  muxMode
  socket
  initiatorCtx
  peerAddr
  versionData
  versionNumber
  bytes
  m
  a
  b
-> Tracer m (Trace peerAddr)
inboundGovernorTracer = Tracer m (Trace peerAddr)
inboundGovernorTracer,
      Tracer m (Debug peerAddr versionData)
debugInboundGovernor :: forall (muxMode :: Mode) socket initiatorCtx peerAddr versionData
       versionNumber bytes (m :: * -> *) a b.
Arguments
  muxMode
  socket
  initiatorCtx
  peerAddr
  versionData
  versionNumber
  bytes
  m
  a
  b
-> Tracer m (Debug peerAddr versionData)
debugInboundGovernor :: Tracer m (Debug peerAddr versionData)
debugInboundGovernor,
      connectionLimits :: forall (muxMode :: Mode) socket initiatorCtx peerAddr versionData
       versionNumber bytes (m :: * -> *) a b.
Arguments
  muxMode
  socket
  initiatorCtx
  peerAddr
  versionData
  versionNumber
  bytes
  m
  a
  b
-> AcceptedConnectionsLimit
connectionLimits =
        limits :: AcceptedConnectionsLimit
limits@AcceptedConnectionsLimit { acceptedConnectionsHardLimit :: AcceptedConnectionsLimit -> Word32
acceptedConnectionsHardLimit = Word32
hardLimit },
      Maybe DiffTime
inboundIdleTimeout :: forall (muxMode :: Mode) socket initiatorCtx peerAddr versionData
       versionNumber bytes (m :: * -> *) a b.
Arguments
  muxMode
  socket
  initiatorCtx
  peerAddr
  versionData
  versionNumber
  bytes
  m
  a
  b
-> Maybe DiffTime
inboundIdleTimeout :: Maybe DiffTime
inboundIdleTimeout,
      MuxConnectionManager
  muxMode
  socket
  initiatorCtx
  (ResponderContext peerAddr)
  peerAddr
  versionData
  versionNumber
  ByteString
  m
  a
  b
connectionManager :: forall (muxMode :: Mode) socket initiatorCtx peerAddr versionData
       versionNumber bytes (m :: * -> *) a b.
Arguments
  muxMode
  socket
  initiatorCtx
  peerAddr
  versionData
  versionNumber
  bytes
  m
  a
  b
-> MuxConnectionManager
     muxMode
     socket
     initiatorCtx
     (ResponderContext peerAddr)
     peerAddr
     versionData
     versionNumber
     bytes
     m
     a
     b
connectionManager :: MuxConnectionManager
  muxMode
  socket
  initiatorCtx
  (ResponderContext peerAddr)
  peerAddr
  versionData
  versionNumber
  ByteString
  m
  a
  b
connectionManager,
      versionData -> DataFlow
connectionDataFlow :: forall (muxMode :: Mode) socket initiatorCtx peerAddr versionData
       versionNumber bytes (m :: * -> *) a b.
Arguments
  muxMode
  socket
  initiatorCtx
  peerAddr
  versionData
  versionNumber
  bytes
  m
  a
  b
-> versionData -> DataFlow
connectionDataFlow :: versionData -> DataFlow
connectionDataFlow,
      InboundGovernorInfoChannel
  muxMode initiatorCtx peerAddr versionData ByteString m a b
inboundInfoChannel :: forall (muxMode :: Mode) socket initiatorCtx peerAddr versionData
       versionNumber bytes (m :: * -> *) a b.
Arguments
  muxMode
  socket
  initiatorCtx
  peerAddr
  versionData
  versionNumber
  bytes
  m
  a
  b
-> InboundGovernorInfoChannel
     muxMode initiatorCtx peerAddr versionData bytes m a b
inboundInfoChannel :: InboundGovernorInfoChannel
  muxMode initiatorCtx peerAddr versionData ByteString m a b
inboundInfoChannel
    }
    Async m Void -> m (PublicState peerAddr versionData) -> m x
k = do
      let sockets :: [socket]
sockets = NonEmpty socket -> [socket]
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty socket
socks
      localAddresses <- (socket -> m peerAddr) -> [socket] -> m [peerAddr]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Snocket m socket peerAddr -> socket -> m peerAddr
forall (m :: * -> *) fd addr. Snocket m fd addr -> fd -> m addr
getLocalAddr Snocket m socket peerAddr
snocket) [socket]
sockets
      traceWith tracer (TrServerStarted localAddresses)
      InboundGovernor.with
        InboundGovernor.Arguments {
          InboundGovernor.transitionTracer   = trTracer,
          InboundGovernor.tracer             = inboundGovernorTracer,
          InboundGovernor.debugTracer        = debugInboundGovernor,
          InboundGovernor.connectionDataFlow = connectionDataFlow,
          InboundGovernor.infoChannel        = inboundInfoChannel,
          InboundGovernor.idleTimeout        = inboundIdleTimeout,
          InboundGovernor.connectionManager  = connectionManager
        } $ \Async m Void
inboundGovernorThread m (PublicState peerAddr versionData)
readPublicInboundState ->
        m x -> (Async m x -> m x) -> m x
forall a b. m a -> (Async m a -> m b) -> m b
forall (m :: * -> *) a b.
MonadAsync m =>
m a -> (Async m a -> m b) -> m b
withAsync (Async m Void -> m (PublicState peerAddr versionData) -> m x
k Async m Void
inboundGovernorThread m (PublicState peerAddr versionData)
readPublicInboundState) ((Async m x -> m x) -> m x) -> (Async m x -> m x) -> m x
forall a b. (a -> b) -> a -> b
$ \Async m x
actionThread -> do
          let acceptLoops :: [m Void]
              acceptLoops :: [m Void]
acceptLoops =
                          [ (Snocket m socket peerAddr -> socket -> m (Accept m socket peerAddr)
forall (m :: * -> *) fd addr.
Snocket m fd addr -> fd -> m (Accept m fd addr)
accept Snocket m socket peerAddr
snocket socket
socket m (Accept m socket peerAddr)
-> (Accept m socket peerAddr -> m Void) -> m Void
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= peerAddr -> Accept m socket peerAddr -> m Void
acceptLoop peerAddr
localAddress)
                              m Void -> m () -> m Void
forall a b. m a -> m b -> m a
forall (m :: * -> *) a b. MonadThrow m => m a -> m b -> m a
`finally` Snocket m socket peerAddr -> socket -> m ()
forall (m :: * -> *) fd addr. Snocket m fd addr -> fd -> m ()
close Snocket m socket peerAddr
snocket socket
socket
                          | (peerAddr
localAddress, socket
socket) <- [peerAddr]
localAddresses [peerAddr] -> [socket] -> [(peerAddr, socket)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [socket]
sockets
                          ]
          -- race all `acceptLoops` with `actionThread` and
          -- `inboundGovernorThread`
          (m x -> m Void -> m x) -> m x -> [m Void] -> m x
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' (\m x
as m Void
io -> Either x Void -> x
fn (Either x Void -> x) -> m (Either x Void) -> m x
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m x
as m x -> m Void -> m (Either x Void)
forall a b. m a -> m b -> m (Either a b)
forall (m :: * -> *) a b.
MonadAsync m =>
m a -> m b -> m (Either a b)
`race` m Void
io)
                 (Either x Void -> x
fn (Either x Void -> x) -> m (Either x Void) -> m x
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Async m x
actionThread Async m x -> Async m Void -> m (Either x Void)
forall a b. Async m a -> Async m b -> m (Either a b)
forall (m :: * -> *) a b.
MonadAsync m =>
Async m a -> Async m b -> m (Either a b)
`waitEither` Async m Void
inboundGovernorThread)
                 [m Void]
acceptLoops
            m x -> m () -> m x
forall a b. m a -> m b -> m a
forall (m :: * -> *) a b. MonadThrow m => m a -> m b -> m a
`finally`
              Tracer m (Trace peerAddr) -> Trace peerAddr -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (Trace peerAddr)
tracer Trace peerAddr
forall peerAddr. Trace peerAddr
TrServerStopped
            m x -> (SomeException -> m x) -> m x
forall e a. Exception e => m a -> (e -> m a) -> m a
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch`
              \(SomeException
e :: SomeException) -> do
                case SomeException -> Maybe AsyncCancelled
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
                  Just (AsyncCancelled
_ :: AsyncCancelled) -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                  Maybe AsyncCancelled
Nothing                    -> Tracer m (Trace peerAddr) -> Trace peerAddr -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (Trace peerAddr)
tracer (SomeException -> Trace peerAddr
forall peerAddr. SomeException -> Trace peerAddr
TrServerError SomeException
e)
                SomeException -> m x
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO SomeException
e
  where
    fn :: Either x Void -> x
    fn :: Either x Void -> x
fn (Left x
x)  = x
x
    fn (Right Void
v) = Void -> x
forall a. Void -> a
absurd Void
v

    acceptLoop :: peerAddr
               -> Accept m socket peerAddr
               -> m Void
    acceptLoop :: peerAddr -> Accept m socket peerAddr -> m Void
acceptLoop peerAddr
localAddress Accept m socket peerAddr
acceptOne0 = ((forall a. m a -> m a) -> m Void) -> m Void
forall b. ((forall a. m a -> m a) -> m b) -> m b
forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
mask (((forall a. m a -> m a) -> m Void) -> m Void)
-> ((forall a. m a -> m a) -> m Void) -> m Void
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> m a
unmask -> do
        String -> m ()
forall (m :: * -> *). MonadThread m => String -> m ()
labelThisThread (String
"accept-loop-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ peerAddr -> String
forall a. Show a => a -> String
show peerAddr
localAddress)
        (forall a. m a -> m a) -> Accept m socket peerAddr -> m Void
go m y -> m y
forall a. m a -> m a
unmask Accept m socket peerAddr
acceptOne0
        m Void -> (SomeException -> m Void) -> m Void
forall e a. Exception e => m a -> (e -> m a) -> m a
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \ SomeException
e -> Tracer m (Trace peerAddr) -> Trace peerAddr -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (Trace peerAddr)
tracer (SomeException -> Trace peerAddr
forall peerAddr. SomeException -> Trace peerAddr
TrServerError SomeException
e)
                    m () -> m Void -> m Void
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SomeException -> m Void
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO SomeException
e
      where
        -- we must guarantee that 'includeInboundConnection' is called,
        -- otherwise we will have a resource leak.
        --
        -- The 'mask' makes sure that exceptions are not delivered once
        -- between accepting a socket and starting thread that runs
        -- 'includeInboundConnection'.
        --
        -- NOTE: when we will make 'includeInboundConnection' a non blocking
        -- (issue #3478) we still need to guarantee the above property.
        --
        go :: (forall y. m y -> m y)
           -> Accept m socket peerAddr
           -> m Void
        go :: (forall a. m a -> m a) -> Accept m socket peerAddr -> m Void
go forall a. m a -> m a
unmask Accept m socket peerAddr
acceptOne = do
          result <- m (Accepted socket peerAddr, Accept m socket peerAddr)
-> m (Accepted socket peerAddr, Accept m socket peerAddr)
forall a. m a -> m a
unmask (m (Accepted socket peerAddr, Accept m socket peerAddr)
 -> m (Accepted socket peerAddr, Accept m socket peerAddr))
-> m (Accepted socket peerAddr, Accept m socket peerAddr)
-> m (Accepted socket peerAddr, Accept m socket peerAddr)
forall a b. (a -> b) -> a -> b
$ do
            Tracer m AcceptConnectionsPolicyTrace
-> STM m Int -> AcceptedConnectionsLimit -> m ()
forall (m :: * -> *).
(MonadSTM m, MonadDelay m) =>
Tracer m AcceptConnectionsPolicyTrace
-> STM m Int -> AcceptedConnectionsLimit -> m ()
runConnectionRateLimits
              (AcceptConnectionsPolicyTrace -> Trace peerAddr
forall peerAddr. AcceptConnectionsPolicyTrace -> Trace peerAddr
TrAcceptPolicyTrace (AcceptConnectionsPolicyTrace -> Trace peerAddr)
-> Tracer m (Trace peerAddr)
-> Tracer m AcceptConnectionsPolicyTrace
forall a' a. (a' -> a) -> Tracer m a -> Tracer m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
`contramap` Tracer m (Trace peerAddr)
tracer)
              (MuxConnectionManager
  muxMode
  socket
  initiatorCtx
  (ResponderContext peerAddr)
  peerAddr
  versionData
  versionNumber
  ByteString
  m
  a
  b
-> STM m Int
forall (muxMode :: Mode) socket peerAddr handle handleError
       (m :: * -> *).
(HasResponder muxMode ~ 'True) =>
ConnectionManager muxMode socket peerAddr handle handleError m
-> STM m Int
numberOfConnections MuxConnectionManager
  muxMode
  socket
  initiatorCtx
  (ResponderContext peerAddr)
  peerAddr
  versionData
  versionNumber
  ByteString
  m
  a
  b
connectionManager)
              AcceptedConnectionsLimit
limits
            Accept m socket peerAddr
-> m (Accepted socket peerAddr, Accept m socket peerAddr)
forall (m :: * -> *) fd addr.
Accept m fd addr -> m (Accepted fd addr, Accept m fd addr)
runAccept Accept m socket peerAddr
acceptOne

          case result of
            (AcceptFailure SomeException
err, Accept m socket peerAddr
acceptNext) -> do
              Tracer m (Trace peerAddr) -> Trace peerAddr -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (Trace peerAddr)
tracer (SomeException -> Trace peerAddr
forall peerAddr. SomeException -> Trace peerAddr
TrAcceptError SomeException
err)
              -- Try to determine if the connection was aborted by the remote
              -- end before we could process the accept, or if it was a resource
              -- exhaustion problem. NB. This piece of code is fragile and
              -- depends on specific strings/mappings in the network and base
              -- libraries.
              case SomeException -> Maybe IOError
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
err of
                Just IOError
ioErr | IOError -> Bool
isECONNABORTED IOError
ioErr -> do
                  DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
server_CONNABORTED_DELAY
                  (forall a. m a -> m a) -> Accept m socket peerAddr -> m Void
go m y -> m y
forall a. m a -> m a
unmask Accept m socket peerAddr
acceptNext
                -- all other exceptions are fatal for the whole process, hence
                -- no need to use a rethrow policy
                Maybe IOError
_ -> SomeException -> m Void
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO SomeException
err

            (Accepted socket
socket peerAddr
remoteAddress, Accept m socket peerAddr
acceptNext) ->
              (do
                  localAddress' <- Snocket m socket peerAddr -> socket -> m peerAddr
forall (m :: * -> *) fd addr. Snocket m fd addr -> fd -> m addr
getLocalAddr Snocket m socket peerAddr
snocket socket
socket
                  let connId = ConnectionId { localAddress :: peerAddr
localAddress = peerAddr
localAddress',
                                              peerAddr
remoteAddress :: peerAddr
remoteAddress :: peerAddr
remoteAddress }
                  traceWith tracer (TrAcceptConnection connId)
                  async $
                    do
                       a <-
                         unmask
                           (includeInboundConnection
                             connectionManager
                             hardLimit socket connId)
                       case a of
                         Connected {}    -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                         Disconnected {} -> Snocket m socket peerAddr -> socket -> m ()
forall (m :: * -> *) fd addr. Snocket m fd addr -> fd -> m ()
close Snocket m socket peerAddr
snocket socket
socket
                    `onException`
                      close snocket socket
              m (Async m ()) -> m () -> m (Async m ())
forall a b. m a -> m b -> m a
forall (m :: * -> *) a b. MonadCatch m => m a -> m b -> m a
`onException`
                 Snocket m socket peerAddr -> socket -> m ()
forall (m :: * -> *) fd addr. Snocket m fd addr -> fd -> m ()
close Snocket m socket peerAddr
snocket socket
socket
              )
              m (Async m ()) -> m Void -> m Void
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (forall a. m a -> m a) -> Accept m socket peerAddr -> m Void
go m y -> m y
forall a. m a -> m a
unmask Accept m socket peerAddr
acceptNext


isECONNABORTED :: IOError -> Bool
#if defined(mingw32_HOST_OS)
-- On Windows the network package classifies all errors as OtherError. This
-- forced us to match on the error string. The text string comes from the
-- network package's winSockErr.c, and if it ever changes we must update our
-- text string too.
isECONNABORTED (IOError _ _ _ "Software caused connection abort (WSAECONNABORTED)" _ _) = True
isECONNABORTED _ = False
#else
isECONNABORTED :: IOError -> Bool
isECONNABORTED (IOError Maybe Handle
_ IOErrorType
_ String
_ String
_ (Just CInt
cerrno) Maybe String
_) = Errno
eCONNABORTED Errno -> Errno -> Bool
forall a. Eq a => a -> a -> Bool
== CInt -> Errno
Errno CInt
cerrno
#if defined(darwin_HOST_OS)
-- There is a bug in accept for IPv6 sockets. Instead of returning -1 and
-- setting errno to ECONNABORTED an invalid (>= 0) file descriptor is returned,
-- with the client address left unchanged. The uninitialized client address
-- causes the network package to throw the user error below.
isECONNABORTED (IOError _ UserError _ "Network.Socket.Types.peekSockAddr: address family '0' not supported." _ _) = True
#endif
isECONNABORTED IOError
_ = Bool
False
#endif

--
-- Trace
--

data Trace peerAddr
    = TrAcceptConnection            (ConnectionId peerAddr)
    | TrAcceptError                 SomeException
    | TrAcceptPolicyTrace           AcceptConnectionsPolicyTrace
    | TrServerStarted               [peerAddr]
    | TrServerStopped
    | TrServerError                 SomeException
    -- ^ similar to 'TrAcceptConnection' but it is logged once the connection is
    -- handed to inbound connection manager, e.g. after handshake negotiation.
  deriving Int -> Trace peerAddr -> String -> String
[Trace peerAddr] -> String -> String
Trace peerAddr -> String
(Int -> Trace peerAddr -> String -> String)
-> (Trace peerAddr -> String)
-> ([Trace peerAddr] -> String -> String)
-> Show (Trace peerAddr)
forall peerAddr.
Show peerAddr =>
Int -> Trace peerAddr -> String -> String
forall peerAddr.
Show peerAddr =>
[Trace peerAddr] -> String -> String
forall peerAddr. Show peerAddr => Trace peerAddr -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: forall peerAddr.
Show peerAddr =>
Int -> Trace peerAddr -> String -> String
showsPrec :: Int -> Trace peerAddr -> String -> String
$cshow :: forall peerAddr. Show peerAddr => Trace peerAddr -> String
show :: Trace peerAddr -> String
$cshowList :: forall peerAddr.
Show peerAddr =>
[Trace peerAddr] -> String -> String
showList :: [Trace peerAddr] -> String -> String
Show