{-# LANGUAGE BlockArguments      #-}
{-# LANGUAGE CPP                 #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE KindSignatures      #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications    #-}
{-# 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.Server
  ( 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 (when)
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.Monad.Fix (MonadFix)

import Control.Tracer (Tracer, contramap, traceWith)

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

import Ouroboros.Network.ConnectionId (ConnectionId (..))
import Ouroboros.Network.ConnectionManager.Types
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 socket peerAddr initiatorCtx responderCtx handle handlerTrace handleError versionNumber versionData bytes m a b x =
    Arguments {
      forall (muxMode :: Mode) socket peerAddr initiatorCtx responderCtx
       handle handlerTrace handleError versionNumber versionData bytes
       (m :: * -> *) a b x.
Arguments
  muxMode
  socket
  peerAddr
  initiatorCtx
  responderCtx
  handle
  handlerTrace
  handleError
  versionNumber
  versionData
  bytes
  m
  a
  b
  x
-> NonEmpty socket
sockets               :: NonEmpty socket,
      forall (muxMode :: Mode) socket peerAddr initiatorCtx responderCtx
       handle handlerTrace handleError versionNumber versionData bytes
       (m :: * -> *) a b x.
Arguments
  muxMode
  socket
  peerAddr
  initiatorCtx
  responderCtx
  handle
  handlerTrace
  handleError
  versionNumber
  versionData
  bytes
  m
  a
  b
  x
-> Snocket m socket peerAddr
snocket               :: Snocket m socket peerAddr,
      forall (muxMode :: Mode) socket peerAddr initiatorCtx responderCtx
       handle handlerTrace handleError versionNumber versionData bytes
       (m :: * -> *) a b x.
Arguments
  muxMode
  socket
  peerAddr
  initiatorCtx
  responderCtx
  handle
  handlerTrace
  handleError
  versionNumber
  versionData
  bytes
  m
  a
  b
  x
-> Tracer m (Trace peerAddr)
tracer                :: Tracer m (Trace peerAddr),
      forall (muxMode :: Mode) socket peerAddr initiatorCtx responderCtx
       handle handlerTrace handleError versionNumber versionData bytes
       (m :: * -> *) a b x.
Arguments
  muxMode
  socket
  peerAddr
  initiatorCtx
  responderCtx
  handle
  handlerTrace
  handleError
  versionNumber
  versionData
  bytes
  m
  a
  b
  x
-> AcceptedConnectionsLimit
connectionLimits      :: AcceptedConnectionsLimit,
      forall (muxMode :: Mode) socket peerAddr initiatorCtx responderCtx
       handle handlerTrace handleError versionNumber versionData bytes
       (m :: * -> *) a b x.
Arguments
  muxMode
  socket
  peerAddr
  initiatorCtx
  responderCtx
  handle
  handlerTrace
  handleError
  versionNumber
  versionData
  bytes
  m
  a
  b
  x
-> Arguments
     muxMode
     handlerTrace
     socket
     peerAddr
     initiatorCtx
     responderCtx
     handle
     handleError
     versionNumber
     versionData
     bytes
     m
     a
     b
     x
inboundGovernorArgs   :: InboundGovernor.Arguments muxMode handlerTrace socket peerAddr initiatorCtx responderCtx handle handleError versionNumber versionData bytes m a b x
    }

-- | 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 peerAddr initiatorCtx responderCtx handle handlerTrace handleError versionNumber versionData bytes 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
       , MonadTraceSTM m
       , MonadFork m
       , MonadFix m
       )
    => Arguments muxMode socket peerAddr initiatorCtx responderCtx handle handlerTrace
                 handleError versionNumber versionData bytes m a b x
    -- ^ record which holds all server arguments
    -> (   Async m Void
        -> m (InboundGovernor.PublicState peerAddr versionData)
        -> ConnectionManager
              muxMode socket peerAddr handle handleError m
        -> 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 peerAddr initiatorCtx responderCtx
       handle handlerTrace handleError versionNumber versionData bytes
       (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,
 MonadTraceSTM m, MonadFork m, MonadFix m) =>
Arguments
  muxMode
  socket
  peerAddr
  initiatorCtx
  responderCtx
  handle
  handlerTrace
  handleError
  versionNumber
  versionData
  bytes
  m
  a
  b
  x
-> (Async m Void
    -> m (PublicState peerAddr versionData)
    -> ConnectionManager muxMode socket peerAddr handle handleError m
    -> m x)
-> m x
with Arguments {
      sockets :: forall (muxMode :: Mode) socket peerAddr initiatorCtx responderCtx
       handle handlerTrace handleError versionNumber versionData bytes
       (m :: * -> *) a b x.
Arguments
  muxMode
  socket
  peerAddr
  initiatorCtx
  responderCtx
  handle
  handlerTrace
  handleError
  versionNumber
  versionData
  bytes
  m
  a
  b
  x
-> NonEmpty socket
sockets = NonEmpty socket
socks,
      Snocket m socket peerAddr
snocket :: forall (muxMode :: Mode) socket peerAddr initiatorCtx responderCtx
       handle handlerTrace handleError versionNumber versionData bytes
       (m :: * -> *) a b x.
Arguments
  muxMode
  socket
  peerAddr
  initiatorCtx
  responderCtx
  handle
  handlerTrace
  handleError
  versionNumber
  versionData
  bytes
  m
  a
  b
  x
-> Snocket m socket peerAddr
snocket :: Snocket m socket peerAddr
snocket,
      Tracer m (Trace peerAddr)
tracer :: forall (muxMode :: Mode) socket peerAddr initiatorCtx responderCtx
       handle handlerTrace handleError versionNumber versionData bytes
       (m :: * -> *) a b x.
Arguments
  muxMode
  socket
  peerAddr
  initiatorCtx
  responderCtx
  handle
  handlerTrace
  handleError
  versionNumber
  versionData
  bytes
  m
  a
  b
  x
-> Tracer m (Trace peerAddr)
tracer :: Tracer m (Trace peerAddr)
tracer,
      connectionLimits :: forall (muxMode :: Mode) socket peerAddr initiatorCtx responderCtx
       handle handlerTrace handleError versionNumber versionData bytes
       (m :: * -> *) a b x.
Arguments
  muxMode
  socket
  peerAddr
  initiatorCtx
  responderCtx
  handle
  handlerTrace
  handleError
  versionNumber
  versionData
  bytes
  m
  a
  b
  x
-> AcceptedConnectionsLimit
connectionLimits =
        limits :: AcceptedConnectionsLimit
limits@AcceptedConnectionsLimit { acceptedConnectionsHardLimit :: AcceptedConnectionsLimit -> Word32
acceptedConnectionsHardLimit = Word32
hardLimit },
      Arguments
  muxMode
  handlerTrace
  socket
  peerAddr
  initiatorCtx
  responderCtx
  handle
  handleError
  versionNumber
  versionData
  bytes
  m
  a
  b
  x
inboundGovernorArgs :: forall (muxMode :: Mode) socket peerAddr initiatorCtx responderCtx
       handle handlerTrace handleError versionNumber versionData bytes
       (m :: * -> *) a b x.
Arguments
  muxMode
  socket
  peerAddr
  initiatorCtx
  responderCtx
  handle
  handlerTrace
  handleError
  versionNumber
  versionData
  bytes
  m
  a
  b
  x
-> Arguments
     muxMode
     handlerTrace
     socket
     peerAddr
     initiatorCtx
     responderCtx
     handle
     handleError
     versionNumber
     versionData
     bytes
     m
     a
     b
     x
inboundGovernorArgs :: Arguments
  muxMode
  handlerTrace
  socket
  peerAddr
  initiatorCtx
  responderCtx
  handle
  handleError
  versionNumber
  versionData
  bytes
  m
  a
  b
  x
inboundGovernorArgs
    }
    Async m Void
-> m (PublicState peerAddr versionData)
-> ConnectionManager muxMode socket peerAddr handle handleError m
-> 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
      InboundGovernor.with inboundGovernorArgs
        \Async m Void
inboundGovernorThread m (PublicState peerAddr versionData)
readPublicInboundState ConnectionManager muxMode socket peerAddr handle handleError m
connectionManager ->
          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 do
            String -> m ()
forall (m :: * -> *). MonadThread m => String -> m ()
labelThisThread String
"Server2 (ouroboros-network-framework)"
            Async m Void
-> m (PublicState peerAddr versionData)
-> ConnectionManager muxMode socket peerAddr handle handleError m
-> m x
k Async m Void
inboundGovernorThread m (PublicState peerAddr versionData)
readPublicInboundState ConnectionManager muxMode socket peerAddr handle handleError m
connectionManager
          \Async m x
actionThread -> do
            Tracer m (Trace peerAddr) -> Trace peerAddr -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (Trace peerAddr)
tracer ([peerAddr] -> Trace peerAddr
forall peerAddr. [peerAddr] -> Trace peerAddr
TrServerStarted [peerAddr]
localAddresses)
            let acceptLoops :: [m Void]
                acceptLoops :: [m Void]
acceptLoops =
                            [ (do
                                  String -> m ()
forall (m :: * -> *). MonadThread m => String -> m ()
labelThisThread (String
"accept " String -> String -> String
forall a. [a] -> [a] -> [a]
++ peerAddr -> String
forall a. Show a => a -> String
show peerAddr
localAddress)
                                  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
-> ConnectionManager muxMode socket peerAddr handle handleError m
-> Accept m socket peerAddr
-> m Void
acceptLoop peerAddr
localAddress ConnectionManager muxMode socket peerAddr handle handleError m
connectionManager)
                                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`
            let waiter :: m x
waiter = 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
<$> (do
                                    String -> m ()
forall (m :: * -> *). MonadThread m => String -> m ()
labelThisThread String
"racing-action-inbound-governor"
                                    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)

            (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
waiter 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` (String -> m ()
forall (m :: * -> *). MonadThread m => String -> m ()
labelThisThread String
"racing-accept-loops" 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
>> [m Void] -> m Void
forall {m :: * -> *} {a}. MonadAsync m => [m a] -> m a
raceAll [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
                  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe SomeAsyncException -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe SomeAsyncException -> Bool)
-> Maybe SomeAsyncException -> Bool
forall a b. (a -> b) -> a -> b
$ forall e. Exception e => SomeException -> Maybe e
fromException @SomeAsyncException SomeException
e) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
                    Tracer m (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

    raceAll :: [m a] -> m a
raceAll [m a]
asyncs = [m a] -> ([Async m a] -> m a) -> m a
forall {m :: * -> *} {a} {b}.
MonadAsync m =>
[m a] -> ([Async m a] -> m b) -> m b
withAsyncAll [m a]
asyncs (((Async m a, a) -> a) -> m (Async m a, a) -> m a
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Async m a, a) -> a
forall a b. (a, b) -> b
snd (m (Async m a, a) -> m a)
-> ([Async m a] -> m (Async m a, a)) -> [Async m a] -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Async m a] -> m (Async m a, a)
forall a. [Async m a] -> m (Async m a, a)
forall (m :: * -> *) a.
MonadAsync m =>
[Async m a] -> m (Async m a, a)
waitAny)

    withAsyncAll :: [m a] -> ([Async m a] -> m b) -> m b
withAsyncAll [m a]
xs0 [Async m a] -> m b
action = [Async m a] -> [m a] -> m b
go [] [m a]
xs0
      where
        go :: [Async m a] -> [m a] -> m b
go [Async m a]
as []     = [Async m a] -> m b
action ([Async m a] -> [Async m a]
forall a. [a] -> [a]
reverse [Async m a]
as)
        go [Async m a]
as (m a
x:[m a]
xs) = m a -> (Async m a -> m b) -> m b
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 m a
x (\Async m a
a -> [Async m a] -> [m a] -> m b
go (Async m a
aAsync m a -> [Async m a] -> [Async m a]
forall a. a -> [a] -> [a]
:[Async m a]
as) [m a]
xs)

    acceptLoop :: peerAddr
               -> ConnectionManager muxMode socket peerAddr handle handleError m
               -> Accept m socket peerAddr
               -> m Void
    acceptLoop :: peerAddr
-> ConnectionManager muxMode socket peerAddr handle handleError m
-> Accept m socket peerAddr
-> m Void
acceptLoop peerAddr
localAddress ConnectionManager muxMode socket peerAddr handle handleError m
connectionManager 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
      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)
              (ConnectionManager muxMode socket peerAddr handle handleError m
-> 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 ConnectionManager muxMode socket peerAddr handle handleError m
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