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

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

-- | Server implementation based on 'ConnectionManager'
--
module Ouroboros.Network.Server2
  ( ServerArguments (..)
  , InboundGovernorObservableState (..)
  , newObservableStateVar
  , newObservableStateVarIO
  , newObservableStateVarFromSeed
    -- * Run server
  , run
    -- * Trace
  , ServerTrace (..)
  , AcceptConnectionsPolicyTrace (..)
  , RemoteSt (..)
  , RemoteTransition
  , RemoteTransitionTrace
    -- * ControlChannel
  , module ControlChannel
  ) where

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.List (intercalate)
import           Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NonEmpty
import           Data.Void (Void)
import           GHC.IO.Exception
#if !defined(mingw32_HOST_OS)
import           Foreign.C.Error
#endif

import           Ouroboros.Network.ConnectionHandler
import           Ouroboros.Network.ConnectionManager.Types
import           Ouroboros.Network.InboundGovernor
import           Ouroboros.Network.InboundGovernor.ControlChannel
import qualified Ouroboros.Network.InboundGovernor.ControlChannel as ControlChannel
import           Ouroboros.Network.Mux hiding (ControlMessage)
import           Ouroboros.Network.Server.RateLimiting
import           Ouroboros.Network.Snocket


--
-- Server API
--


-- | Server static configuration.
--
data ServerArguments (muxMode  :: MuxMode) socket peerAddr versionNumber bytes m a b =
    ServerArguments {
      ServerArguments muxMode socket peerAddr versionNumber bytes m a b
-> NonEmpty socket
serverSockets               :: NonEmpty socket,
      ServerArguments muxMode socket peerAddr versionNumber bytes m a b
-> Snocket m socket peerAddr
serverSnocket               :: Snocket m socket peerAddr,
      ServerArguments muxMode socket peerAddr versionNumber bytes m a b
-> Tracer m (ServerTrace peerAddr)
serverTracer                :: Tracer m (ServerTrace peerAddr),
      ServerArguments muxMode socket peerAddr versionNumber bytes m a b
-> Tracer m (RemoteTransitionTrace peerAddr)
serverTrTracer              :: Tracer m (RemoteTransitionTrace peerAddr),
      ServerArguments muxMode socket peerAddr versionNumber bytes m a b
-> Tracer m (InboundGovernorTrace peerAddr)
serverInboundGovernorTracer :: Tracer m (InboundGovernorTrace peerAddr),
      ServerArguments muxMode socket peerAddr versionNumber bytes m a b
-> AcceptedConnectionsLimit
serverConnectionLimits      :: AcceptedConnectionsLimit,
      ServerArguments muxMode socket peerAddr versionNumber bytes m a b
-> MuxConnectionManager
     muxMode socket peerAddr versionNumber bytes m a b
serverConnectionManager     :: MuxConnectionManager muxMode socket peerAddr
                                                        versionNumber bytes m a b,

      -- | Time for which all protocols need to be idle to trigger
      -- 'DemotedToCold' transition.
      --
      ServerArguments muxMode socket peerAddr versionNumber bytes m a b
-> DiffTime
serverInboundIdleTimeout    :: DiffTime,

      -- | 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.
      --
      ServerArguments muxMode socket peerAddr versionNumber bytes m a b
-> ServerControlChannel muxMode peerAddr bytes m a b
serverControlChannel        :: ServerControlChannel muxMode peerAddr bytes m a b,

      -- | Observable mutable state.
      --
      ServerArguments muxMode socket peerAddr versionNumber bytes m a b
-> StrictTVar m InboundGovernorObservableState
serverObservableStateVar    :: StrictTVar m InboundGovernorObservableState
    }


-- | 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/.
--
run :: forall muxMode socket peerAddr versionNumber m a b.
       ( MonadAsync    m
       , MonadCatch    m
       , MonadEvaluate m
       , MonadLabelledSTM  m
       , MonadMask     m
       , MonadThrow   (STM m)
       , MonadTime     m
       , MonadTimer    m
       , HasResponder muxMode ~ True
       , Ord      peerAddr
       , Show     peerAddr
       )
    => ServerArguments muxMode socket peerAddr versionNumber ByteString m a b
    -> m Void
run :: ServerArguments
  muxMode socket peerAddr versionNumber ByteString m a b
-> m Void
run ServerArguments {
      NonEmpty socket
serverSockets :: NonEmpty socket
serverSockets :: forall (muxMode :: MuxMode) socket peerAddr versionNumber bytes
       (m :: * -> *) a b.
ServerArguments muxMode socket peerAddr versionNumber bytes m a b
-> NonEmpty socket
serverSockets,
      Snocket m socket peerAddr
serverSnocket :: Snocket m socket peerAddr
serverSnocket :: forall (muxMode :: MuxMode) socket peerAddr versionNumber bytes
       (m :: * -> *) a b.
ServerArguments muxMode socket peerAddr versionNumber bytes m a b
-> Snocket m socket peerAddr
serverSnocket,
      Tracer m (RemoteTransitionTrace peerAddr)
serverTrTracer :: Tracer m (RemoteTransitionTrace peerAddr)
serverTrTracer :: forall (muxMode :: MuxMode) socket peerAddr versionNumber bytes
       (m :: * -> *) a b.
ServerArguments muxMode socket peerAddr versionNumber bytes m a b
-> Tracer m (RemoteTransitionTrace peerAddr)
serverTrTracer,
      serverTracer :: forall (muxMode :: MuxMode) socket peerAddr versionNumber bytes
       (m :: * -> *) a b.
ServerArguments muxMode socket peerAddr versionNumber bytes m a b
-> Tracer m (ServerTrace peerAddr)
serverTracer = Tracer m (ServerTrace peerAddr)
tracer,
      serverInboundGovernorTracer :: forall (muxMode :: MuxMode) socket peerAddr versionNumber bytes
       (m :: * -> *) a b.
ServerArguments muxMode socket peerAddr versionNumber bytes m a b
-> Tracer m (InboundGovernorTrace peerAddr)
serverInboundGovernorTracer = Tracer m (InboundGovernorTrace peerAddr)
inboundGovernorTracer,
      serverConnectionLimits :: forall (muxMode :: MuxMode) socket peerAddr versionNumber bytes
       (m :: * -> *) a b.
ServerArguments muxMode socket peerAddr versionNumber bytes m a b
-> AcceptedConnectionsLimit
serverConnectionLimits =
        serverLimits :: AcceptedConnectionsLimit
serverLimits@AcceptedConnectionsLimit { acceptedConnectionsHardLimit :: AcceptedConnectionsLimit -> Word32
acceptedConnectionsHardLimit = Word32
hardLimit },
      DiffTime
serverInboundIdleTimeout :: DiffTime
serverInboundIdleTimeout :: forall (muxMode :: MuxMode) socket peerAddr versionNumber bytes
       (m :: * -> *) a b.
ServerArguments muxMode socket peerAddr versionNumber bytes m a b
-> DiffTime
serverInboundIdleTimeout,
      MuxConnectionManager
  muxMode socket peerAddr versionNumber ByteString m a b
serverConnectionManager :: MuxConnectionManager
  muxMode socket peerAddr versionNumber ByteString m a b
serverConnectionManager :: forall (muxMode :: MuxMode) socket peerAddr versionNumber bytes
       (m :: * -> *) a b.
ServerArguments muxMode socket peerAddr versionNumber bytes m a b
-> MuxConnectionManager
     muxMode socket peerAddr versionNumber bytes m a b
serverConnectionManager,
      ServerControlChannel muxMode peerAddr ByteString m a b
serverControlChannel :: ServerControlChannel muxMode peerAddr ByteString m a b
serverControlChannel :: forall (muxMode :: MuxMode) socket peerAddr versionNumber bytes
       (m :: * -> *) a b.
ServerArguments muxMode socket peerAddr versionNumber bytes m a b
-> ServerControlChannel muxMode peerAddr bytes m a b
serverControlChannel,
      StrictTVar m InboundGovernorObservableState
serverObservableStateVar :: StrictTVar m InboundGovernorObservableState
serverObservableStateVar :: forall (muxMode :: MuxMode) socket peerAddr versionNumber bytes
       (m :: * -> *) a b.
ServerArguments muxMode socket peerAddr versionNumber bytes m a b
-> StrictTVar m InboundGovernorObservableState
serverObservableStateVar
    } = do
      let sockets :: [socket]
sockets = NonEmpty socket -> [socket]
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty socket
serverSockets
      [peerAddr]
localAddresses <- (socket -> m peerAddr) -> [socket] -> m [peerAddr]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t 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
serverSnocket) [socket]
sockets
      StrictTVar m InboundGovernorObservableState -> String -> m ()
forall (m :: * -> *) a.
MonadLabelledSTM m =>
StrictTVar m a -> String -> m ()
labelTVarIO StrictTVar m InboundGovernorObservableState
serverObservableStateVar
                  (  String
"server-observable-state-"
                  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"-" (peerAddr -> String
forall a. Show a => a -> String
show (peerAddr -> String) -> [peerAddr] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [peerAddr]
localAddresses)
                  )
      Tracer m (ServerTrace peerAddr) -> ServerTrace peerAddr -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (ServerTrace peerAddr)
tracer ([peerAddr] -> ServerTrace peerAddr
forall peerAddr. [peerAddr] -> ServerTrace peerAddr
TrServerStarted [peerAddr]
localAddresses)
      let threads :: [m Void]
threads = (do String -> m ()
forall (m :: * -> *). MonadThread m => String -> m ()
labelThisThread (  String
"inbound-governor-"
                                        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"-" (peerAddr -> String
forall a. Show a => a -> String
show (peerAddr -> String) -> [peerAddr] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [peerAddr]
localAddresses)
                                        )
                        Tracer m (RemoteTransitionTrace peerAddr)
-> Tracer m (InboundGovernorTrace peerAddr)
-> ServerControlChannel muxMode peerAddr ByteString m a b
-> DiffTime
-> MuxConnectionManager
     muxMode socket peerAddr versionNumber ByteString m a b
-> StrictTVar m InboundGovernorObservableState
-> m Void
forall (muxMode :: MuxMode) socket peerAddr versionNumber
       (m :: * -> *) a b.
(MonadAsync m, MonadCatch m, MonadEvaluate m, MonadThrow m,
 MonadThrow (STM m), MonadTime m, MonadTimer m, MonadMask m,
 Ord peerAddr, HasResponder muxMode ~ 'True) =>
Tracer m (RemoteTransitionTrace peerAddr)
-> Tracer m (InboundGovernorTrace peerAddr)
-> ServerControlChannel muxMode peerAddr ByteString m a b
-> DiffTime
-> MuxConnectionManager
     muxMode socket peerAddr versionNumber ByteString m a b
-> StrictTVar m InboundGovernorObservableState
-> m Void
inboundGovernor Tracer m (RemoteTransitionTrace peerAddr)
serverTrTracer
                                        Tracer m (InboundGovernorTrace peerAddr)
inboundGovernorTracer
                                        ServerControlChannel muxMode peerAddr ByteString m a b
serverControlChannel
                                        DiffTime
serverInboundIdleTimeout
                                        MuxConnectionManager
  muxMode socket peerAddr versionNumber ByteString m a b
serverConnectionManager
                                        StrictTVar m InboundGovernorObservableState
serverObservableStateVar)
                    m Void -> [m Void] -> [m Void]
forall a. a -> [a] -> [a]
: [ (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
serverSnocket socket
socket m (Accept m socket peerAddr)
-> (Accept m socket peerAddr -> m Void) -> m Void
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 (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
serverSnocket socket
socket
                      | (peerAddr
localAddress, socket
socket) <- [peerAddr]
localAddresses [peerAddr] -> [socket] -> [(peerAddr, socket)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [socket]
sockets
                      ]

      [m Void] -> m Void
forall x. [m x] -> m x
raceAll [m Void]
threads
        m Void -> m () -> m Void
forall (m :: * -> *) a b. MonadThrow m => m a -> m b -> m a
`finally`
          Tracer m (ServerTrace peerAddr) -> ServerTrace peerAddr -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (ServerTrace peerAddr)
tracer ServerTrace peerAddr
forall peerAddr. ServerTrace peerAddr
TrServerStopped
        m Void -> (SomeException -> m Void) -> m Void
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 (f :: * -> *) a. Applicative f => a -> f a
pure ()
              Maybe AsyncCancelled
Nothing                    -> Tracer m (ServerTrace peerAddr) -> ServerTrace peerAddr -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (ServerTrace peerAddr)
tracer (SomeException -> ServerTrace peerAddr
forall peerAddr. SomeException -> ServerTrace peerAddr
TrServerError SomeException
e)
            SomeException -> m Void
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO SomeException
e
  where

    iseCONNABORTED :: IOError -> Bool
#if defined(mingw32_HOST_OS)
    -- On Windows the network packet classifies all errors
    -- as OtherError. This means that we're forced 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 Maybe Handle
_ IOErrorType
UserError String
_ String
"Network.Socket.Types.peekSockAddr: address family '0' not supported." Maybe CInt
_ Maybe String
_) = Bool
True
#endif
    iseCONNABORTED IOError
_ = Bool
False
#endif

    raceAll :: [m x] -> m x
    raceAll :: [m x] -> m x
raceAll []       = String -> m x
forall a. HasCallStack => String -> a
error String
"raceAll: invariant violation"
    raceAll [m x
t]      = m x
t
    raceAll (m x
t : [m x]
ts) = (x -> x) -> (x -> x) -> Either x x -> x
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either x -> x
forall a. a -> a
id x -> x
forall a. a -> a
id (Either x x -> x) -> m (Either x x) -> m x
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m x -> m x -> m (Either x x)
forall (m :: * -> *) a b.
MonadAsync m =>
m a -> m b -> m (Either a b)
race m x
t ([m x] -> m x
forall x. [m x] -> m x
raceAll [m x]
ts)

    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 (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 forall a. m a -> m a
unmask Accept m socket peerAddr
acceptOne0
        m Void -> (SomeException -> m Void) -> m Void
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \ SomeException
e -> Tracer m (ServerTrace peerAddr) -> ServerTrace peerAddr -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (ServerTrace peerAddr)
tracer (SomeException -> ServerTrace peerAddr
forall peerAddr. SomeException -> ServerTrace peerAddr
TrServerError SomeException
e)
                    m () -> m Void -> m Void
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SomeException -> m Void
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 x. m x -> m x)
           -> 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
          (Accepted socket peerAddr, Accept m socket peerAddr)
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, MonadTime m) =>
Tracer m AcceptConnectionsPolicyTrace
-> STM m Int -> AcceptedConnectionsLimit -> m ()
runConnectionRateLimits
              (AcceptConnectionsPolicyTrace -> ServerTrace peerAddr
forall peerAddr.
AcceptConnectionsPolicyTrace -> ServerTrace peerAddr
TrAcceptPolicyTrace (AcceptConnectionsPolicyTrace -> ServerTrace peerAddr)
-> Tracer m (ServerTrace peerAddr)
-> Tracer m AcceptConnectionsPolicyTrace
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
`contramap` Tracer m (ServerTrace peerAddr)
tracer)
              (MuxConnectionManager
  muxMode socket peerAddr versionNumber ByteString m a b
-> STM m Int
forall (muxMode :: MuxMode) socket peerAddr handle handleError
       (m :: * -> *).
(HasResponder muxMode ~ 'True) =>
ConnectionManager muxMode socket peerAddr handle handleError m
-> STM m Int
numberOfConnections MuxConnectionManager
  muxMode socket peerAddr versionNumber ByteString m a b
serverConnectionManager)
              AcceptedConnectionsLimit
serverLimits
            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 (Accepted socket peerAddr, Accept m socket peerAddr)
result of
            (AcceptFailure SomeException
err, Accept m socket peerAddr
acceptNext) -> do
              Tracer m (ServerTrace peerAddr) -> ServerTrace peerAddr -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (ServerTrace peerAddr)
tracer (SomeException -> ServerTrace peerAddr
forall peerAddr. SomeException -> ServerTrace 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 ->
                   if IOError -> Bool
iseCONNABORTED IOError
ioErr
                      then DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
0.5 m () -> m Void -> m Void
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 forall a. m a -> m a
unmask Accept m socket peerAddr
acceptNext
                      else IOError -> m Void
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO IOError
ioErr
                 Maybe IOError
Nothing -> SomeException -> m Void
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO SomeException
err

            (Accepted socket
socket peerAddr
peerAddr, Accept m socket peerAddr
acceptNext) ->
              (do
                  Tracer m (ServerTrace peerAddr) -> ServerTrace peerAddr -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (ServerTrace peerAddr)
tracer (peerAddr -> ServerTrace peerAddr
forall peerAddr. peerAddr -> ServerTrace peerAddr
TrAcceptConnection peerAddr
peerAddr)
                  m () -> m (Async m ())
forall (m :: * -> *) a. MonadAsync m => m a -> m (Async m a)
async (m () -> m (Async m ())) -> m () -> m (Async m ())
forall a b. (a -> b) -> a -> b
$
                    do Connected
  peerAddr
  (Handle muxMode peerAddr ByteString m a b)
  (HandleError muxMode versionNumber)
a <-
                         m (Connected
     peerAddr
     (Handle muxMode peerAddr ByteString m a b)
     (HandleError muxMode versionNumber))
-> m (Connected
        peerAddr
        (Handle muxMode peerAddr ByteString m a b)
        (HandleError muxMode versionNumber))
forall a. m a -> m a
unmask
                           (MuxConnectionManager
  muxMode socket peerAddr versionNumber ByteString m a b
-> IncludeInboundConnection
     socket
     peerAddr
     (Handle muxMode peerAddr ByteString m a b)
     (HandleError muxMode versionNumber)
     m
forall (muxMode :: MuxMode) socket peerAddr handle handleError
       (m :: * -> *).
(HasResponder muxMode ~ 'True) =>
ConnectionManager muxMode socket peerAddr handle handleError m
-> IncludeInboundConnection socket peerAddr handle handleError m
includeInboundConnection
                             MuxConnectionManager
  muxMode socket peerAddr versionNumber ByteString m a b
serverConnectionManager
                             Word32
hardLimit socket
socket peerAddr
peerAddr)
                       case Connected
  peerAddr
  (Handle muxMode peerAddr ByteString m a b)
  (HandleError muxMode versionNumber)
a of
                         Connected {}    -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                         Disconnected {} -> do
                           Snocket m socket peerAddr -> socket -> m ()
forall (m :: * -> *) fd addr. Snocket m fd addr -> fd -> m ()
close Snocket m socket peerAddr
serverSnocket socket
socket
                           () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                    m () -> m () -> m ()
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
serverSnocket socket
socket
              m (Async m ()) -> m () -> m (Async m ())
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
serverSnocket socket
socket
              )
              m (Async m ()) -> m Void -> m Void
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 forall a. m a -> m a
unmask Accept m socket peerAddr
acceptNext

--
-- Trace
--

data ServerTrace peerAddr
    = TrAcceptConnection            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 -> ServerTrace peerAddr -> String -> String
[ServerTrace peerAddr] -> String -> String
ServerTrace peerAddr -> String
(Int -> ServerTrace peerAddr -> String -> String)
-> (ServerTrace peerAddr -> String)
-> ([ServerTrace peerAddr] -> String -> String)
-> Show (ServerTrace peerAddr)
forall peerAddr.
Show peerAddr =>
Int -> ServerTrace peerAddr -> String -> String
forall peerAddr.
Show peerAddr =>
[ServerTrace peerAddr] -> String -> String
forall peerAddr. Show peerAddr => ServerTrace peerAddr -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [ServerTrace peerAddr] -> String -> String
$cshowList :: forall peerAddr.
Show peerAddr =>
[ServerTrace peerAddr] -> String -> String
show :: ServerTrace peerAddr -> String
$cshow :: forall peerAddr. Show peerAddr => ServerTrace peerAddr -> String
showsPrec :: Int -> ServerTrace peerAddr -> String -> String
$cshowsPrec :: forall peerAddr.
Show peerAddr =>
Int -> ServerTrace peerAddr -> String -> String
Show