{-# LANGUAGE DerivingStrategies  #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE FlexibleInstances   #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE KindSignatures      #-}
{-# LANGUAGE MultiWayIf          #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | This module provides simulation environment and a snocket implementation
-- suitable for 'IOSim'.
--
-- Though this module is designed for simulation \/ testing, it lives in the
-- library, since it is needed in `ouroboros-network-framework:test` and
-- `ouroboros-network:test' components.
--
-- TODO: Create a 'snocket' package, in order to avoid having to have
-- ouroboros-network-testing as a dependency for this cabal library.
module Simulation.Network.Snocket
  ( -- * Simulated Snocket
    withSnocket
  , ObservableNetworkState (..)
  , ResourceException (..)
  , SDUSize
  , Script (..)
  , Size
  , SnocketTrace (..)
  , SockType (..)
  , OpenType (..)
  , normaliseId
  , BearerInfo (..)
  , IOErrType (..)
  , SuccessOrFailure (..)
  , TimeoutDetail (..)
  , noAttenuation
  , FD
  , GlobalAddressScheme (..)
  , AddressType (..)
  ) where

import           Prelude hiding (read)

import           Control.Monad (when)
import qualified Control.Monad.Class.MonadSTM as LazySTM
import           Control.Monad.Class.MonadSTM.Strict
import           Control.Monad.Class.MonadThrow
import           Control.Monad.Class.MonadTime
import           Control.Monad.Class.MonadTimer
import           Control.Tracer (Tracer, contramap, contramapM, traceWith)

import           GHC.IO.Exception

import           Data.Bifoldable (bitraverse_)
import           Data.Foldable (traverse_)
import           Data.Functor (($>))
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import           Data.Typeable (Typeable)
import           Foreign.C.Error
import           Numeric.Natural (Natural)
import           Text.Printf (printf)

import           Data.Monoid.Synchronisation (FirstToFinish (..))
import           Data.Wedge

import           Network.Mux.Bearer.AttenuatedChannel
import           Network.Mux.Trace (MuxTrace)
import           Network.Mux.Types (MuxBearer, SDUSize (..))

import           Ouroboros.Network.ConnectionId
import           Ouroboros.Network.ConnectionManager.Types (AddressType (..))
import           Ouroboros.Network.Snocket

import           Ouroboros.Network.Testing.Data.Script (Script (..),
                     stepScriptSTM)

data Connection m addr = Connection
    { -- | Attenuated channels of a connection.
      --
      Connection m addr -> AttenuatedChannel m
connChannelLocal  :: !(AttenuatedChannel m)
    , Connection m addr -> AttenuatedChannel m
connChannelRemote :: !(AttenuatedChannel m)

      -- | SDU size of a connection.
      --
    , Connection m addr -> SDUSize
connSDUSize       :: !SDUSize

      -- | Opening state of a connection.  This is used to detect simultaneous
      -- open.
      --
    , Connection m addr -> ConnectionState
connState         :: !ConnectionState

      -- | Provider of this Connection, so one can know its origin and decide
      -- accordingly when accepting/connecting a connection.
    , Connection m addr -> addr
connProvider      :: !addr
    }


-- | Connection state as seen by the network environment.  We borrow TCP state
-- names, but be aware that these states, unlike in TCP, are not local to the
-- service point.
--
data ConnectionState
    -- | SYN_SENT connection state: after calling `connect` but before the
    -- other side accepted it: either as a simultaneous open or normal open.
    --
  = SYN_SENT

    -- | This corresponds to established state of a tcp connection.
    --
  | ESTABLISHED

    -- | Half opened connection.
    --
  | FIN
  deriving (ConnectionState -> ConnectionState -> Bool
(ConnectionState -> ConnectionState -> Bool)
-> (ConnectionState -> ConnectionState -> Bool)
-> Eq ConnectionState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ConnectionState -> ConnectionState -> Bool
$c/= :: ConnectionState -> ConnectionState -> Bool
== :: ConnectionState -> ConnectionState -> Bool
$c== :: ConnectionState -> ConnectionState -> Bool
Eq, Int -> ConnectionState -> ShowS
[ConnectionState] -> ShowS
ConnectionState -> String
(Int -> ConnectionState -> ShowS)
-> (ConnectionState -> String)
-> ([ConnectionState] -> ShowS)
-> Show ConnectionState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ConnectionState] -> ShowS
$cshowList :: [ConnectionState] -> ShowS
show :: ConnectionState -> String
$cshow :: ConnectionState -> String
showsPrec :: Int -> ConnectionState -> ShowS
$cshowsPrec :: Int -> ConnectionState -> ShowS
Show)


dualConnection :: Connection m addr -> Connection m addr
dualConnection :: Connection m addr -> Connection m addr
dualConnection conn :: Connection m addr
conn@Connection { AttenuatedChannel m
connChannelLocal :: AttenuatedChannel m
connChannelLocal :: forall (m :: * -> *) addr. Connection m addr -> AttenuatedChannel m
connChannelLocal, AttenuatedChannel m
connChannelRemote :: AttenuatedChannel m
connChannelRemote :: forall (m :: * -> *) addr. Connection m addr -> AttenuatedChannel m
connChannelRemote } =
    Connection m addr
conn { connChannelLocal :: AttenuatedChannel m
connChannelLocal  = AttenuatedChannel m
connChannelRemote
         , connChannelRemote :: AttenuatedChannel m
connChannelRemote = AttenuatedChannel m
connChannelLocal
         }


mkConnection :: ( MonadLabelledSTM   m
                , MonadTime          m
                , MonadTimer         m
                , MonadThrow         m
                , MonadThrow    (STM m)
                )
             => Tracer m (WithAddr (TestAddress addr)
                                   (SnocketTrace m (TestAddress addr)))
             -> BearerInfo
             -> ConnectionId (TestAddress addr)
             -> STM m (Connection m (TestAddress addr))
mkConnection :: Tracer
  m (WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr)))
-> BearerInfo
-> ConnectionId (TestAddress addr)
-> STM m (Connection m (TestAddress addr))
mkConnection Tracer
  m (WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr)))
tr BearerInfo
bearerInfo connId :: ConnectionId (TestAddress addr)
connId@ConnectionId { TestAddress addr
localAddress :: forall addr. ConnectionId addr -> addr
localAddress :: TestAddress addr
localAddress, TestAddress addr
remoteAddress :: forall addr. ConnectionId addr -> addr
remoteAddress :: TestAddress addr
remoteAddress } = do
    (AttenuatedChannel m
channelLocal, AttenuatedChannel m
channelRemote)  <-
      Tracer m AttenuatedChannelTrace
-> Tracer m AttenuatedChannelTrace
-> Attenuation
-> Attenuation
-> STM m (AttenuatedChannel m, AttenuatedChannel m)
forall (m :: * -> *).
(MonadLabelledSTM m, MonadTime m, MonadTimer m, MonadThrow m,
 MonadThrow (STM m)) =>
Tracer m AttenuatedChannelTrace
-> Tracer m AttenuatedChannelTrace
-> Attenuation
-> Attenuation
-> STM m (AttenuatedChannel m, AttenuatedChannel m)
newConnectedAttenuatedChannelPair
        ( ( Maybe (TestAddress addr)
-> Maybe (TestAddress addr)
-> SnocketTrace m (TestAddress addr)
-> WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr))
forall addr event.
Maybe addr -> Maybe addr -> event -> WithAddr addr event
WithAddr (TestAddress addr -> Maybe (TestAddress addr)
forall a. a -> Maybe a
Just TestAddress addr
localAddress) (TestAddress addr -> Maybe (TestAddress addr)
forall a. a -> Maybe a
Just TestAddress addr
remoteAddress)
          (SnocketTrace m (TestAddress addr)
 -> WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr)))
-> (AttenuatedChannelTrace -> SnocketTrace m (TestAddress addr))
-> AttenuatedChannelTrace
-> WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConnectionId (TestAddress addr)
-> AttenuatedChannelTrace -> SnocketTrace m (TestAddress addr)
forall (m :: * -> *) addr.
ConnectionId addr -> AttenuatedChannelTrace -> SnocketTrace m addr
STAttenuatedChannelTrace ConnectionId (TestAddress addr)
connId
          )
          (AttenuatedChannelTrace
 -> WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr)))
-> Tracer
     m (WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr)))
-> Tracer m AttenuatedChannelTrace
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
`contramap` Tracer
  m (WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr)))
tr)
        ( ( Maybe (TestAddress addr)
-> Maybe (TestAddress addr)
-> SnocketTrace m (TestAddress addr)
-> WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr))
forall addr event.
Maybe addr -> Maybe addr -> event -> WithAddr addr event
WithAddr (TestAddress addr -> Maybe (TestAddress addr)
forall a. a -> Maybe a
Just TestAddress addr
remoteAddress) (TestAddress addr -> Maybe (TestAddress addr)
forall a. a -> Maybe a
Just TestAddress addr
localAddress)
          (SnocketTrace m (TestAddress addr)
 -> WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr)))
-> (AttenuatedChannelTrace -> SnocketTrace m (TestAddress addr))
-> AttenuatedChannelTrace
-> WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConnectionId (TestAddress addr)
-> AttenuatedChannelTrace -> SnocketTrace m (TestAddress addr)
forall (m :: * -> *) addr.
ConnectionId addr -> AttenuatedChannelTrace -> SnocketTrace m addr
STAttenuatedChannelTrace ConnectionId :: forall addr. addr -> addr -> ConnectionId addr
ConnectionId
              { localAddress :: TestAddress addr
localAddress  = TestAddress addr
remoteAddress
              , remoteAddress :: TestAddress addr
remoteAddress = TestAddress addr
localAddress
              }
          )
         (AttenuatedChannelTrace
 -> WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr)))
-> Tracer
     m (WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr)))
-> Tracer m AttenuatedChannelTrace
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
`contramap` Tracer
  m (WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr)))
tr)
        Attenuation :: (Time -> Size -> (DiffTime, SuccessOrFailure))
-> Maybe Int -> Attenuation
Attenuation
          { aReadAttenuation :: Time -> Size -> (DiffTime, SuccessOrFailure)
aReadAttenuation  = BearerInfo -> Time -> Size -> (DiffTime, SuccessOrFailure)
biOutboundAttenuation  BearerInfo
bearerInfo
          , aWriteAttenuation :: Maybe Int
aWriteAttenuation = BearerInfo -> Maybe Int
biOutboundWriteFailure BearerInfo
bearerInfo
          }
        Attenuation :: (Time -> Size -> (DiffTime, SuccessOrFailure))
-> Maybe Int -> Attenuation
Attenuation
          { aReadAttenuation :: Time -> Size -> (DiffTime, SuccessOrFailure)
aReadAttenuation  = BearerInfo -> Time -> Size -> (DiffTime, SuccessOrFailure)
biInboundAttenuation  BearerInfo
bearerInfo
          , aWriteAttenuation :: Maybe Int
aWriteAttenuation = BearerInfo -> Maybe Int
biInboundWriteFailure BearerInfo
bearerInfo
          }
    Connection m (TestAddress addr)
-> STM m (Connection m (TestAddress addr))
forall (m :: * -> *) a. Monad m => a -> m a
return (Connection m (TestAddress addr)
 -> STM m (Connection m (TestAddress addr)))
-> Connection m (TestAddress addr)
-> STM m (Connection m (TestAddress addr))
forall a b. (a -> b) -> a -> b
$ AttenuatedChannel m
-> AttenuatedChannel m
-> SDUSize
-> ConnectionState
-> TestAddress addr
-> Connection m (TestAddress addr)
forall (m :: * -> *) addr.
AttenuatedChannel m
-> AttenuatedChannel m
-> SDUSize
-> ConnectionState
-> addr
-> Connection m addr
Connection AttenuatedChannel m
channelLocal
                        AttenuatedChannel m
channelRemote
                        (BearerInfo -> SDUSize
biSDUSize BearerInfo
bearerInfo)
                        ConnectionState
SYN_SENT
                        TestAddress addr
localAddress


-- | Connection id independent of who provisioned the connection. 'NormalisedId'
-- satisfies the invariant that for @NormalisedId {nidLow, nidHight}@ we have
-- @nidLow <= nidHigh@.
--
data NormalisedId addr = UnsafeNormalisedId
    { NormalisedId addr -> addr
nidLow  :: !addr
    , NormalisedId addr -> addr
nidHigh :: !addr
    }
  deriving (NormalisedId addr -> NormalisedId addr -> Bool
(NormalisedId addr -> NormalisedId addr -> Bool)
-> (NormalisedId addr -> NormalisedId addr -> Bool)
-> Eq (NormalisedId addr)
forall addr.
Eq addr =>
NormalisedId addr -> NormalisedId addr -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NormalisedId addr -> NormalisedId addr -> Bool
$c/= :: forall addr.
Eq addr =>
NormalisedId addr -> NormalisedId addr -> Bool
== :: NormalisedId addr -> NormalisedId addr -> Bool
$c== :: forall addr.
Eq addr =>
NormalisedId addr -> NormalisedId addr -> Bool
Eq, Eq (NormalisedId addr)
Eq (NormalisedId addr)
-> (NormalisedId addr -> NormalisedId addr -> Ordering)
-> (NormalisedId addr -> NormalisedId addr -> Bool)
-> (NormalisedId addr -> NormalisedId addr -> Bool)
-> (NormalisedId addr -> NormalisedId addr -> Bool)
-> (NormalisedId addr -> NormalisedId addr -> Bool)
-> (NormalisedId addr -> NormalisedId addr -> NormalisedId addr)
-> (NormalisedId addr -> NormalisedId addr -> NormalisedId addr)
-> Ord (NormalisedId addr)
NormalisedId addr -> NormalisedId addr -> Bool
NormalisedId addr -> NormalisedId addr -> Ordering
NormalisedId addr -> NormalisedId addr -> NormalisedId addr
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall addr. Ord addr => Eq (NormalisedId addr)
forall addr.
Ord addr =>
NormalisedId addr -> NormalisedId addr -> Bool
forall addr.
Ord addr =>
NormalisedId addr -> NormalisedId addr -> Ordering
forall addr.
Ord addr =>
NormalisedId addr -> NormalisedId addr -> NormalisedId addr
min :: NormalisedId addr -> NormalisedId addr -> NormalisedId addr
$cmin :: forall addr.
Ord addr =>
NormalisedId addr -> NormalisedId addr -> NormalisedId addr
max :: NormalisedId addr -> NormalisedId addr -> NormalisedId addr
$cmax :: forall addr.
Ord addr =>
NormalisedId addr -> NormalisedId addr -> NormalisedId addr
>= :: NormalisedId addr -> NormalisedId addr -> Bool
$c>= :: forall addr.
Ord addr =>
NormalisedId addr -> NormalisedId addr -> Bool
> :: NormalisedId addr -> NormalisedId addr -> Bool
$c> :: forall addr.
Ord addr =>
NormalisedId addr -> NormalisedId addr -> Bool
<= :: NormalisedId addr -> NormalisedId addr -> Bool
$c<= :: forall addr.
Ord addr =>
NormalisedId addr -> NormalisedId addr -> Bool
< :: NormalisedId addr -> NormalisedId addr -> Bool
$c< :: forall addr.
Ord addr =>
NormalisedId addr -> NormalisedId addr -> Bool
compare :: NormalisedId addr -> NormalisedId addr -> Ordering
$ccompare :: forall addr.
Ord addr =>
NormalisedId addr -> NormalisedId addr -> Ordering
$cp1Ord :: forall addr. Ord addr => Eq (NormalisedId addr)
Ord, Int -> NormalisedId addr -> ShowS
[NormalisedId addr] -> ShowS
NormalisedId addr -> String
(Int -> NormalisedId addr -> ShowS)
-> (NormalisedId addr -> String)
-> ([NormalisedId addr] -> ShowS)
-> Show (NormalisedId addr)
forall addr. Show addr => Int -> NormalisedId addr -> ShowS
forall addr. Show addr => [NormalisedId addr] -> ShowS
forall addr. Show addr => NormalisedId addr -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NormalisedId addr] -> ShowS
$cshowList :: forall addr. Show addr => [NormalisedId addr] -> ShowS
show :: NormalisedId addr -> String
$cshow :: forall addr. Show addr => NormalisedId addr -> String
showsPrec :: Int -> NormalisedId addr -> ShowS
$cshowsPrec :: forall addr. Show addr => Int -> NormalisedId addr -> ShowS
Show)

-- | Safe constructor of 'NormalisedId'
--
normaliseId :: Ord addr
            => ConnectionId addr -> NormalisedId addr
normaliseId :: ConnectionId addr -> NormalisedId addr
normaliseId
  ConnectionId {addr
localAddress :: addr
localAddress :: forall addr. ConnectionId addr -> addr
localAddress, addr
remoteAddress :: addr
remoteAddress :: forall addr. ConnectionId addr -> addr
remoteAddress}
    | addr
localAddress addr -> addr -> Bool
forall a. Ord a => a -> a -> Bool
<= addr
remoteAddress
    = addr -> addr -> NormalisedId addr
forall addr. addr -> addr -> NormalisedId addr
UnsafeNormalisedId addr
localAddress addr
remoteAddress
    | Bool
otherwise
    = addr -> addr -> NormalisedId addr
forall addr. addr -> addr -> NormalisedId addr
UnsafeNormalisedId addr
remoteAddress addr
localAddress


-- | Simulation network environment consumed by 'simSnocket'.
--
data NetworkState m addr = NetworkState {
      -- | All listening 'FD's.
      --
      NetworkState m addr -> StrictTVar m (Map addr (FD m addr))
nsListeningFDs      :: StrictTVar m (Map addr (FD m addr)),

      -- | Registry of active connections.
      --
      NetworkState m addr
-> StrictTVar m (Map (NormalisedId addr) (Connection m addr))
nsConnections       :: StrictTVar
                              m
                              (Map (NormalisedId addr) (Connection m addr)),

      -- | Get an unused ephemeral address.
      --
      NetworkState m addr -> AddressType -> STM m addr
nsNextEphemeralAddr :: AddressType -> STM m addr,

      NetworkState m addr -> BearerInfo
nsDefaultBearerInfo :: BearerInfo,

      -- | Get the BearerInfo Script for a given connection.
      --
      NetworkState m addr
-> Map (NormalisedId addr) (TVar m (Script BearerInfo))
nsAttenuationMap    :: Map (NormalisedId addr)
                                 (LazySTM.TVar m (Script BearerInfo))

    }

-- | Simulation accessible network environment consumed by 'simSnocket'.
--
newtype ObservableNetworkState addr = ObservableNetworkState {
      -- | Registry of active connections and respective provider
      --
      ObservableNetworkState addr -> Map (NormalisedId addr) addr
onsConnections :: Map (NormalisedId addr) addr
    }
    deriving Int -> ObservableNetworkState addr -> ShowS
[ObservableNetworkState addr] -> ShowS
ObservableNetworkState addr -> String
(Int -> ObservableNetworkState addr -> ShowS)
-> (ObservableNetworkState addr -> String)
-> ([ObservableNetworkState addr] -> ShowS)
-> Show (ObservableNetworkState addr)
forall addr.
Show addr =>
Int -> ObservableNetworkState addr -> ShowS
forall addr. Show addr => [ObservableNetworkState addr] -> ShowS
forall addr. Show addr => ObservableNetworkState addr -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ObservableNetworkState addr] -> ShowS
$cshowList :: forall addr. Show addr => [ObservableNetworkState addr] -> ShowS
show :: ObservableNetworkState addr -> String
$cshow :: forall addr. Show addr => ObservableNetworkState addr -> String
showsPrec :: Int -> ObservableNetworkState addr -> ShowS
$cshowsPrec :: forall addr.
Show addr =>
Int -> ObservableNetworkState addr -> ShowS
Show


-- | Error types.
--
data IOErrType = IOErrConnectionAborted
               | IOErrResourceExhausted
  deriving (IOErrType -> IOErrType -> Bool
(IOErrType -> IOErrType -> Bool)
-> (IOErrType -> IOErrType -> Bool) -> Eq IOErrType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: IOErrType -> IOErrType -> Bool
$c/= :: IOErrType -> IOErrType -> Bool
== :: IOErrType -> IOErrType -> Bool
$c== :: IOErrType -> IOErrType -> Bool
Eq, Int -> IOErrType -> ShowS
[IOErrType] -> ShowS
IOErrType -> String
(Int -> IOErrType -> ShowS)
-> (IOErrType -> String)
-> ([IOErrType] -> ShowS)
-> Show IOErrType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [IOErrType] -> ShowS
$cshowList :: [IOErrType] -> ShowS
show :: IOErrType -> String
$cshow :: IOErrType -> String
showsPrec :: Int -> IOErrType -> ShowS
$cshowsPrec :: Int -> IOErrType -> ShowS
Show)


-- | Each bearer info describes outbound and inbound side of a point to
-- point bearer.
--
data BearerInfo = BearerInfo
    {
      -- | How long it take to create a connection
      BearerInfo -> DiffTime
biConnectionDelay      :: !DiffTime

      -- | attenuation of inbound side of the bearer, i.e. attenuation used by
      -- bearers that were 'accept'ed.
    , BearerInfo -> Time -> Size -> (DiffTime, SuccessOrFailure)
biInboundAttenuation   ::  Time -> Size -> ( DiffTime,
                                                   SuccessOrFailure )

      -- | attenuation of outbound side of the bearer, i.e. the attenuation used
      -- by bearers that were created with 'connect' call.
      --
    , BearerInfo -> Time -> Size -> (DiffTime, SuccessOrFailure)
biOutboundAttenuation  ::  Time -> Size -> ( DiffTime,
                                                   SuccessOrFailure )

      -- | Maximum number of successful writes for an inbound bearer.
    , BearerInfo -> Maybe Int
biInboundWriteFailure  :: !(Maybe Int)

      -- | Maximum number of successful writes for an outbound bearer.
    , BearerInfo -> Maybe Int
biOutboundWriteFailure :: !(Maybe Int)

      -- | Time after which  accept will throw an exception.
      --
      -- Currently it only supports two kinds of exceptions, ones that are
      -- caught and rethrown by the server (ECONNABORTED), and an exception
      -- which would be caught, and delivered to the application via
      -- 'AcceptFailure'.
      --
    , BearerInfo -> Maybe (DiffTime, IOErrType)
biAcceptFailures       :: !(Maybe (DiffTime, IOErrType))

      -- | SDU size of the bearer; it will be shared between outbound and inbound
      -- sides.
      --
      -- Note: shrinking 'SDUSize' means make it larger, as this allows to send
      -- fewer chunks through the bearer.
      --
    , BearerInfo -> SDUSize
biSDUSize              :: !SDUSize
    }

instance Show BearerInfo where
    show :: BearerInfo -> String
show BearerInfo {DiffTime
biConnectionDelay :: DiffTime
biConnectionDelay :: BearerInfo -> DiffTime
biConnectionDelay, Maybe Int
biInboundWriteFailure :: Maybe Int
biInboundWriteFailure :: BearerInfo -> Maybe Int
biInboundWriteFailure, Maybe Int
biOutboundWriteFailure :: Maybe Int
biOutboundWriteFailure :: BearerInfo -> Maybe Int
biOutboundWriteFailure, SDUSize
biSDUSize :: SDUSize
biSDUSize :: BearerInfo -> SDUSize
biSDUSize} =
      [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"BearerInfo "
        , DiffTime -> String
forall a. Show a => a -> String
show DiffTime
biConnectionDelay
        , String
" ("
        , Maybe Int -> String
forall a. Show a => a -> String
show Maybe Int
biInboundWriteFailure
        , String
") ("
        , Maybe Int -> String
forall a. Show a => a -> String
show Maybe Int
biOutboundWriteFailure
        , String
") "
        , SDUSize -> String
forall a. Show a => a -> String
show SDUSize
biSDUSize
        ]


-- | 'BearerInfo' without attenuation and instantaneous connect delay.  It also
-- using the production value of 'SDUSize'.
--
noAttenuation :: BearerInfo
noAttenuation :: BearerInfo
noAttenuation = BearerInfo :: DiffTime
-> (Time -> Size -> (DiffTime, SuccessOrFailure))
-> (Time -> Size -> (DiffTime, SuccessOrFailure))
-> Maybe Int
-> Maybe Int
-> Maybe (DiffTime, IOErrType)
-> SDUSize
-> BearerInfo
BearerInfo { biConnectionDelay :: DiffTime
biConnectionDelay      = DiffTime
0
                           , biInboundAttenuation :: Time -> Size -> (DiffTime, SuccessOrFailure)
biInboundAttenuation   = \Time
_ Size
_ -> (DiffTime
0, SuccessOrFailure
Success)
                           , biOutboundAttenuation :: Time -> Size -> (DiffTime, SuccessOrFailure)
biOutboundAttenuation  = \Time
_ Size
_ -> (DiffTime
0, SuccessOrFailure
Success)
                           , biInboundWriteFailure :: Maybe Int
biInboundWriteFailure  = Maybe Int
forall a. Maybe a
Nothing
                           , biOutboundWriteFailure :: Maybe Int
biOutboundWriteFailure = Maybe Int
forall a. Maybe a
Nothing
                           , biAcceptFailures :: Maybe (DiffTime, IOErrType)
biAcceptFailures       = Maybe (DiffTime, IOErrType)
forall a. Maybe a
Nothing
                           , biSDUSize :: SDUSize
biSDUSize              = Word16 -> SDUSize
SDUSize Word16
12228
                           }


-- | Create a new network snocket based on a 'BearerInfo' script.
--
newNetworkState
    :: forall m peerAddr.
       ( MonadLabelledSTM m
       , GlobalAddressScheme peerAddr
       )
    => BearerInfo
    -> Map (NormalisedId (TestAddress peerAddr))
           (Script BearerInfo)
    -- ^ the largest ephemeral address
    -> m (NetworkState m (TestAddress peerAddr))
newNetworkState :: BearerInfo
-> Map (NormalisedId (TestAddress peerAddr)) (Script BearerInfo)
-> m (NetworkState m (TestAddress peerAddr))
newNetworkState BearerInfo
defaultBearerInfo Map (NormalisedId (TestAddress peerAddr)) (Script BearerInfo)
scriptMap = STM m (NetworkState m (TestAddress peerAddr))
-> m (NetworkState m (TestAddress peerAddr))
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (NetworkState m (TestAddress peerAddr))
 -> m (NetworkState m (TestAddress peerAddr)))
-> STM m (NetworkState m (TestAddress peerAddr))
-> m (NetworkState m (TestAddress peerAddr))
forall a b. (a -> b) -> a -> b
$ do
  (StrictTVar m Natural
v :: StrictTVar m Natural) <- Natural -> STM m (StrictTVar m Natural)
forall (m :: * -> *) a. MonadSTM m => a -> STM m (StrictTVar m a)
newTVar Natural
0
  let nextEphemeralAddr :: AddressType -> STM m (TestAddress peerAddr)
      nextEphemeralAddr :: AddressType -> STM m (TestAddress peerAddr)
nextEphemeralAddr AddressType
addrType = do
        -- TODO: we should use `(\s -> (succ s, s)` but p2p-master does not
        -- include PR #3172.
         Natural
a <- StrictTVar m Natural
-> (Natural -> (Natural, Natural)) -> STM m Natural
forall (m :: * -> *) s a.
MonadSTM m =>
StrictTVar m s -> (s -> (a, s)) -> STM m a
stateTVar StrictTVar m Natural
v (\Natural
s -> let s' :: Natural
s' = Natural -> Natural
forall a. Enum a => a -> a
succ Natural
s in (Natural
s', Natural
s'))
         TestAddress peerAddr -> STM m (TestAddress peerAddr)
forall (m :: * -> *) a. Monad m => a -> m a
return (AddressType -> Natural -> TestAddress peerAddr
forall addr.
GlobalAddressScheme addr =>
AddressType -> Natural -> TestAddress addr
ephemeralAddress AddressType
addrType Natural
a)

  Map
  (NormalisedId (TestAddress peerAddr)) (TVar m (Script BearerInfo))
scriptMapVars <- (Script BearerInfo -> STM m (TVar m (Script BearerInfo)))
-> Map (NormalisedId (TestAddress peerAddr)) (Script BearerInfo)
-> STM
     m
     (Map
        (NormalisedId (TestAddress peerAddr)) (TVar m (Script BearerInfo)))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Script BearerInfo -> STM m (TVar m (Script BearerInfo))
forall (m :: * -> *) a. MonadSTM m => a -> STM m (TVar m a)
LazySTM.newTVar Map (NormalisedId (TestAddress peerAddr)) (Script BearerInfo)
scriptMap
  NetworkState m (TestAddress peerAddr)
s <- StrictTVar
  m (Map (TestAddress peerAddr) (FD m (TestAddress peerAddr)))
-> StrictTVar
     m
     (Map
        (NormalisedId (TestAddress peerAddr))
        (Connection m (TestAddress peerAddr)))
-> (AddressType -> STM m (TestAddress peerAddr))
-> BearerInfo
-> Map
     (NormalisedId (TestAddress peerAddr)) (TVar m (Script BearerInfo))
-> NetworkState m (TestAddress peerAddr)
forall (m :: * -> *) addr.
StrictTVar m (Map addr (FD m addr))
-> StrictTVar m (Map (NormalisedId addr) (Connection m addr))
-> (AddressType -> STM m addr)
-> BearerInfo
-> Map (NormalisedId addr) (TVar m (Script BearerInfo))
-> NetworkState m addr
NetworkState
    -- nsListeningFDs
    (StrictTVar
   m (Map (TestAddress peerAddr) (FD m (TestAddress peerAddr)))
 -> StrictTVar
      m
      (Map
         (NormalisedId (TestAddress peerAddr))
         (Connection m (TestAddress peerAddr)))
 -> (AddressType -> STM m (TestAddress peerAddr))
 -> BearerInfo
 -> Map
      (NormalisedId (TestAddress peerAddr)) (TVar m (Script BearerInfo))
 -> NetworkState m (TestAddress peerAddr))
-> STM
     m
     (StrictTVar
        m (Map (TestAddress peerAddr) (FD m (TestAddress peerAddr))))
-> STM
     m
     (StrictTVar
        m
        (Map
           (NormalisedId (TestAddress peerAddr))
           (Connection m (TestAddress peerAddr)))
      -> (AddressType -> STM m (TestAddress peerAddr))
      -> BearerInfo
      -> Map
           (NormalisedId (TestAddress peerAddr)) (TVar m (Script BearerInfo))
      -> NetworkState m (TestAddress peerAddr))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map (TestAddress peerAddr) (FD m (TestAddress peerAddr))
-> STM
     m
     (StrictTVar
        m (Map (TestAddress peerAddr) (FD m (TestAddress peerAddr))))
forall (m :: * -> *) a. MonadSTM m => a -> STM m (StrictTVar m a)
newTVar Map (TestAddress peerAddr) (FD m (TestAddress peerAddr))
forall k a. Map k a
Map.empty
    -- nsConnections
    STM
  m
  (StrictTVar
     m
     (Map
        (NormalisedId (TestAddress peerAddr))
        (Connection m (TestAddress peerAddr)))
   -> (AddressType -> STM m (TestAddress peerAddr))
   -> BearerInfo
   -> Map
        (NormalisedId (TestAddress peerAddr)) (TVar m (Script BearerInfo))
   -> NetworkState m (TestAddress peerAddr))
-> STM
     m
     (StrictTVar
        m
        (Map
           (NormalisedId (TestAddress peerAddr))
           (Connection m (TestAddress peerAddr))))
-> STM
     m
     ((AddressType -> STM m (TestAddress peerAddr))
      -> BearerInfo
      -> Map
           (NormalisedId (TestAddress peerAddr)) (TVar m (Script BearerInfo))
      -> NetworkState m (TestAddress peerAddr))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Map
  (NormalisedId (TestAddress peerAddr))
  (Connection m (TestAddress peerAddr))
-> STM
     m
     (StrictTVar
        m
        (Map
           (NormalisedId (TestAddress peerAddr))
           (Connection m (TestAddress peerAddr))))
forall (m :: * -> *) a. MonadSTM m => a -> STM m (StrictTVar m a)
newTVar Map
  (NormalisedId (TestAddress peerAddr))
  (Connection m (TestAddress peerAddr))
forall k a. Map k a
Map.empty
    -- nsNextEphemeralAddr
    STM
  m
  ((AddressType -> STM m (TestAddress peerAddr))
   -> BearerInfo
   -> Map
        (NormalisedId (TestAddress peerAddr)) (TVar m (Script BearerInfo))
   -> NetworkState m (TestAddress peerAddr))
-> STM m (AddressType -> STM m (TestAddress peerAddr))
-> STM
     m
     (BearerInfo
      -> Map
           (NormalisedId (TestAddress peerAddr)) (TVar m (Script BearerInfo))
      -> NetworkState m (TestAddress peerAddr))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (AddressType -> STM m (TestAddress peerAddr))
-> STM m (AddressType -> STM m (TestAddress peerAddr))
forall (f :: * -> *) a. Applicative f => a -> f a
pure AddressType -> STM m (TestAddress peerAddr)
nextEphemeralAddr
    -- nsBearerInfo
    STM
  m
  (BearerInfo
   -> Map
        (NormalisedId (TestAddress peerAddr)) (TVar m (Script BearerInfo))
   -> NetworkState m (TestAddress peerAddr))
-> STM m BearerInfo
-> STM
     m
     (Map
        (NormalisedId (TestAddress peerAddr)) (TVar m (Script BearerInfo))
      -> NetworkState m (TestAddress peerAddr))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BearerInfo -> STM m BearerInfo
forall (f :: * -> *) a. Applicative f => a -> f a
pure BearerInfo
defaultBearerInfo
    -- attenuationMap
    STM
  m
  (Map
     (NormalisedId (TestAddress peerAddr)) (TVar m (Script BearerInfo))
   -> NetworkState m (TestAddress peerAddr))
-> STM
     m
     (Map
        (NormalisedId (TestAddress peerAddr)) (TVar m (Script BearerInfo)))
-> STM m (NetworkState m (TestAddress peerAddr))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Map
  (NormalisedId (TestAddress peerAddr)) (TVar m (Script BearerInfo))
-> STM
     m
     (Map
        (NormalisedId (TestAddress peerAddr)) (TVar m (Script BearerInfo)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map
  (NormalisedId (TestAddress peerAddr)) (TVar m (Script BearerInfo))
scriptMapVars

  StrictTVar
  m (Map (TestAddress peerAddr) (FD m (TestAddress peerAddr)))
-> String -> STM m ()
forall (m :: * -> *) a.
MonadLabelledSTM m =>
StrictTVar m a -> String -> STM m ()
labelTVar (NetworkState m (TestAddress peerAddr)
-> StrictTVar
     m (Map (TestAddress peerAddr) (FD m (TestAddress peerAddr)))
forall (m :: * -> *) addr.
NetworkState m addr -> StrictTVar m (Map addr (FD m addr))
nsListeningFDs NetworkState m (TestAddress peerAddr)
s)   String
"nsListeningFDs"
  StrictTVar
  m
  (Map
     (NormalisedId (TestAddress peerAddr))
     (Connection m (TestAddress peerAddr)))
-> String -> STM m ()
forall (m :: * -> *) a.
MonadLabelledSTM m =>
StrictTVar m a -> String -> STM m ()
labelTVar (NetworkState m (TestAddress peerAddr)
-> StrictTVar
     m
     (Map
        (NormalisedId (TestAddress peerAddr))
        (Connection m (TestAddress peerAddr)))
forall (m :: * -> *) addr.
NetworkState m addr
-> StrictTVar m (Map (NormalisedId addr) (Connection m addr))
nsConnections NetworkState m (TestAddress peerAddr)
s)    String
"nsConnections"
  NetworkState m (TestAddress peerAddr)
-> STM m (NetworkState m (TestAddress peerAddr))
forall (m :: * -> *) a. Monad m => a -> m a
return NetworkState m (TestAddress peerAddr)
s


data ResourceException addr
  = NotReleasedListeningSockets [addr] (Maybe SomeException)
  | NotReleasedConnections      (Map (NormalisedId addr) ConnectionState)
                                (Maybe SomeException)
  deriving (Int -> ResourceException addr -> ShowS
[ResourceException addr] -> ShowS
ResourceException addr -> String
(Int -> ResourceException addr -> ShowS)
-> (ResourceException addr -> String)
-> ([ResourceException addr] -> ShowS)
-> Show (ResourceException addr)
forall addr. Show addr => Int -> ResourceException addr -> ShowS
forall addr. Show addr => [ResourceException addr] -> ShowS
forall addr. Show addr => ResourceException addr -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ResourceException addr] -> ShowS
$cshowList :: forall addr. Show addr => [ResourceException addr] -> ShowS
show :: ResourceException addr -> String
$cshow :: forall addr. Show addr => ResourceException addr -> String
showsPrec :: Int -> ResourceException addr -> ShowS
$cshowsPrec :: forall addr. Show addr => Int -> ResourceException addr -> ShowS
Show, Typeable)

instance (Typeable addr, Show addr)
      => Exception (ResourceException addr)


-- | A type class for global IP address scheme.  Every node in the simulation
-- has an ephemeral address.  Every node in the simulation has an implicit ipv4
-- and ipv6 address (if one is not bound by explicitly).
--
class GlobalAddressScheme addr where
    getAddressType   :: TestAddress addr -> AddressType
    ephemeralAddress :: AddressType -> Natural -> TestAddress addr



-- | All negative addresses are ephemeral.  Even address are IPv4, while odd
-- ones are IPv6.
--
instance GlobalAddressScheme Int where
    getAddressType :: TestAddress Int -> AddressType
getAddressType (TestAddress Int
n) = if Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
2 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
                         then AddressType
IPv4Address
                         else AddressType
IPv6Address
    ephemeralAddress :: AddressType -> Natural -> TestAddress Int
ephemeralAddress AddressType
IPv4Address Natural
n = Int -> TestAddress Int
forall addr. addr -> TestAddress addr
TestAddress (Int -> TestAddress Int) -> Int -> TestAddress Int
forall a b. (a -> b) -> a -> b
$ (-Int
2) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
n
    ephemeralAddress AddressType
IPv6Address Natural
n = Int -> TestAddress Int
forall addr. addr -> TestAddress addr
TestAddress (Int -> TestAddress Int) -> Int -> TestAddress Int
forall a b. (a -> b) -> a -> b
$ (-Int
1) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1


-- | A bracket which runs a network simulation.  When the simulation
-- terminates it verifies that all listening sockets and all connections are
-- closed.  It might throw 'ResourceException'.
--
withSnocket
    :: forall m peerAddr a.
       ( MonadCatch       m
       , MonadLabelledSTM m
       , MonadMask        m
       , MonadTime        m
       , MonadTimer       m
       , MonadThrow  (STM m)
       , GlobalAddressScheme peerAddr
       , Ord      peerAddr
       , Typeable peerAddr
       , Show     peerAddr
       )
    => Tracer m (WithAddr (TestAddress peerAddr)
                          (SnocketTrace m (TestAddress peerAddr)))
    -> BearerInfo
    -> Map (NormalisedId (TestAddress peerAddr))
           (Script BearerInfo)
    -> (Snocket m (FD m (TestAddress peerAddr)) (TestAddress peerAddr)
        -> m (ObservableNetworkState (TestAddress peerAddr))
        -> m a)
    -> m a
withSnocket :: Tracer
  m
  (WithAddr
     (TestAddress peerAddr) (SnocketTrace m (TestAddress peerAddr)))
-> BearerInfo
-> Map (NormalisedId (TestAddress peerAddr)) (Script BearerInfo)
-> (Snocket m (FD m (TestAddress peerAddr)) (TestAddress peerAddr)
    -> m (ObservableNetworkState (TestAddress peerAddr)) -> m a)
-> m a
withSnocket Tracer
  m
  (WithAddr
     (TestAddress peerAddr) (SnocketTrace m (TestAddress peerAddr)))
tr BearerInfo
defaultBearerInfo Map (NormalisedId (TestAddress peerAddr)) (Script BearerInfo)
scriptMap Snocket m (FD m (TestAddress peerAddr)) (TestAddress peerAddr)
-> m (ObservableNetworkState (TestAddress peerAddr)) -> m a
k = do
    NetworkState m (TestAddress peerAddr)
st <- BearerInfo
-> Map (NormalisedId (TestAddress peerAddr)) (Script BearerInfo)
-> m (NetworkState m (TestAddress peerAddr))
forall (m :: * -> *) peerAddr.
(MonadLabelledSTM m, GlobalAddressScheme peerAddr) =>
BearerInfo
-> Map (NormalisedId (TestAddress peerAddr)) (Script BearerInfo)
-> m (NetworkState m (TestAddress peerAddr))
newNetworkState BearerInfo
defaultBearerInfo Map (NormalisedId (TestAddress peerAddr)) (Script BearerInfo)
scriptMap
    a
a <- Snocket m (FD m (TestAddress peerAddr)) (TestAddress peerAddr)
-> m (ObservableNetworkState (TestAddress peerAddr)) -> m a
k (NetworkState m (TestAddress peerAddr)
-> Tracer
     m
     (WithAddr
        (TestAddress peerAddr) (SnocketTrace m (TestAddress peerAddr)))
-> Snocket m (FD m (TestAddress peerAddr)) (TestAddress peerAddr)
forall (m :: * -> *) addr.
(MonadLabelledSTM m, MonadThrow (STM m), MonadMask m, MonadTime m,
 MonadTimer m, GlobalAddressScheme addr, Ord addr, Show addr) =>
NetworkState m (TestAddress addr)
-> Tracer
     m (WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr)))
-> Snocket m (FD m (TestAddress addr)) (TestAddress addr)
mkSnocket NetworkState m (TestAddress peerAddr)
st Tracer
  m
  (WithAddr
     (TestAddress peerAddr) (SnocketTrace m (TestAddress peerAddr)))
tr) (NetworkState m (TestAddress peerAddr)
-> m (ObservableNetworkState (TestAddress peerAddr))
toState NetworkState m (TestAddress peerAddr)
st)
         m a -> (SomeException -> m a) -> m a
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch`
         \SomeException
e -> do Maybe (ResourceException (TestAddress peerAddr))
re <- NetworkState m (TestAddress peerAddr)
-> Maybe SomeException
-> m (Maybe (ResourceException (TestAddress peerAddr)))
checkResources NetworkState m (TestAddress peerAddr)
st (SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just SomeException
e)
                  (ResourceException (TestAddress peerAddr) -> m Any)
-> Maybe (ResourceException (TestAddress peerAddr)) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ResourceException (TestAddress peerAddr) -> m Any
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO Maybe (ResourceException (TestAddress peerAddr))
re
                  SomeException -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO SomeException
e
    Maybe (ResourceException (TestAddress peerAddr))
re <- NetworkState m (TestAddress peerAddr)
-> Maybe SomeException
-> m (Maybe (ResourceException (TestAddress peerAddr)))
checkResources NetworkState m (TestAddress peerAddr)
st Maybe SomeException
forall a. Maybe a
Nothing
    (ResourceException (TestAddress peerAddr) -> m Any)
-> Maybe (ResourceException (TestAddress peerAddr)) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ResourceException (TestAddress peerAddr) -> m Any
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO Maybe (ResourceException (TestAddress peerAddr))
re
    a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
  where
    -- verify that all sockets are closed
    checkResources :: NetworkState m (TestAddress peerAddr)
                   -> Maybe SomeException
                   -> m (Maybe (ResourceException (TestAddress peerAddr)))
    checkResources :: NetworkState m (TestAddress peerAddr)
-> Maybe SomeException
-> m (Maybe (ResourceException (TestAddress peerAddr)))
checkResources NetworkState { StrictTVar
  m (Map (TestAddress peerAddr) (FD m (TestAddress peerAddr)))
nsListeningFDs :: StrictTVar
  m (Map (TestAddress peerAddr) (FD m (TestAddress peerAddr)))
nsListeningFDs :: forall (m :: * -> *) addr.
NetworkState m addr -> StrictTVar m (Map addr (FD m addr))
nsListeningFDs, StrictTVar
  m
  (Map
     (NormalisedId (TestAddress peerAddr))
     (Connection m (TestAddress peerAddr)))
nsConnections :: StrictTVar
  m
  (Map
     (NormalisedId (TestAddress peerAddr))
     (Connection m (TestAddress peerAddr)))
nsConnections :: forall (m :: * -> *) addr.
NetworkState m addr
-> StrictTVar m (Map (NormalisedId addr) (Connection m addr))
nsConnections } Maybe SomeException
err = do
      (Map (TestAddress peerAddr) (FD m (TestAddress peerAddr))
lstFDMap, Map
  (NormalisedId (TestAddress peerAddr))
  (Connection m (TestAddress peerAddr))
connMap) <- STM
  m
  (Map (TestAddress peerAddr) (FD m (TestAddress peerAddr)),
   Map
     (NormalisedId (TestAddress peerAddr))
     (Connection m (TestAddress peerAddr)))
-> m (Map (TestAddress peerAddr) (FD m (TestAddress peerAddr)),
      Map
        (NormalisedId (TestAddress peerAddr))
        (Connection m (TestAddress peerAddr)))
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM
   m
   (Map (TestAddress peerAddr) (FD m (TestAddress peerAddr)),
    Map
      (NormalisedId (TestAddress peerAddr))
      (Connection m (TestAddress peerAddr)))
 -> m (Map (TestAddress peerAddr) (FD m (TestAddress peerAddr)),
       Map
         (NormalisedId (TestAddress peerAddr))
         (Connection m (TestAddress peerAddr))))
-> STM
     m
     (Map (TestAddress peerAddr) (FD m (TestAddress peerAddr)),
      Map
        (NormalisedId (TestAddress peerAddr))
        (Connection m (TestAddress peerAddr)))
-> m (Map (TestAddress peerAddr) (FD m (TestAddress peerAddr)),
      Map
        (NormalisedId (TestAddress peerAddr))
        (Connection m (TestAddress peerAddr)))
forall a b. (a -> b) -> a -> b
$ (,) (Map (TestAddress peerAddr) (FD m (TestAddress peerAddr))
 -> Map
      (NormalisedId (TestAddress peerAddr))
      (Connection m (TestAddress peerAddr))
 -> (Map (TestAddress peerAddr) (FD m (TestAddress peerAddr)),
     Map
       (NormalisedId (TestAddress peerAddr))
       (Connection m (TestAddress peerAddr))))
-> STM m (Map (TestAddress peerAddr) (FD m (TestAddress peerAddr)))
-> STM
     m
     (Map
        (NormalisedId (TestAddress peerAddr))
        (Connection m (TestAddress peerAddr))
      -> (Map (TestAddress peerAddr) (FD m (TestAddress peerAddr)),
          Map
            (NormalisedId (TestAddress peerAddr))
            (Connection m (TestAddress peerAddr))))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar
  m (Map (TestAddress peerAddr) (FD m (TestAddress peerAddr)))
-> STM m (Map (TestAddress peerAddr) (FD m (TestAddress peerAddr)))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar
  m (Map (TestAddress peerAddr) (FD m (TestAddress peerAddr)))
nsListeningFDs
                                              STM
  m
  (Map
     (NormalisedId (TestAddress peerAddr))
     (Connection m (TestAddress peerAddr))
   -> (Map (TestAddress peerAddr) (FD m (TestAddress peerAddr)),
       Map
         (NormalisedId (TestAddress peerAddr))
         (Connection m (TestAddress peerAddr))))
-> STM
     m
     (Map
        (NormalisedId (TestAddress peerAddr))
        (Connection m (TestAddress peerAddr)))
-> STM
     m
     (Map (TestAddress peerAddr) (FD m (TestAddress peerAddr)),
      Map
        (NormalisedId (TestAddress peerAddr))
        (Connection m (TestAddress peerAddr)))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StrictTVar
  m
  (Map
     (NormalisedId (TestAddress peerAddr))
     (Connection m (TestAddress peerAddr)))
-> STM
     m
     (Map
        (NormalisedId (TestAddress peerAddr))
        (Connection m (TestAddress peerAddr)))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar
  m
  (Map
     (NormalisedId (TestAddress peerAddr))
     (Connection m (TestAddress peerAddr)))
nsConnections
      if |  Bool -> Bool
not (Map (TestAddress peerAddr) (FD m (TestAddress peerAddr)) -> Bool
forall k a. Map k a -> Bool
Map.null Map (TestAddress peerAddr) (FD m (TestAddress peerAddr))
lstFDMap)
         -> Maybe (ResourceException (TestAddress peerAddr))
-> m (Maybe (ResourceException (TestAddress peerAddr)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (ResourceException (TestAddress peerAddr))
 -> m (Maybe (ResourceException (TestAddress peerAddr))))
-> Maybe (ResourceException (TestAddress peerAddr))
-> m (Maybe (ResourceException (TestAddress peerAddr)))
forall a b. (a -> b) -> a -> b
$ ResourceException (TestAddress peerAddr)
-> Maybe (ResourceException (TestAddress peerAddr))
forall a. a -> Maybe a
Just ([TestAddress peerAddr]
-> Maybe SomeException -> ResourceException (TestAddress peerAddr)
forall addr.
[addr] -> Maybe SomeException -> ResourceException addr
NotReleasedListeningSockets (Map (TestAddress peerAddr) (FD m (TestAddress peerAddr))
-> [TestAddress peerAddr]
forall k a. Map k a -> [k]
Map.keys Map (TestAddress peerAddr) (FD m (TestAddress peerAddr))
lstFDMap) Maybe SomeException
err)

         |  Bool -> Bool
not (Map
  (NormalisedId (TestAddress peerAddr))
  (Connection m (TestAddress peerAddr))
-> Bool
forall k a. Map k a -> Bool
Map.null Map
  (NormalisedId (TestAddress peerAddr))
  (Connection m (TestAddress peerAddr))
connMap)
         -> Maybe (ResourceException (TestAddress peerAddr))
-> m (Maybe (ResourceException (TestAddress peerAddr)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (ResourceException (TestAddress peerAddr))
 -> m (Maybe (ResourceException (TestAddress peerAddr))))
-> Maybe (ResourceException (TestAddress peerAddr))
-> m (Maybe (ResourceException (TestAddress peerAddr)))
forall a b. (a -> b) -> a -> b
$ ResourceException (TestAddress peerAddr)
-> Maybe (ResourceException (TestAddress peerAddr))
forall a. a -> Maybe a
Just (Map (NormalisedId (TestAddress peerAddr)) ConnectionState
-> Maybe SomeException -> ResourceException (TestAddress peerAddr)
forall addr.
Map (NormalisedId addr) ConnectionState
-> Maybe SomeException -> ResourceException addr
NotReleasedConnections      ( (Connection m (TestAddress peerAddr) -> ConnectionState)
-> Map
     (NormalisedId (TestAddress peerAddr))
     (Connection m (TestAddress peerAddr))
-> Map (NormalisedId (TestAddress peerAddr)) ConnectionState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Connection m (TestAddress peerAddr) -> ConnectionState
forall (m :: * -> *) addr. Connection m addr -> ConnectionState
connState
                                                       (Map
   (NormalisedId (TestAddress peerAddr))
   (Connection m (TestAddress peerAddr))
 -> Map (NormalisedId (TestAddress peerAddr)) ConnectionState)
-> Map
     (NormalisedId (TestAddress peerAddr))
     (Connection m (TestAddress peerAddr))
-> Map (NormalisedId (TestAddress peerAddr)) ConnectionState
forall a b. (a -> b) -> a -> b
$ Map
  (NormalisedId (TestAddress peerAddr))
  (Connection m (TestAddress peerAddr))
connMap
                                                       ) Maybe SomeException
err)

         |  Bool
otherwise
         -> Maybe (ResourceException (TestAddress peerAddr))
-> m (Maybe (ResourceException (TestAddress peerAddr)))
forall (m :: * -> *) a. Monad m => a -> m a
return   Maybe (ResourceException (TestAddress peerAddr))
forall a. Maybe a
Nothing

    toState :: NetworkState m (TestAddress peerAddr)
               -> m (ObservableNetworkState (TestAddress peerAddr))
    toState :: NetworkState m (TestAddress peerAddr)
-> m (ObservableNetworkState (TestAddress peerAddr))
toState NetworkState m (TestAddress peerAddr)
ns = STM m (ObservableNetworkState (TestAddress peerAddr))
-> m (ObservableNetworkState (TestAddress peerAddr))
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (ObservableNetworkState (TestAddress peerAddr))
 -> m (ObservableNetworkState (TestAddress peerAddr)))
-> STM m (ObservableNetworkState (TestAddress peerAddr))
-> m (ObservableNetworkState (TestAddress peerAddr))
forall a b. (a -> b) -> a -> b
$ do
        Map (NormalisedId (TestAddress peerAddr)) (TestAddress peerAddr)
onsConnections <- (Connection m (TestAddress peerAddr) -> TestAddress peerAddr)
-> Map
     (NormalisedId (TestAddress peerAddr))
     (Connection m (TestAddress peerAddr))
-> Map (NormalisedId (TestAddress peerAddr)) (TestAddress peerAddr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Connection m (TestAddress peerAddr) -> TestAddress peerAddr
forall (m :: * -> *) addr. Connection m addr -> addr
connProvider (Map
   (NormalisedId (TestAddress peerAddr))
   (Connection m (TestAddress peerAddr))
 -> Map
      (NormalisedId (TestAddress peerAddr)) (TestAddress peerAddr))
-> STM
     m
     (Map
        (NormalisedId (TestAddress peerAddr))
        (Connection m (TestAddress peerAddr)))
-> STM
     m
     (Map (NormalisedId (TestAddress peerAddr)) (TestAddress peerAddr))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar
  m
  (Map
     (NormalisedId (TestAddress peerAddr))
     (Connection m (TestAddress peerAddr)))
-> STM
     m
     (Map
        (NormalisedId (TestAddress peerAddr))
        (Connection m (TestAddress peerAddr)))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (NetworkState m (TestAddress peerAddr)
-> StrictTVar
     m
     (Map
        (NormalisedId (TestAddress peerAddr))
        (Connection m (TestAddress peerAddr)))
forall (m :: * -> *) addr.
NetworkState m addr
-> StrictTVar m (Map (NormalisedId addr) (Connection m addr))
nsConnections NetworkState m (TestAddress peerAddr)
ns)
        ObservableNetworkState (TestAddress peerAddr)
-> STM m (ObservableNetworkState (TestAddress peerAddr))
forall (m :: * -> *) a. Monad m => a -> m a
return (Map (NormalisedId (TestAddress peerAddr)) (TestAddress peerAddr)
-> ObservableNetworkState (TestAddress peerAddr)
forall addr.
Map (NormalisedId addr) addr -> ObservableNetworkState addr
ObservableNetworkState Map (NormalisedId (TestAddress peerAddr)) (TestAddress peerAddr)
onsConnections)



-- | Channel together with information needed by the other end, e.g. address of
-- the connecting host, shared 'SDUSize'.
--
data ChannelWithInfo m addr = ChannelWithInfo {
    ChannelWithInfo m addr -> addr
cwiAddress       :: !addr,
    ChannelWithInfo m addr -> SDUSize
cwiSDUSize       :: !SDUSize,
    ChannelWithInfo m addr -> AttenuatedChannel m
cwiChannelLocal  :: !(AttenuatedChannel m),
    ChannelWithInfo m addr -> AttenuatedChannel m
cwiChannelRemote :: !(AttenuatedChannel m)
  }


--
-- File descriptors
--

-- | Internal file descriptor type which tracks the file descriptor state
-- across 'Snocket' api calls.
--
data FD_ m addr
    -- | 'FD_' for uninitialised snockets (either not connected or not
    -- listening).
    --
    -- 'open' or 'openToConnect' creates an uninitialised file descriptor
    -- (which corresponds to 'socket' system call).
    -- 'bind' will update the address.
    = FDUninitialised
        !(Maybe addr)
        -- ^ address (initialised by a 'bind')

    -- | 'FD_' for snockets in listening state.
    --
    -- 'FDListening' is created by 'listen'
    --
    | FDListening
        !addr
        -- ^ listening address

        !(TBQueue m (ChannelWithInfo m addr))
        -- ^ listening queue; when 'connect' is called; dual 'AttenuatedChannel'
        -- of 'FDConnected' file descriptor is passed through the listening
        -- queue.
        --
        -- 'connect' is the producer of this queue;
        -- 'accept' is the consumer.

    -- | 'FD_' was passed to 'connect' call, if needed an ephemeral address was
    -- assigned to it.  This corresponds to 'SYN_SENT' state.
    --
    | FDConnecting !(ConnectionId addr)
                   !(Connection m addr)

    -- | 'FD_' for snockets in connected state.
    --
    -- 'FDConnected' is created by either 'connect' or 'accept'.  It
    -- corresponds to 'ESTABLISHED' state.
    --
    | FDConnected
        !(ConnectionId addr)
        -- ^ local and remote addresses
        !(Connection m addr)
        -- ^ connection

    -- | 'FD_' of a closed file descriptor; we keep 'ConnectionId' just for
    -- tracing purposes.
    --
    | FDClosed
        !(Wedge (ConnectionId addr) addr)


instance Show addr => Show (FD_ m addr) where
    show :: FD_ m addr -> String
show (FDUninitialised Maybe addr
mbAddr)   = String
"FDUninitialised " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Maybe addr -> String
forall a. Show a => a -> String
show Maybe addr
mbAddr
    show (FDListening addr
addr TBQueue m (ChannelWithInfo m addr)
_)       = String
"FDListening " String -> ShowS
forall a. [a] -> [a] -> [a]
++ addr -> String
forall a. Show a => a -> String
show addr
addr
    show (FDConnecting ConnectionId addr
connId Connection m addr
conn) = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                                    [ String
"FDConnecting "
                                    , ConnectionId addr -> String
forall a. Show a => a -> String
show ConnectionId addr
connId
                                    , String
" "
                                    , SDUSize -> String
forall a. Show a => a -> String
show (Connection m addr -> SDUSize
forall (m :: * -> *) addr. Connection m addr -> SDUSize
connSDUSize Connection m addr
conn)
                                    ]
    show (FDConnected ConnectionId addr
connId Connection m addr
conn)  = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                                    [ String
"FDConnected "
                                    , ConnectionId addr -> String
forall a. Show a => a -> String
show ConnectionId addr
connId
                                    , String
" "
                                    , SDUSize -> String
forall a. Show a => a -> String
show (Connection m addr -> SDUSize
forall (m :: * -> *) addr. Connection m addr -> SDUSize
connSDUSize Connection m addr
conn)
                                    ]
    show (FDClosed Wedge (ConnectionId addr) addr
mbConnId)        = String
"FDClosed " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Wedge (ConnectionId addr) addr -> String
forall a. Show a => a -> String
show Wedge (ConnectionId addr) addr
mbConnId


-- | File descriptor type.
--
newtype FD m peerAddr = FD { FD m peerAddr -> StrictTVar m (FD_ m peerAddr)
fdVar :: (StrictTVar m (FD_ m peerAddr)) }


--
-- Simulated snockets
--

data WithAddr addr event =
    WithAddr { WithAddr addr event -> Maybe addr
waLocalAddr  :: Maybe addr
             , WithAddr addr event -> Maybe addr
waRemoteAddr :: Maybe addr
             , WithAddr addr event -> event
waEvent      :: event
             }
  deriving Int -> WithAddr addr event -> ShowS
[WithAddr addr event] -> ShowS
WithAddr addr event -> String
(Int -> WithAddr addr event -> ShowS)
-> (WithAddr addr event -> String)
-> ([WithAddr addr event] -> ShowS)
-> Show (WithAddr addr event)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall addr event.
(Show addr, Show event) =>
Int -> WithAddr addr event -> ShowS
forall addr event.
(Show addr, Show event) =>
[WithAddr addr event] -> ShowS
forall addr event.
(Show addr, Show event) =>
WithAddr addr event -> String
showList :: [WithAddr addr event] -> ShowS
$cshowList :: forall addr event.
(Show addr, Show event) =>
[WithAddr addr event] -> ShowS
show :: WithAddr addr event -> String
$cshow :: forall addr event.
(Show addr, Show event) =>
WithAddr addr event -> String
showsPrec :: Int -> WithAddr addr event -> ShowS
$cshowsPrec :: forall addr event.
(Show addr, Show event) =>
Int -> WithAddr addr event -> ShowS
Show

data SockType = ListeningSock
              | ConnectionSock
              | UnknownType
  deriving Int -> SockType -> ShowS
[SockType] -> ShowS
SockType -> String
(Int -> SockType -> ShowS)
-> (SockType -> String) -> ([SockType] -> ShowS) -> Show SockType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SockType] -> ShowS
$cshowList :: [SockType] -> ShowS
show :: SockType -> String
$cshow :: SockType -> String
showsPrec :: Int -> SockType -> ShowS
$cshowsPrec :: Int -> SockType -> ShowS
Show

mkSockType :: FD_ m addr -> SockType
mkSockType :: FD_ m addr -> SockType
mkSockType FDUninitialised {} = SockType
UnknownType
mkSockType FDListening {}     = SockType
ListeningSock
mkSockType FDConnecting {}    = SockType
ConnectionSock
mkSockType FDConnected {}     = SockType
ConnectionSock
mkSockType FDClosed {}        = SockType
UnknownType

data TimeoutDetail
    = WaitingToConnect
    | WaitingToBeAccepted
  deriving Int -> TimeoutDetail -> ShowS
[TimeoutDetail] -> ShowS
TimeoutDetail -> String
(Int -> TimeoutDetail -> ShowS)
-> (TimeoutDetail -> String)
-> ([TimeoutDetail] -> ShowS)
-> Show TimeoutDetail
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TimeoutDetail] -> ShowS
$cshowList :: [TimeoutDetail] -> ShowS
show :: TimeoutDetail -> String
$cshow :: TimeoutDetail -> String
showsPrec :: Int -> TimeoutDetail -> ShowS
$cshowsPrec :: Int -> TimeoutDetail -> ShowS
Show

data SnocketTrace m addr
    = STConnecting   (FD_ m addr) addr
    | STConnected    (FD_ m addr) OpenType
    | STBearerInfo   BearerInfo
    | STConnectError (FD_ m addr) addr IOError
    | STConnectTimeout TimeoutDetail
    | STBindError    (FD_ m addr) addr IOError
    | STClosing      SockType (Wedge (ConnectionId addr) [addr])
    | STClosed       SockType (Maybe (Maybe ConnectionState))
    -- ^ TODO: Document meaning of 'Maybe (Maybe OpenState)'
    | STClosingQueue Bool
    | STClosedQueue  Bool
    | STAcceptFailure SockType SomeException
    | STAccepting
    | STAccepted      addr
    | STBearer       (FD_ m addr)
    | STAttenuatedChannelTrace (ConnectionId addr) AttenuatedChannelTrace
  deriving Int -> SnocketTrace m addr -> ShowS
[SnocketTrace m addr] -> ShowS
SnocketTrace m addr -> String
(Int -> SnocketTrace m addr -> ShowS)
-> (SnocketTrace m addr -> String)
-> ([SnocketTrace m addr] -> ShowS)
-> Show (SnocketTrace m addr)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (m :: * -> *) addr.
Show addr =>
Int -> SnocketTrace m addr -> ShowS
forall (m :: * -> *) addr.
Show addr =>
[SnocketTrace m addr] -> ShowS
forall (m :: * -> *) addr.
Show addr =>
SnocketTrace m addr -> String
showList :: [SnocketTrace m addr] -> ShowS
$cshowList :: forall (m :: * -> *) addr.
Show addr =>
[SnocketTrace m addr] -> ShowS
show :: SnocketTrace m addr -> String
$cshow :: forall (m :: * -> *) addr.
Show addr =>
SnocketTrace m addr -> String
showsPrec :: Int -> SnocketTrace m addr -> ShowS
$cshowsPrec :: forall (m :: * -> *) addr.
Show addr =>
Int -> SnocketTrace m addr -> ShowS
Show

-- | Either simultaneous open or normal open.  Unlike in TCP, only one side will
-- will know that it is doing simultaneous open.
--
data OpenType =
    -- | Simultaneous open
      SimOpen

    -- | Normal open
    | NormalOpen
  deriving Int -> OpenType -> ShowS
[OpenType] -> ShowS
OpenType -> String
(Int -> OpenType -> ShowS)
-> (OpenType -> String) -> ([OpenType] -> ShowS) -> Show OpenType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [OpenType] -> ShowS
$cshowList :: [OpenType] -> ShowS
show :: OpenType -> String
$cshow :: OpenType -> String
showsPrec :: Int -> OpenType -> ShowS
$cshowsPrec :: Int -> OpenType -> ShowS
Show


connectTimeout :: DiffTime
connectTimeout :: DiffTime
connectTimeout = DiffTime
120


-- | Simulated 'Snocket' running in 'NetworkState'.  A single 'NetworkState'
-- should be shared with all nodes in the same network.
--
mkSnocket :: forall m addr.
             ( MonadLabelledSTM   m
             , MonadThrow    (STM m)
             , MonadMask          m
             , MonadTime          m
             , MonadTimer         m
             , GlobalAddressScheme addr
             , Ord  addr
             , Show addr
             )
          => NetworkState m (TestAddress addr)
          -> Tracer m (WithAddr (TestAddress addr)
                                (SnocketTrace m (TestAddress addr)))
          -> Snocket m (FD m (TestAddress addr)) (TestAddress addr)
mkSnocket :: NetworkState m (TestAddress addr)
-> Tracer
     m (WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr)))
-> Snocket m (FD m (TestAddress addr)) (TestAddress addr)
mkSnocket NetworkState m (TestAddress addr)
state Tracer
  m (WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr)))
tr = Snocket :: forall (m :: * -> *) fd addr.
(fd -> m addr)
-> (fd -> m addr)
-> (addr -> AddressFamily addr)
-> (AddressFamily addr -> m fd)
-> (addr -> m fd)
-> (fd -> addr -> m ())
-> (fd -> addr -> m ())
-> (fd -> m ())
-> (fd -> m (Accept m fd addr))
-> (fd -> m ())
-> (DiffTime -> Tracer m MuxTrace -> fd -> m (MuxBearer m))
-> Snocket m fd addr
Snocket { FD m (TestAddress addr) -> m (TestAddress addr)
getLocalAddr :: FD m (TestAddress addr) -> m (TestAddress addr)
getLocalAddr :: FD m (TestAddress addr) -> m (TestAddress addr)
getLocalAddr
                             , FD m (TestAddress addr) -> m (TestAddress addr)
getRemoteAddr :: FD m (TestAddress addr) -> m (TestAddress addr)
getRemoteAddr :: FD m (TestAddress addr) -> m (TestAddress addr)
getRemoteAddr
                             , TestAddress addr -> AddressFamily (TestAddress addr)
addrFamily :: TestAddress addr -> AddressFamily (TestAddress addr)
addrFamily :: TestAddress addr -> AddressFamily (TestAddress addr)
addrFamily
                             , AddressFamily (TestAddress addr) -> m (FD m (TestAddress addr))
open :: AddressFamily (TestAddress addr) -> m (FD m (TestAddress addr))
open :: AddressFamily (TestAddress addr) -> m (FD m (TestAddress addr))
open
                             , TestAddress addr -> m (FD m (TestAddress addr))
openToConnect :: TestAddress addr -> m (FD m (TestAddress addr))
openToConnect :: TestAddress addr -> m (FD m (TestAddress addr))
openToConnect
                             , FD m (TestAddress addr) -> TestAddress addr -> m ()
connect :: FD m (TestAddress addr) -> TestAddress addr -> m ()
connect :: FD m (TestAddress addr) -> TestAddress addr -> m ()
connect
                             , FD m (TestAddress addr) -> TestAddress addr -> m ()
bind :: FD m (TestAddress addr) -> TestAddress addr -> m ()
bind :: FD m (TestAddress addr) -> TestAddress addr -> m ()
bind
                             , FD m (TestAddress addr) -> m ()
listen :: FD m (TestAddress addr) -> m ()
listen :: FD m (TestAddress addr) -> m ()
listen
                             , FD m (TestAddress addr)
-> m (Accept m (FD m (TestAddress addr)) (TestAddress addr))
accept :: FD m (TestAddress addr)
-> m (Accept m (FD m (TestAddress addr)) (TestAddress addr))
accept :: FD m (TestAddress addr)
-> m (Accept m (FD m (TestAddress addr)) (TestAddress addr))
accept
                             , FD m (TestAddress addr) -> m ()
close :: FD m (TestAddress addr) -> m ()
close :: FD m (TestAddress addr) -> m ()
close
                             , DiffTime
-> Tracer m MuxTrace -> FD m (TestAddress addr) -> m (MuxBearer m)
toBearer :: DiffTime
-> Tracer m MuxTrace -> FD m (TestAddress addr) -> m (MuxBearer m)
toBearer :: DiffTime
-> Tracer m MuxTrace -> FD m (TestAddress addr) -> m (MuxBearer m)
toBearer
                             }
  where
    getLocalAddrM :: FD m (TestAddress addr)
                  -> m (Either (FD_ m (TestAddress addr))
                               (TestAddress addr))
    getLocalAddrM :: FD m (TestAddress addr)
-> m (Either (FD_ m (TestAddress addr)) (TestAddress addr))
getLocalAddrM FD { StrictTVar m (FD_ m (TestAddress addr))
fdVar :: StrictTVar m (FD_ m (TestAddress addr))
fdVar :: forall (m :: * -> *) peerAddr.
FD m peerAddr -> StrictTVar m (FD_ m peerAddr)
fdVar } = do
        FD_ m (TestAddress addr)
fd_ <- STM m (FD_ m (TestAddress addr)) -> m (FD_ m (TestAddress addr))
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (StrictTVar m (FD_ m (TestAddress addr))
-> STM m (FD_ m (TestAddress addr))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (FD_ m (TestAddress addr))
fdVar)
        Either (FD_ m (TestAddress addr)) (TestAddress addr)
-> m (Either (FD_ m (TestAddress addr)) (TestAddress addr))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (FD_ m (TestAddress addr)) (TestAddress addr)
 -> m (Either (FD_ m (TestAddress addr)) (TestAddress addr)))
-> Either (FD_ m (TestAddress addr)) (TestAddress addr)
-> m (Either (FD_ m (TestAddress addr)) (TestAddress addr))
forall a b. (a -> b) -> a -> b
$ case FD_ m (TestAddress addr)
fd_ of
          FDUninitialised Maybe (TestAddress addr)
Nothing         -> FD_ m (TestAddress addr)
-> Either (FD_ m (TestAddress addr)) (TestAddress addr)
forall a b. a -> Either a b
Left FD_ m (TestAddress addr)
fd_
          FDUninitialised (Just TestAddress addr
peerAddr) -> TestAddress addr
-> Either (FD_ m (TestAddress addr)) (TestAddress addr)
forall a b. b -> Either a b
Right TestAddress addr
peerAddr
          FDListening TestAddress addr
peerAddr TBQueue m (ChannelWithInfo m (TestAddress addr))
_          -> TestAddress addr
-> Either (FD_ m (TestAddress addr)) (TestAddress addr)
forall a b. b -> Either a b
Right TestAddress addr
peerAddr
          FDConnecting ConnectionId { TestAddress addr
localAddress :: TestAddress addr
localAddress :: forall addr. ConnectionId addr -> addr
localAddress } Connection m (TestAddress addr)
_
                                          -> TestAddress addr
-> Either (FD_ m (TestAddress addr)) (TestAddress addr)
forall a b. b -> Either a b
Right TestAddress addr
localAddress
          FDConnected  ConnectionId { TestAddress addr
localAddress :: TestAddress addr
localAddress :: forall addr. ConnectionId addr -> addr
localAddress } Connection m (TestAddress addr)
_
                                          -> TestAddress addr
-> Either (FD_ m (TestAddress addr)) (TestAddress addr)
forall a b. b -> Either a b
Right TestAddress addr
localAddress
          FDClosed {}                     -> FD_ m (TestAddress addr)
-> Either (FD_ m (TestAddress addr)) (TestAddress addr)
forall a b. a -> Either a b
Left FD_ m (TestAddress addr)
fd_

    getRemoteAddrM :: FD m (TestAddress addr)
                   -> m (Either (FD_ m (TestAddress addr))
                                (TestAddress addr))
    getRemoteAddrM :: FD m (TestAddress addr)
-> m (Either (FD_ m (TestAddress addr)) (TestAddress addr))
getRemoteAddrM FD { StrictTVar m (FD_ m (TestAddress addr))
fdVar :: StrictTVar m (FD_ m (TestAddress addr))
fdVar :: forall (m :: * -> *) peerAddr.
FD m peerAddr -> StrictTVar m (FD_ m peerAddr)
fdVar } = do
        FD_ m (TestAddress addr)
fd_ <- STM m (FD_ m (TestAddress addr)) -> m (FD_ m (TestAddress addr))
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (StrictTVar m (FD_ m (TestAddress addr))
-> STM m (FD_ m (TestAddress addr))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (FD_ m (TestAddress addr))
fdVar)
        Either (FD_ m (TestAddress addr)) (TestAddress addr)
-> m (Either (FD_ m (TestAddress addr)) (TestAddress addr))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (FD_ m (TestAddress addr)) (TestAddress addr)
 -> m (Either (FD_ m (TestAddress addr)) (TestAddress addr)))
-> Either (FD_ m (TestAddress addr)) (TestAddress addr)
-> m (Either (FD_ m (TestAddress addr)) (TestAddress addr))
forall a b. (a -> b) -> a -> b
$ case FD_ m (TestAddress addr)
fd_ of
          FDUninitialised {}         -> FD_ m (TestAddress addr)
-> Either (FD_ m (TestAddress addr)) (TestAddress addr)
forall a b. a -> Either a b
Left FD_ m (TestAddress addr)
fd_
          FDListening {}             -> FD_ m (TestAddress addr)
-> Either (FD_ m (TestAddress addr)) (TestAddress addr)
forall a b. a -> Either a b
Left FD_ m (TestAddress addr)
fd_
          FDConnecting ConnectionId { TestAddress addr
remoteAddress :: TestAddress addr
remoteAddress :: forall addr. ConnectionId addr -> addr
remoteAddress } Connection m (TestAddress addr)
_
                                     -> TestAddress addr
-> Either (FD_ m (TestAddress addr)) (TestAddress addr)
forall a b. b -> Either a b
Right TestAddress addr
remoteAddress
          FDConnected  ConnectionId { TestAddress addr
remoteAddress :: TestAddress addr
remoteAddress :: forall addr. ConnectionId addr -> addr
remoteAddress } Connection m (TestAddress addr)
_
                                     -> TestAddress addr
-> Either (FD_ m (TestAddress addr)) (TestAddress addr)
forall a b. b -> Either a b
Right TestAddress addr
remoteAddress
          FDClosed {}                -> FD_ m (TestAddress addr)
-> Either (FD_ m (TestAddress addr)) (TestAddress addr)
forall a b. a -> Either a b
Left FD_ m (TestAddress addr)
fd_

    traceWith' :: FD m (TestAddress addr)
               -> SnocketTrace m (TestAddress addr)
               -> m ()
    traceWith' :: FD m (TestAddress addr)
-> SnocketTrace m (TestAddress addr) -> m ()
traceWith' FD m (TestAddress addr)
fd =
      let tr' :: Tracer m (SnocketTrace m (TestAddress addr))
          tr' :: Tracer m (SnocketTrace m (TestAddress addr))
tr' = (\SnocketTrace m (TestAddress addr)
ev -> (\Either (FD_ m (TestAddress addr)) (TestAddress addr)
a Either (FD_ m (TestAddress addr)) (TestAddress addr)
b -> Maybe (TestAddress addr)
-> Maybe (TestAddress addr)
-> SnocketTrace m (TestAddress addr)
-> WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr))
forall addr event.
Maybe addr -> Maybe addr -> event -> WithAddr addr event
WithAddr (Either (FD_ m (TestAddress addr)) (TestAddress addr)
-> Maybe (TestAddress addr)
forall a b. Either a b -> Maybe b
hush Either (FD_ m (TestAddress addr)) (TestAddress addr)
a)
                                          (Either (FD_ m (TestAddress addr)) (TestAddress addr)
-> Maybe (TestAddress addr)
forall a b. Either a b -> Maybe b
hush Either (FD_ m (TestAddress addr)) (TestAddress addr)
b) SnocketTrace m (TestAddress addr)
ev)
                    (Either (FD_ m (TestAddress addr)) (TestAddress addr)
 -> Either (FD_ m (TestAddress addr)) (TestAddress addr)
 -> WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr)))
-> m (Either (FD_ m (TestAddress addr)) (TestAddress addr))
-> m (Either (FD_ m (TestAddress addr)) (TestAddress addr)
      -> WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FD m (TestAddress addr)
-> m (Either (FD_ m (TestAddress addr)) (TestAddress addr))
getLocalAddrM  FD m (TestAddress addr)
fd
                    m (Either (FD_ m (TestAddress addr)) (TestAddress addr)
   -> WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr)))
-> m (Either (FD_ m (TestAddress addr)) (TestAddress addr))
-> m (WithAddr
        (TestAddress addr) (SnocketTrace m (TestAddress addr)))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FD m (TestAddress addr)
-> m (Either (FD_ m (TestAddress addr)) (TestAddress addr))
getRemoteAddrM FD m (TestAddress addr)
fd)
                (SnocketTrace m (TestAddress addr)
 -> m (WithAddr
         (TestAddress addr) (SnocketTrace m (TestAddress addr))))
-> Tracer
     m (WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr)))
-> Tracer m (SnocketTrace m (TestAddress addr))
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Tracer m b -> Tracer m a
`contramapM` Tracer
  m (WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr)))
tr
      in Tracer m (SnocketTrace m (TestAddress addr))
-> SnocketTrace m (TestAddress addr) -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (SnocketTrace m (TestAddress addr))
tr'

    --
    -- Snocket api
    --

    getLocalAddr :: FD m (TestAddress addr) -> m (TestAddress addr)
    getLocalAddr :: FD m (TestAddress addr) -> m (TestAddress addr)
getLocalAddr FD m (TestAddress addr)
fd = do
        Either (FD_ m (TestAddress addr)) (TestAddress addr)
maddr <- FD m (TestAddress addr)
-> m (Either (FD_ m (TestAddress addr)) (TestAddress addr))
getLocalAddrM FD m (TestAddress addr)
fd
        case Either (FD_ m (TestAddress addr)) (TestAddress addr)
maddr of
          Right TestAddress addr
addr -> TestAddress addr -> m (TestAddress addr)
forall (m :: * -> *) a. Monad m => a -> m a
return TestAddress addr
addr
          -- Socket would not error for an @FDUninitialised Nothing@; it would
          -- return '0.0.0.0:0'.
          Left FD_ m (TestAddress addr)
fd_   -> IOError -> m (TestAddress addr)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (FD_ m (TestAddress addr) -> IOError
ioe FD_ m (TestAddress addr)
fd_)
      where
        ioe :: FD_ m (TestAddress addr) -> IOError
        ioe :: FD_ m (TestAddress addr) -> IOError
ioe FD_ m (TestAddress addr)
fd_ = IOError :: Maybe Handle
-> IOErrorType
-> String
-> String
-> Maybe CInt
-> Maybe String
-> IOError
IOError
                { ioe_handle :: Maybe Handle
ioe_handle      = Maybe Handle
forall a. Maybe a
Nothing
                , ioe_type :: IOErrorType
ioe_type        = IOErrorType
InvalidArgument
                , ioe_location :: String
ioe_location    = String
"Ouroboros.Network.Snocket.Sim.getLocalAddr"
                , ioe_description :: String
ioe_description = String -> ShowS
forall r. PrintfType r => String -> r
printf String
"Transport endpoint (%s) is not connected" (FD_ m (TestAddress addr) -> String
forall a. Show a => a -> String
show FD_ m (TestAddress addr)
fd_)
                , ioe_errno :: Maybe CInt
ioe_errno       = Maybe CInt
forall a. Maybe a
Nothing
                , ioe_filename :: Maybe String
ioe_filename    = Maybe String
forall a. Maybe a
Nothing
                }

    getRemoteAddr :: FD m (TestAddress addr) -> m (TestAddress addr)
    getRemoteAddr :: FD m (TestAddress addr) -> m (TestAddress addr)
getRemoteAddr FD m (TestAddress addr)
fd = do
      Either (FD_ m (TestAddress addr)) (TestAddress addr)
maddr <- FD m (TestAddress addr)
-> m (Either (FD_ m (TestAddress addr)) (TestAddress addr))
getRemoteAddrM FD m (TestAddress addr)
fd
      case Either (FD_ m (TestAddress addr)) (TestAddress addr)
maddr of
        Right TestAddress addr
addr -> TestAddress addr -> m (TestAddress addr)
forall (m :: * -> *) a. Monad m => a -> m a
return TestAddress addr
addr
        Left FD_ m (TestAddress addr)
fd_   -> IOError -> m (TestAddress addr)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (FD_ m (TestAddress addr) -> IOError
ioe FD_ m (TestAddress addr)
fd_)
      where
        ioe :: FD_ m (TestAddress addr) -> IOError
        ioe :: FD_ m (TestAddress addr) -> IOError
ioe FD_ m (TestAddress addr)
fd_ = IOError :: Maybe Handle
-> IOErrorType
-> String
-> String
-> Maybe CInt
-> Maybe String
-> IOError
IOError
          { ioe_handle :: Maybe Handle
ioe_handle      = Maybe Handle
forall a. Maybe a
Nothing
          , ioe_type :: IOErrorType
ioe_type        = IOErrorType
InvalidArgument
          , ioe_location :: String
ioe_location    = String
"Ouroboros.Network.Snocket.Sim.getRemoteAddr"
          , ioe_description :: String
ioe_description = String -> ShowS
forall r. PrintfType r => String -> r
printf String
"Transport endpoint is not connected" (FD_ m (TestAddress addr) -> String
forall a. Show a => a -> String
show FD_ m (TestAddress addr)
fd_)
          , ioe_errno :: Maybe CInt
ioe_errno       = Maybe CInt
forall a. Maybe a
Nothing
          , ioe_filename :: Maybe String
ioe_filename    = Maybe String
forall a. Maybe a
Nothing
          }


    addrFamily :: TestAddress addr -> AddressFamily (TestAddress addr)
    addrFamily :: TestAddress addr -> AddressFamily (TestAddress addr)
addrFamily TestAddress addr
_ = AddressFamily (TestAddress addr)
forall addr. AddressFamily (TestAddress addr)
TestFamily


    open :: AddressFamily (TestAddress addr) -> m (FD m (TestAddress addr))
    open :: AddressFamily (TestAddress addr) -> m (FD m (TestAddress addr))
open AddressFamily (TestAddress addr)
_ = STM m (FD m (TestAddress addr)) -> m (FD m (TestAddress addr))
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (FD m (TestAddress addr)) -> m (FD m (TestAddress addr)))
-> STM m (FD m (TestAddress addr)) -> m (FD m (TestAddress addr))
forall a b. (a -> b) -> a -> b
$ do
      StrictTVar m (FD_ m (TestAddress addr))
fdVar <- FD_ m (TestAddress addr)
-> STM m (StrictTVar m (FD_ m (TestAddress addr)))
forall (m :: * -> *) a. MonadSTM m => a -> STM m (StrictTVar m a)
newTVar (Maybe (TestAddress addr) -> FD_ m (TestAddress addr)
forall (m :: * -> *) addr. Maybe addr -> FD_ m addr
FDUninitialised Maybe (TestAddress addr)
forall a. Maybe a
Nothing)
      StrictTVar m (FD_ m (TestAddress addr)) -> String -> STM m ()
forall (m :: * -> *) a.
MonadLabelledSTM m =>
StrictTVar m a -> String -> STM m ()
labelTVar StrictTVar m (FD_ m (TestAddress addr))
fdVar String
"fd"
      FD m (TestAddress addr) -> STM m (FD m (TestAddress addr))
forall (m :: * -> *) a. Monad m => a -> m a
return FD :: forall (m :: * -> *) peerAddr.
StrictTVar m (FD_ m peerAddr) -> FD m peerAddr
FD { StrictTVar m (FD_ m (TestAddress addr))
fdVar :: StrictTVar m (FD_ m (TestAddress addr))
fdVar :: StrictTVar m (FD_ m (TestAddress addr))
fdVar }


    openToConnect :: TestAddress addr  -> m (FD m (TestAddress addr))
    openToConnect :: TestAddress addr -> m (FD m (TestAddress addr))
openToConnect TestAddress addr
_ = AddressFamily (TestAddress addr) -> m (FD m (TestAddress addr))
open AddressFamily (TestAddress addr)
forall addr. AddressFamily (TestAddress addr)
TestFamily


    connect :: FD m (TestAddress addr) -> TestAddress addr -> m ()
    connect :: FD m (TestAddress addr) -> TestAddress addr -> m ()
connect fd :: FD m (TestAddress addr)
fd@FD { fdVar :: forall (m :: * -> *) peerAddr.
FD m peerAddr -> StrictTVar m (FD_ m peerAddr)
fdVar = StrictTVar m (FD_ m (TestAddress addr))
fdVarLocal } TestAddress addr
remoteAddress = do
        FD_ m (TestAddress addr)
fd_ <- STM m (FD_ m (TestAddress addr)) -> m (FD_ m (TestAddress addr))
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (StrictTVar m (FD_ m (TestAddress addr))
-> STM m (FD_ m (TestAddress addr))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (FD_ m (TestAddress addr))
fdVarLocal)
        FD m (TestAddress addr)
-> SnocketTrace m (TestAddress addr) -> m ()
traceWith' FD m (TestAddress addr)
fd (FD_ m (TestAddress addr)
-> TestAddress addr -> SnocketTrace m (TestAddress addr)
forall (m :: * -> *) addr.
FD_ m addr -> addr -> SnocketTrace m addr
STConnecting FD_ m (TestAddress addr)
fd_ TestAddress addr
remoteAddress)
        case FD_ m (TestAddress addr)
fd_ of
          -- Mask asynchronous exceptions.  Only unmask when we really block
          -- with using a `threadDelay` or waiting for the connection to be
          -- accepted.
          FDUninitialised Maybe (TestAddress addr)
mbLocalAddr -> ((forall a. m a -> m a) -> m ()) -> m ()
forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
mask (((forall a. m a -> m a) -> m ()) -> m ())
-> ((forall a. m a -> m a) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> m a
unmask -> do
            (ConnectionId (TestAddress addr)
connId, BearerInfo
bearerInfo, OpenType
simOpen) <- STM m (ConnectionId (TestAddress addr), BearerInfo, OpenType)
-> m (ConnectionId (TestAddress addr), BearerInfo, OpenType)
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (ConnectionId (TestAddress addr), BearerInfo, OpenType)
 -> m (ConnectionId (TestAddress addr), BearerInfo, OpenType))
-> STM m (ConnectionId (TestAddress addr), BearerInfo, OpenType)
-> m (ConnectionId (TestAddress addr), BearerInfo, OpenType)
forall a b. (a -> b) -> a -> b
$ do
              TestAddress addr
localAddress <-
                case Maybe (TestAddress addr)
mbLocalAddr of
                  Just TestAddress addr
addr -> TestAddress addr -> STM m (TestAddress addr)
forall (m :: * -> *) a. Monad m => a -> m a
return TestAddress addr
addr
                  Maybe (TestAddress addr)
Nothing   -> NetworkState m (TestAddress addr)
-> AddressType -> STM m (TestAddress addr)
forall (m :: * -> *) addr.
NetworkState m addr -> AddressType -> STM m addr
nsNextEphemeralAddr NetworkState m (TestAddress addr)
state (TestAddress addr -> AddressType
forall addr.
GlobalAddressScheme addr =>
TestAddress addr -> AddressType
getAddressType TestAddress addr
remoteAddress)

              let connId :: ConnectionId (TestAddress addr)
connId = ConnectionId :: forall addr. addr -> addr -> ConnectionId addr
ConnectionId { TestAddress addr
localAddress :: TestAddress addr
localAddress :: TestAddress addr
localAddress, TestAddress addr
remoteAddress :: TestAddress addr
remoteAddress :: TestAddress addr
remoteAddress }
                  normalisedId :: NormalisedId (TestAddress addr)
normalisedId = ConnectionId (TestAddress addr) -> NormalisedId (TestAddress addr)
forall addr. Ord addr => ConnectionId addr -> NormalisedId addr
normaliseId ConnectionId (TestAddress addr)
connId

              BearerInfo
bearerInfo <- case NormalisedId (TestAddress addr)
-> Map
     (NormalisedId (TestAddress addr)) (TVar m (Script BearerInfo))
-> Maybe (TVar m (Script BearerInfo))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup NormalisedId (TestAddress addr)
normalisedId (NetworkState m (TestAddress addr)
-> Map
     (NormalisedId (TestAddress addr)) (TVar m (Script BearerInfo))
forall (m :: * -> *) addr.
NetworkState m addr
-> Map (NormalisedId addr) (TVar m (Script BearerInfo))
nsAttenuationMap NetworkState m (TestAddress addr)
state) of
                Maybe (TVar m (Script BearerInfo))
Nothing     -> do
                  BearerInfo -> STM m BearerInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (NetworkState m (TestAddress addr) -> BearerInfo
forall (m :: * -> *) addr. NetworkState m addr -> BearerInfo
nsDefaultBearerInfo NetworkState m (TestAddress addr)
state)

                Just TVar m (Script BearerInfo)
script -> TVar m (Script BearerInfo) -> STM m BearerInfo
forall (m :: * -> *) a. MonadSTM m => TVar m (Script a) -> STM m a
stepScriptSTM TVar m (Script BearerInfo)
script

              Map
  (NormalisedId (TestAddress addr)) (Connection m (TestAddress addr))
connMap <- StrictTVar
  m
  (Map
     (NormalisedId (TestAddress addr))
     (Connection m (TestAddress addr)))
-> STM
     m
     (Map
        (NormalisedId (TestAddress addr))
        (Connection m (TestAddress addr)))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (NetworkState m (TestAddress addr)
-> StrictTVar
     m
     (Map
        (NormalisedId (TestAddress addr))
        (Connection m (TestAddress addr)))
forall (m :: * -> *) addr.
NetworkState m addr
-> StrictTVar m (Map (NormalisedId addr) (Connection m addr))
nsConnections NetworkState m (TestAddress addr)
state)
              case NormalisedId (TestAddress addr)
-> Map
     (NormalisedId (TestAddress addr)) (Connection m (TestAddress addr))
-> Maybe (Connection m (TestAddress addr))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup NormalisedId (TestAddress addr)
normalisedId Map
  (NormalisedId (TestAddress addr)) (Connection m (TestAddress addr))
connMap of
                Just      Connection { connState :: forall (m :: * -> *) addr. Connection m addr -> ConnectionState
connState = ConnectionState
ESTABLISHED } ->
                  IOError
-> STM m (ConnectionId (TestAddress addr), BearerInfo, OpenType)
forall (m :: * -> *) e a.
(MonadSTM m, MonadThrow (STM m), Exception e) =>
e -> STM m a
throwSTM (FD_ m (TestAddress addr) -> IOError
connectedIOError FD_ m (TestAddress addr)
fd_)

                -- simultaneous open
                Just conn :: Connection m (TestAddress addr)
conn@Connection { connState :: forall (m :: * -> *) addr. Connection m addr -> ConnectionState
connState = ConnectionState
SYN_SENT } -> do
                  let conn' :: Connection m (TestAddress addr)
conn' = Connection m (TestAddress addr)
conn { connState :: ConnectionState
connState = ConnectionState
ESTABLISHED }
                  StrictTVar m (FD_ m (TestAddress addr))
-> FD_ m (TestAddress addr) -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (FD_ m (TestAddress addr))
fdVarLocal (ConnectionId (TestAddress addr)
-> Connection m (TestAddress addr) -> FD_ m (TestAddress addr)
forall (m :: * -> *) addr.
ConnectionId addr -> Connection m addr -> FD_ m addr
FDConnecting ConnectionId (TestAddress addr)
connId Connection m (TestAddress addr)
conn')
                  StrictTVar
  m
  (Map
     (NormalisedId (TestAddress addr))
     (Connection m (TestAddress addr)))
-> (Map
      (NormalisedId (TestAddress addr)) (Connection m (TestAddress addr))
    -> Map
         (NormalisedId (TestAddress addr))
         (Connection m (TestAddress addr)))
-> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar (NetworkState m (TestAddress addr)
-> StrictTVar
     m
     (Map
        (NormalisedId (TestAddress addr))
        (Connection m (TestAddress addr)))
forall (m :: * -> *) addr.
NetworkState m addr
-> StrictTVar m (Map (NormalisedId addr) (Connection m addr))
nsConnections NetworkState m (TestAddress addr)
state)
                             ((Connection m (TestAddress addr)
 -> Connection m (TestAddress addr))
-> NormalisedId (TestAddress addr)
-> Map
     (NormalisedId (TestAddress addr)) (Connection m (TestAddress addr))
-> Map
     (NormalisedId (TestAddress addr)) (Connection m (TestAddress addr))
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust (Connection m (TestAddress addr)
-> Connection m (TestAddress addr)
-> Connection m (TestAddress addr)
forall a b. a -> b -> a
const Connection m (TestAddress addr)
conn')
                                         (ConnectionId (TestAddress addr) -> NormalisedId (TestAddress addr)
forall addr. Ord addr => ConnectionId addr -> NormalisedId addr
normaliseId ConnectionId (TestAddress addr)
connId))
                  (ConnectionId (TestAddress addr), BearerInfo, OpenType)
-> STM m (ConnectionId (TestAddress addr), BearerInfo, OpenType)
forall (m :: * -> *) a. Monad m => a -> m a
return (ConnectionId (TestAddress addr)
connId, BearerInfo
bearerInfo, OpenType
SimOpen)

                Just Connection { connState :: forall (m :: * -> *) addr. Connection m addr -> ConnectionState
connState = ConnectionState
FIN } ->
                  IOError
-> STM m (ConnectionId (TestAddress addr), BearerInfo, OpenType)
forall (m :: * -> *) e a.
(MonadSTM m, MonadThrow (STM m), Exception e) =>
e -> STM m a
throwSTM (FD_ m (TestAddress addr) -> IOError
connectedIOError FD_ m (TestAddress addr)
fd_)

                Maybe (Connection m (TestAddress addr))
Nothing -> do
                  Connection m (TestAddress addr)
conn <- Tracer
  m (WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr)))
-> BearerInfo
-> ConnectionId (TestAddress addr)
-> STM m (Connection m (TestAddress addr))
forall (m :: * -> *) addr.
(MonadLabelledSTM m, MonadTime m, MonadTimer m, MonadThrow m,
 MonadThrow (STM m)) =>
Tracer
  m (WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr)))
-> BearerInfo
-> ConnectionId (TestAddress addr)
-> STM m (Connection m (TestAddress addr))
mkConnection Tracer
  m (WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr)))
tr BearerInfo
bearerInfo ConnectionId (TestAddress addr)
connId
                  StrictTVar m (FD_ m (TestAddress addr))
-> FD_ m (TestAddress addr) -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (FD_ m (TestAddress addr))
fdVarLocal (ConnectionId (TestAddress addr)
-> Connection m (TestAddress addr) -> FD_ m (TestAddress addr)
forall (m :: * -> *) addr.
ConnectionId addr -> Connection m addr -> FD_ m addr
FDConnecting ConnectionId (TestAddress addr)
connId Connection m (TestAddress addr)
conn)
                  StrictTVar
  m
  (Map
     (NormalisedId (TestAddress addr))
     (Connection m (TestAddress addr)))
-> (Map
      (NormalisedId (TestAddress addr)) (Connection m (TestAddress addr))
    -> Map
         (NormalisedId (TestAddress addr))
         (Connection m (TestAddress addr)))
-> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar (NetworkState m (TestAddress addr)
-> StrictTVar
     m
     (Map
        (NormalisedId (TestAddress addr))
        (Connection m (TestAddress addr)))
forall (m :: * -> *) addr.
NetworkState m addr
-> StrictTVar m (Map (NormalisedId addr) (Connection m addr))
nsConnections NetworkState m (TestAddress addr)
state)
                             (NormalisedId (TestAddress addr)
-> Connection m (TestAddress addr)
-> Map
     (NormalisedId (TestAddress addr)) (Connection m (TestAddress addr))
-> Map
     (NormalisedId (TestAddress addr)) (Connection m (TestAddress addr))
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (ConnectionId (TestAddress addr) -> NormalisedId (TestAddress addr)
forall addr. Ord addr => ConnectionId addr -> NormalisedId addr
normaliseId ConnectionId (TestAddress addr)
connId)
                                         (Connection m (TestAddress addr) -> Connection m (TestAddress addr)
forall (m :: * -> *) addr. Connection m addr -> Connection m addr
dualConnection Connection m (TestAddress addr)
conn))
                  -- so far it looks like normal open, it still might turn up
                  -- a simultaneous open if the other side will open the
                  -- connection before it would be put on its accept loop
                  (ConnectionId (TestAddress addr), BearerInfo, OpenType)
-> STM m (ConnectionId (TestAddress addr), BearerInfo, OpenType)
forall (m :: * -> *) a. Monad m => a -> m a
return (ConnectionId (TestAddress addr)
connId, BearerInfo
bearerInfo, OpenType
NormalOpen)

            Tracer
  m (WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr)))
-> WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr))
-> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer
  m (WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr)))
tr (Maybe (TestAddress addr)
-> Maybe (TestAddress addr)
-> SnocketTrace m (TestAddress addr)
-> WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr))
forall addr event.
Maybe addr -> Maybe addr -> event -> WithAddr addr event
WithAddr (TestAddress addr -> Maybe (TestAddress addr)
forall a. a -> Maybe a
Just (ConnectionId (TestAddress addr) -> TestAddress addr
forall addr. ConnectionId addr -> addr
localAddress ConnectionId (TestAddress addr)
connId))
                                   (TestAddress addr -> Maybe (TestAddress addr)
forall a. a -> Maybe a
Just TestAddress addr
remoteAddress)
                                   (BearerInfo -> SnocketTrace m (TestAddress addr)
forall (m :: * -> *) addr. BearerInfo -> SnocketTrace m addr
STBearerInfo BearerInfo
bearerInfo))
            -- connection delay
            --
            -- We need a way for a node to detect if the other end failed so
            -- we keep an eye on the network state while waiting the full amount
            -- of connection delay
            -- TODO: Improve this see #3628
            TVar m Bool
connDelayTimeoutVar <-
              DiffTime -> m (TVar m Bool)
forall (m :: * -> *). MonadTimer m => DiffTime -> m (TVar m Bool)
registerDelay (BearerInfo -> DiffTime
biConnectionDelay BearerInfo
bearerInfo DiffTime -> DiffTime -> DiffTime
forall a. Ord a => a -> a -> a
`min` DiffTime
connectTimeout)
            m () -> m ()
forall a. m a -> m a
unmask
              (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
$ FirstToFinish (STM m) () -> STM m ()
forall (m :: * -> *) a. FirstToFinish m a -> m a
runFirstToFinish (FirstToFinish (STM m) () -> STM m ())
-> FirstToFinish (STM m) () -> STM m ()
forall a b. (a -> b) -> a -> b
$
                  STM m () -> FirstToFinish (STM m) ()
forall (m :: * -> *) a. m a -> FirstToFinish m a
FirstToFinish
                    (TVar m Bool -> STM m Bool
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
LazySTM.readTVar TVar m Bool
connDelayTimeoutVar STM m Bool -> (Bool -> STM m ()) -> STM m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> STM m ()
forall (m :: * -> *). MonadSTM m => Bool -> STM m ()
check)
                  FirstToFinish (STM m) ()
-> FirstToFinish (STM m) () -> FirstToFinish (STM m) ()
forall a. Semigroup a => a -> a -> a
<>
                  STM m () -> FirstToFinish (STM m) ()
forall (m :: * -> *) a. m a -> FirstToFinish m a
FirstToFinish (do
                    Bool
b <- Bool -> Bool
not (Bool -> Bool)
-> (Map
      (NormalisedId (TestAddress addr)) (Connection m (TestAddress addr))
    -> Bool)
-> Map
     (NormalisedId (TestAddress addr)) (Connection m (TestAddress addr))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NormalisedId (TestAddress addr)
-> Map
     (NormalisedId (TestAddress addr)) (Connection m (TestAddress addr))
-> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member (ConnectionId (TestAddress addr) -> NormalisedId (TestAddress addr)
forall addr. Ord addr => ConnectionId addr -> NormalisedId addr
normaliseId ConnectionId (TestAddress addr)
connId)
                      (Map
   (NormalisedId (TestAddress addr)) (Connection m (TestAddress addr))
 -> Bool)
-> STM
     m
     (Map
        (NormalisedId (TestAddress addr))
        (Connection m (TestAddress addr)))
-> STM m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar
  m
  (Map
     (NormalisedId (TestAddress addr))
     (Connection m (TestAddress addr)))
-> STM
     m
     (Map
        (NormalisedId (TestAddress addr))
        (Connection m (TestAddress addr)))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (NetworkState m (TestAddress addr)
-> StrictTVar
     m
     (Map
        (NormalisedId (TestAddress addr))
        (Connection m (TestAddress addr)))
forall (m :: * -> *) addr.
NetworkState m addr
-> StrictTVar m (Map (NormalisedId addr) (Connection m addr))
nsConnections NetworkState m (TestAddress addr)
state)
                    Bool -> STM m ()
forall (m :: * -> *). MonadSTM m => Bool -> STM m ()
check Bool
b
                    IOError -> STM m ()
forall (m :: * -> *) e a.
(MonadSTM m, MonadThrow (STM m), Exception e) =>
e -> STM m a
throwSTM (IOError -> STM m ()) -> IOError -> STM m ()
forall a b. (a -> b) -> a -> b
$ ConnectionId (TestAddress addr) -> String -> IOError
connectIOError ConnectionId (TestAddress addr)
connId
                             (String -> IOError) -> String -> IOError
forall a b. (a -> b) -> a -> b
$ String
"unknown connection: "
                            String -> ShowS
forall a. [a] -> [a] -> [a]
++ NormalisedId (TestAddress addr) -> String
forall a. Show a => a -> String
show (ConnectionId (TestAddress addr) -> NormalisedId (TestAddress addr)
forall addr. Ord addr => ConnectionId addr -> NormalisedId addr
normaliseId ConnectionId (TestAddress addr)
connId))
              )
              m () -> m () -> m ()
forall (m :: * -> *) a b. MonadCatch m => m a -> m b -> m a
`onException`
                STM m () -> m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (StrictTVar
  m
  (Map
     (NormalisedId (TestAddress addr))
     (Connection m (TestAddress addr)))
-> (Map
      (NormalisedId (TestAddress addr)) (Connection m (TestAddress addr))
    -> Map
         (NormalisedId (TestAddress addr))
         (Connection m (TestAddress addr)))
-> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar (NetworkState m (TestAddress addr)
-> StrictTVar
     m
     (Map
        (NormalisedId (TestAddress addr))
        (Connection m (TestAddress addr)))
forall (m :: * -> *) addr.
NetworkState m addr
-> StrictTVar m (Map (NormalisedId addr) (Connection m addr))
nsConnections NetworkState m (TestAddress addr)
state)
                                       (NormalisedId (TestAddress addr)
-> Map
     (NormalisedId (TestAddress addr)) (Connection m (TestAddress addr))
-> Map
     (NormalisedId (TestAddress addr)) (Connection m (TestAddress addr))
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete (ConnectionId (TestAddress addr) -> NormalisedId (TestAddress addr)
forall addr. Ord addr => ConnectionId addr -> NormalisedId addr
normaliseId ConnectionId (TestAddress addr)
connId)))

            Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BearerInfo -> DiffTime
biConnectionDelay BearerInfo
bearerInfo DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
>= DiffTime
connectTimeout) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
              FD m (TestAddress addr)
-> SnocketTrace m (TestAddress addr) -> m ()
traceWith' FD m (TestAddress addr)
fd (TimeoutDetail -> SnocketTrace m (TestAddress addr)
forall (m :: * -> *) addr. TimeoutDetail -> SnocketTrace m addr
STConnectTimeout TimeoutDetail
WaitingToConnect)
              STM m () -> m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ StrictTVar
  m
  (Map
     (NormalisedId (TestAddress addr))
     (Connection m (TestAddress addr)))
-> (Map
      (NormalisedId (TestAddress addr)) (Connection m (TestAddress addr))
    -> Map
         (NormalisedId (TestAddress addr))
         (Connection m (TestAddress addr)))
-> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar (NetworkState m (TestAddress addr)
-> StrictTVar
     m
     (Map
        (NormalisedId (TestAddress addr))
        (Connection m (TestAddress addr)))
forall (m :: * -> *) addr.
NetworkState m addr
-> StrictTVar m (Map (NormalisedId addr) (Connection m addr))
nsConnections NetworkState m (TestAddress addr)
state)
                                      (NormalisedId (TestAddress addr)
-> Map
     (NormalisedId (TestAddress addr)) (Connection m (TestAddress addr))
-> Map
     (NormalisedId (TestAddress addr)) (Connection m (TestAddress addr))
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete (ConnectionId (TestAddress addr) -> NormalisedId (TestAddress addr)
forall addr. Ord addr => ConnectionId addr -> NormalisedId addr
normaliseId ConnectionId (TestAddress addr)
connId))
              IOError -> m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (ConnectionId (TestAddress addr) -> String -> IOError
connectIOError ConnectionId (TestAddress addr)
connId String
"connect timeout: when connecting")

            Either IOError (FD_ m (TestAddress addr), OpenType)
efd <- STM m (Either IOError (FD_ m (TestAddress addr), OpenType))
-> m (Either IOError (FD_ m (TestAddress addr), OpenType))
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Either IOError (FD_ m (TestAddress addr), OpenType))
 -> m (Either IOError (FD_ m (TestAddress addr), OpenType)))
-> STM m (Either IOError (FD_ m (TestAddress addr), OpenType))
-> m (Either IOError (FD_ m (TestAddress addr), OpenType))
forall a b. (a -> b) -> a -> b
$ do
              Map (TestAddress addr) (FD m (TestAddress addr))
lstMap <- StrictTVar m (Map (TestAddress addr) (FD m (TestAddress addr)))
-> STM m (Map (TestAddress addr) (FD m (TestAddress addr)))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (NetworkState m (TestAddress addr)
-> StrictTVar m (Map (TestAddress addr) (FD m (TestAddress addr)))
forall (m :: * -> *) addr.
NetworkState m addr -> StrictTVar m (Map addr (FD m addr))
nsListeningFDs NetworkState m (TestAddress addr)
state)
              Maybe (FD_ m (TestAddress addr))
lstFd  <- (FD m (TestAddress addr) -> STM m (FD_ m (TestAddress addr)))
-> Maybe (FD m (TestAddress addr))
-> STM m (Maybe (FD_ m (TestAddress addr)))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (StrictTVar m (FD_ m (TestAddress addr))
-> STM m (FD_ m (TestAddress addr))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (StrictTVar m (FD_ m (TestAddress addr))
 -> STM m (FD_ m (TestAddress addr)))
-> (FD m (TestAddress addr)
    -> StrictTVar m (FD_ m (TestAddress addr)))
-> FD m (TestAddress addr)
-> STM m (FD_ m (TestAddress addr))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FD m (TestAddress addr) -> StrictTVar m (FD_ m (TestAddress addr))
forall (m :: * -> *) peerAddr.
FD m peerAddr -> StrictTVar m (FD_ m peerAddr)
fdVar)
                                 (TestAddress addr
-> Map (TestAddress addr) (FD m (TestAddress addr))
-> Maybe (FD m (TestAddress addr))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TestAddress addr
remoteAddress Map (TestAddress addr) (FD m (TestAddress addr))
lstMap)
              Maybe (Connection m (TestAddress addr))
mConn  <- NormalisedId (TestAddress addr)
-> Map
     (NormalisedId (TestAddress addr)) (Connection m (TestAddress addr))
-> Maybe (Connection m (TestAddress addr))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (ConnectionId (TestAddress addr) -> NormalisedId (TestAddress addr)
forall addr. Ord addr => ConnectionId addr -> NormalisedId addr
normaliseId ConnectionId (TestAddress addr)
connId)
                    (Map
   (NormalisedId (TestAddress addr)) (Connection m (TestAddress addr))
 -> Maybe (Connection m (TestAddress addr)))
-> STM
     m
     (Map
        (NormalisedId (TestAddress addr))
        (Connection m (TestAddress addr)))
-> STM m (Maybe (Connection m (TestAddress addr)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar
  m
  (Map
     (NormalisedId (TestAddress addr))
     (Connection m (TestAddress addr)))
-> STM
     m
     (Map
        (NormalisedId (TestAddress addr))
        (Connection m (TestAddress addr)))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (NetworkState m (TestAddress addr)
-> StrictTVar
     m
     (Map
        (NormalisedId (TestAddress addr))
        (Connection m (TestAddress addr)))
forall (m :: * -> *) addr.
NetworkState m addr
-> StrictTVar m (Map (NormalisedId addr) (Connection m addr))
nsConnections NetworkState m (TestAddress addr)
state)
              case Maybe (FD_ m (TestAddress addr))
lstFd of
                -- error cases
                (Maybe (FD_ m (TestAddress addr))
Nothing) ->
                  Either IOError (FD_ m (TestAddress addr), OpenType)
-> STM m (Either IOError (FD_ m (TestAddress addr), OpenType))
forall (m :: * -> *) a. Monad m => a -> m a
return (IOError -> Either IOError (FD_ m (TestAddress addr), OpenType)
forall a b. a -> Either a b
Left (ConnectionId (TestAddress addr) -> String -> IOError
connectIOError ConnectionId (TestAddress addr)
connId String
"no such listening socket"))
                (Just FDUninitialised {}) ->
                  Either IOError (FD_ m (TestAddress addr), OpenType)
-> STM m (Either IOError (FD_ m (TestAddress addr), OpenType))
forall (m :: * -> *) a. Monad m => a -> m a
return (IOError -> Either IOError (FD_ m (TestAddress addr), OpenType)
forall a b. a -> Either a b
Left (ConnectionId (TestAddress addr) -> String -> IOError
connectIOError ConnectionId (TestAddress addr)
connId String
"unitialised listening socket"))
                (Just FDConnecting {}) ->
                  Either IOError (FD_ m (TestAddress addr), OpenType)
-> STM m (Either IOError (FD_ m (TestAddress addr), OpenType))
forall (m :: * -> *) a. Monad m => a -> m a
return (IOError -> Either IOError (FD_ m (TestAddress addr), OpenType)
forall a b. a -> Either a b
Left (FD_ m (TestAddress addr) -> IOError
invalidError FD_ m (TestAddress addr)
fd_))
                (Just FDConnected {}) ->
                  Either IOError (FD_ m (TestAddress addr), OpenType)
-> STM m (Either IOError (FD_ m (TestAddress addr), OpenType))
forall (m :: * -> *) a. Monad m => a -> m a
return (IOError -> Either IOError (FD_ m (TestAddress addr), OpenType)
forall a b. a -> Either a b
Left (ConnectionId (TestAddress addr) -> String -> IOError
connectIOError ConnectionId (TestAddress addr)
connId String
"not a listening socket"))
                (Just FDClosed {}) ->
                  Either IOError (FD_ m (TestAddress addr), OpenType)
-> STM m (Either IOError (FD_ m (TestAddress addr), OpenType))
forall (m :: * -> *) a. Monad m => a -> m a
return (IOError -> Either IOError (FD_ m (TestAddress addr), OpenType)
forall a b. a -> Either a b
Left IOError
notConnectedIOError)

                (Just (FDListening TestAddress addr
_ TBQueue m (ChannelWithInfo m (TestAddress addr))
queue)) -> do
                  case Maybe (Connection m (TestAddress addr))
mConn of
                    -- simultaneous open: this handles both cases: either we or
                    -- the remote side opened it late but before being able to
                    -- accept it.  In the later case we need to use
                    -- 'dualConnection'.
                    Just conn :: Connection m (TestAddress addr)
conn@Connection { connState :: forall (m :: * -> *) addr. Connection m addr -> ConnectionState
connState = ConnectionState
ESTABLISHED } -> do
                      let fd_' :: FD_ m (TestAddress addr)
fd_' = ConnectionId (TestAddress addr)
-> Connection m (TestAddress addr) -> FD_ m (TestAddress addr)
forall (m :: * -> *) addr.
ConnectionId addr -> Connection m addr -> FD_ m addr
FDConnected ConnectionId (TestAddress addr)
connId
                               (Connection m (TestAddress addr) -> FD_ m (TestAddress addr))
-> Connection m (TestAddress addr) -> FD_ m (TestAddress addr)
forall a b. (a -> b) -> a -> b
$ case OpenType
simOpen of
                                   OpenType
SimOpen    -> Connection m (TestAddress addr) -> Connection m (TestAddress addr)
forall (m :: * -> *) addr. Connection m addr -> Connection m addr
dualConnection Connection m (TestAddress addr)
conn
                                   OpenType
NormalOpen ->                Connection m (TestAddress addr)
conn
                      StrictTVar m (FD_ m (TestAddress addr))
-> FD_ m (TestAddress addr) -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (FD_ m (TestAddress addr))
fdVarLocal FD_ m (TestAddress addr)
fd_'
                      Either IOError (FD_ m (TestAddress addr), OpenType)
-> STM m (Either IOError (FD_ m (TestAddress addr), OpenType))
forall (m :: * -> *) a. Monad m => a -> m a
return ((FD_ m (TestAddress addr), OpenType)
-> Either IOError (FD_ m (TestAddress addr), OpenType)
forall a b. b -> Either a b
Right (FD_ m (TestAddress addr)
fd_', OpenType
SimOpen))

                    -- normal open: at this stage the other side did not open
                    -- a connection, we add 'ChannelWithInfo' into accept loop.
                    Just conn :: Connection m (TestAddress addr)
conn@Connection { connState :: forall (m :: * -> *) addr. Connection m addr -> ConnectionState
connState = ConnectionState
SYN_SENT } -> do
                      let fd_' :: FD_ m (TestAddress addr)
fd_' = ConnectionId (TestAddress addr)
-> Connection m (TestAddress addr) -> FD_ m (TestAddress addr)
forall (m :: * -> *) addr.
ConnectionId addr -> Connection m addr -> FD_ m addr
FDConnected ConnectionId (TestAddress addr)
connId Connection m (TestAddress addr)
conn
                      StrictTVar m (FD_ m (TestAddress addr))
-> FD_ m (TestAddress addr) -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (FD_ m (TestAddress addr))
fdVarLocal FD_ m (TestAddress addr)
fd_'
                      TBQueue m (ChannelWithInfo m (TestAddress addr))
-> ChannelWithInfo m (TestAddress addr) -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TBQueue m a -> a -> STM m ()
writeTBQueue TBQueue m (ChannelWithInfo m (TestAddress addr))
queue
                                   ChannelWithInfo :: forall (m :: * -> *) addr.
addr
-> SDUSize
-> AttenuatedChannel m
-> AttenuatedChannel m
-> ChannelWithInfo m addr
ChannelWithInfo
                                     { cwiAddress :: TestAddress addr
cwiAddress       = ConnectionId (TestAddress addr) -> TestAddress addr
forall addr. ConnectionId addr -> addr
localAddress ConnectionId (TestAddress addr)
connId
                                     , cwiSDUSize :: SDUSize
cwiSDUSize       = BearerInfo -> SDUSize
biSDUSize BearerInfo
bearerInfo
                                     , cwiChannelLocal :: AttenuatedChannel m
cwiChannelLocal  = Connection m (TestAddress addr) -> AttenuatedChannel m
forall (m :: * -> *) addr. Connection m addr -> AttenuatedChannel m
connChannelRemote Connection m (TestAddress addr)
conn
                                     , cwiChannelRemote :: AttenuatedChannel m
cwiChannelRemote = Connection m (TestAddress addr) -> AttenuatedChannel m
forall (m :: * -> *) addr. Connection m addr -> AttenuatedChannel m
connChannelLocal Connection m (TestAddress addr)
conn
                                     }
                      Either IOError (FD_ m (TestAddress addr), OpenType)
-> STM m (Either IOError (FD_ m (TestAddress addr), OpenType))
forall (m :: * -> *) a. Monad m => a -> m a
return ((FD_ m (TestAddress addr), OpenType)
-> Either IOError (FD_ m (TestAddress addr), OpenType)
forall a b. b -> Either a b
Right (FD_ m (TestAddress addr)
fd_', OpenType
NormalOpen))

                    Just Connection { connState :: forall (m :: * -> *) addr. Connection m addr -> ConnectionState
connState = ConnectionState
FIN } -> do
                      Either IOError (FD_ m (TestAddress addr), OpenType)
-> STM m (Either IOError (FD_ m (TestAddress addr), OpenType))
forall (m :: * -> *) a. Monad m => a -> m a
return (IOError -> Either IOError (FD_ m (TestAddress addr), OpenType)
forall a b. a -> Either a b
Left (ConnectionId (TestAddress addr) -> String -> IOError
connectIOError ConnectionId (TestAddress addr)
connId String
"connect error (FIN)"))

                    Maybe (Connection m (TestAddress addr))
Nothing ->
                      Either IOError (FD_ m (TestAddress addr), OpenType)
-> STM m (Either IOError (FD_ m (TestAddress addr), OpenType))
forall (m :: * -> *) a. Monad m => a -> m a
return (IOError -> Either IOError (FD_ m (TestAddress addr), OpenType)
forall a b. a -> Either a b
Left (ConnectionId (TestAddress addr) -> String -> IOError
connectIOError ConnectionId (TestAddress addr)
connId String
"connect error"))

            case Either IOError (FD_ m (TestAddress addr), OpenType)
efd of
              Left IOError
e          -> do
                FD m (TestAddress addr)
-> SnocketTrace m (TestAddress addr) -> m ()
traceWith' FD m (TestAddress addr)
fd (FD_ m (TestAddress addr)
-> TestAddress addr -> IOError -> SnocketTrace m (TestAddress addr)
forall (m :: * -> *) addr.
FD_ m addr -> addr -> IOError -> SnocketTrace m addr
STConnectError FD_ m (TestAddress addr)
fd_ TestAddress addr
remoteAddress IOError
e)
                STM m () -> m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ StrictTVar
  m
  (Map
     (NormalisedId (TestAddress addr))
     (Connection m (TestAddress addr)))
-> (Map
      (NormalisedId (TestAddress addr)) (Connection m (TestAddress addr))
    -> Map
         (NormalisedId (TestAddress addr))
         (Connection m (TestAddress addr)))
-> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar (NetworkState m (TestAddress addr)
-> StrictTVar
     m
     (Map
        (NormalisedId (TestAddress addr))
        (Connection m (TestAddress addr)))
forall (m :: * -> *) addr.
NetworkState m addr
-> StrictTVar m (Map (NormalisedId addr) (Connection m addr))
nsConnections NetworkState m (TestAddress addr)
state)
                                        (NormalisedId (TestAddress addr)
-> Map
     (NormalisedId (TestAddress addr)) (Connection m (TestAddress addr))
-> Map
     (NormalisedId (TestAddress addr)) (Connection m (TestAddress addr))
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete (ConnectionId (TestAddress addr) -> NormalisedId (TestAddress addr)
forall addr. Ord addr => ConnectionId addr -> NormalisedId addr
normaliseId ConnectionId (TestAddress addr)
connId))
                IOError -> m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO IOError
e
              Right (FD_ m (TestAddress addr)
fd_', OpenType
o) -> do
                -- successful open

                -- wait for a connection to be accepted; we can also be
                -- interrupted by an asynchronous exception in which case we
                -- just forget about the connection.
                TVar m Bool
timeoutVar <-
                  DiffTime -> m (TVar m Bool)
forall (m :: * -> *). MonadTimer m => DiffTime -> m (TVar m Bool)
registerDelay (DiffTime
connectTimeout DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
- BearerInfo -> DiffTime
biConnectionDelay BearerInfo
bearerInfo)
                Maybe ()
r <-
                  (SomeException -> Maybe SomeException)
-> (SomeException -> m (Maybe ())) -> m (Maybe ()) -> m (Maybe ())
forall (m :: * -> *) e b a.
(MonadCatch m, Exception e) =>
(e -> Maybe b) -> (b -> m a) -> m a -> m a
handleJust
                    (\SomeException
e -> case SomeException -> Maybe SomeAsyncException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
                             Just SomeAsyncException {} -> SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just SomeException
e
                             Maybe SomeAsyncException
Nothing                    -> Maybe SomeException
forall a. Maybe a
Nothing)
                    (\SomeException
e -> STM m (Maybe ()) -> m (Maybe ())
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Maybe ()) -> m (Maybe ()))
-> STM m (Maybe ()) -> m (Maybe ())
forall a b. (a -> b) -> a -> b
$ StrictTVar
  m
  (Map
     (NormalisedId (TestAddress addr))
     (Connection m (TestAddress addr)))
-> (Map
      (NormalisedId (TestAddress addr)) (Connection m (TestAddress addr))
    -> Map
         (NormalisedId (TestAddress addr))
         (Connection m (TestAddress addr)))
-> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar (NetworkState m (TestAddress addr)
-> StrictTVar
     m
     (Map
        (NormalisedId (TestAddress addr))
        (Connection m (TestAddress addr)))
forall (m :: * -> *) addr.
NetworkState m addr
-> StrictTVar m (Map (NormalisedId addr) (Connection m addr))
nsConnections NetworkState m (TestAddress addr)
state)
                                                   (NormalisedId (TestAddress addr)
-> Map
     (NormalisedId (TestAddress addr)) (Connection m (TestAddress addr))
-> Map
     (NormalisedId (TestAddress addr)) (Connection m (TestAddress addr))
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete (ConnectionId (TestAddress addr) -> NormalisedId (TestAddress addr)
forall addr. Ord addr => ConnectionId addr -> NormalisedId addr
normaliseId ConnectionId (TestAddress addr)
connId))
                        STM m () -> STM m (Maybe ()) -> STM m (Maybe ())
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SomeException -> STM m (Maybe ())
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO SomeException
e)
                    (m (Maybe ()) -> m (Maybe ())) -> m (Maybe ()) -> m (Maybe ())
forall a b. (a -> b) -> a -> b
$ m (Maybe ()) -> m (Maybe ())
forall a. m a -> m a
unmask (STM m (Maybe ()) -> m (Maybe ())
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Maybe ()) -> m (Maybe ()))
-> STM m (Maybe ()) -> m (Maybe ())
forall a b. (a -> b) -> a -> b
$ FirstToFinish (STM m) (Maybe ()) -> STM m (Maybe ())
forall (m :: * -> *) a. FirstToFinish m a -> m a
runFirstToFinish (FirstToFinish (STM m) (Maybe ()) -> STM m (Maybe ()))
-> FirstToFinish (STM m) (Maybe ()) -> STM m (Maybe ())
forall a b. (a -> b) -> a -> b
$
                        (STM m (Maybe ()) -> FirstToFinish (STM m) (Maybe ())
forall (m :: * -> *) a. m a -> FirstToFinish m a
FirstToFinish (STM m (Maybe ()) -> FirstToFinish (STM m) (Maybe ()))
-> STM m (Maybe ()) -> FirstToFinish (STM m) (Maybe ())
forall a b. (a -> b) -> a -> b
$ do
                          TVar m Bool -> STM m Bool
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
LazySTM.readTVar TVar m Bool
timeoutVar STM m Bool -> (Bool -> STM m ()) -> STM m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> STM m ()
forall (m :: * -> *). MonadSTM m => Bool -> STM m ()
check
                          StrictTVar
  m
  (Map
     (NormalisedId (TestAddress addr))
     (Connection m (TestAddress addr)))
-> (Map
      (NormalisedId (TestAddress addr)) (Connection m (TestAddress addr))
    -> Map
         (NormalisedId (TestAddress addr))
         (Connection m (TestAddress addr)))
-> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar (NetworkState m (TestAddress addr)
-> StrictTVar
     m
     (Map
        (NormalisedId (TestAddress addr))
        (Connection m (TestAddress addr)))
forall (m :: * -> *) addr.
NetworkState m addr
-> StrictTVar m (Map (NormalisedId addr) (Connection m addr))
nsConnections NetworkState m (TestAddress addr)
state)
                                     (NormalisedId (TestAddress addr)
-> Map
     (NormalisedId (TestAddress addr)) (Connection m (TestAddress addr))
-> Map
     (NormalisedId (TestAddress addr)) (Connection m (TestAddress addr))
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete (ConnectionId (TestAddress addr) -> NormalisedId (TestAddress addr)
forall addr. Ord addr => ConnectionId addr -> NormalisedId addr
normaliseId ConnectionId (TestAddress addr)
connId))
                          Maybe () -> STM m (Maybe ())
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ()
forall a. Maybe a
Nothing
                        )
                        FirstToFinish (STM m) (Maybe ())
-> FirstToFinish (STM m) (Maybe ())
-> FirstToFinish (STM m) (Maybe ())
forall a. Semigroup a => a -> a -> a
<>
                        (STM m (Maybe ()) -> FirstToFinish (STM m) (Maybe ())
forall (m :: * -> *) a. m a -> FirstToFinish m a
FirstToFinish (STM m (Maybe ()) -> FirstToFinish (STM m) (Maybe ()))
-> STM m (Maybe ()) -> FirstToFinish (STM m) (Maybe ())
forall a b. (a -> b) -> a -> b
$ do
                          Maybe (Connection m (TestAddress addr))
mbConn <- NormalisedId (TestAddress addr)
-> Map
     (NormalisedId (TestAddress addr)) (Connection m (TestAddress addr))
-> Maybe (Connection m (TestAddress addr))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (ConnectionId (TestAddress addr) -> NormalisedId (TestAddress addr)
forall addr. Ord addr => ConnectionId addr -> NormalisedId addr
normaliseId ConnectionId (TestAddress addr)
connId)
                                (Map
   (NormalisedId (TestAddress addr)) (Connection m (TestAddress addr))
 -> Maybe (Connection m (TestAddress addr)))
-> STM
     m
     (Map
        (NormalisedId (TestAddress addr))
        (Connection m (TestAddress addr)))
-> STM m (Maybe (Connection m (TestAddress addr)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar
  m
  (Map
     (NormalisedId (TestAddress addr))
     (Connection m (TestAddress addr)))
-> STM
     m
     (Map
        (NormalisedId (TestAddress addr))
        (Connection m (TestAddress addr)))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (NetworkState m (TestAddress addr)
-> StrictTVar
     m
     (Map
        (NormalisedId (TestAddress addr))
        (Connection m (TestAddress addr)))
forall (m :: * -> *) addr.
NetworkState m addr
-> StrictTVar m (Map (NormalisedId addr) (Connection m addr))
nsConnections NetworkState m (TestAddress addr)
state)
                          case Maybe (Connection m (TestAddress addr))
mbConn of
                            -- it could happen that the 'accept' removes the
                            -- connection from the state; we treat this as an io
                            -- exception.
                            Maybe (Connection m (TestAddress addr))
Nothing -> do
                              StrictTVar
  m
  (Map
     (NormalisedId (TestAddress addr))
     (Connection m (TestAddress addr)))
-> (Map
      (NormalisedId (TestAddress addr)) (Connection m (TestAddress addr))
    -> Map
         (NormalisedId (TestAddress addr))
         (Connection m (TestAddress addr)))
-> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar (NetworkState m (TestAddress addr)
-> StrictTVar
     m
     (Map
        (NormalisedId (TestAddress addr))
        (Connection m (TestAddress addr)))
forall (m :: * -> *) addr.
NetworkState m addr
-> StrictTVar m (Map (NormalisedId addr) (Connection m addr))
nsConnections NetworkState m (TestAddress addr)
state)
                                         (NormalisedId (TestAddress addr)
-> Map
     (NormalisedId (TestAddress addr)) (Connection m (TestAddress addr))
-> Map
     (NormalisedId (TestAddress addr)) (Connection m (TestAddress addr))
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete (ConnectionId (TestAddress addr) -> NormalisedId (TestAddress addr)
forall addr. Ord addr => ConnectionId addr -> NormalisedId addr
normaliseId ConnectionId (TestAddress addr)
connId))
                              IOError -> STM m (Maybe ())
forall (m :: * -> *) e a.
(MonadSTM m, MonadThrow (STM m), Exception e) =>
e -> STM m a
throwSTM (IOError -> STM m (Maybe ())) -> IOError -> STM m (Maybe ())
forall a b. (a -> b) -> a -> b
$ ConnectionId (TestAddress addr) -> String -> IOError
connectIOError ConnectionId (TestAddress addr)
connId
                                       (String -> IOError) -> String -> IOError
forall a b. (a -> b) -> a -> b
$ String
"unknown connection: "
                                      String -> ShowS
forall a. [a] -> [a] -> [a]
++ NormalisedId (TestAddress addr) -> String
forall a. Show a => a -> String
show (ConnectionId (TestAddress addr) -> NormalisedId (TestAddress addr)
forall addr. Ord addr => ConnectionId addr -> NormalisedId addr
normaliseId ConnectionId (TestAddress addr)
connId)
                            Just Connection { ConnectionState
connState :: ConnectionState
connState :: forall (m :: * -> *) addr. Connection m addr -> ConnectionState
connState } ->
                              () -> Maybe ()
forall a. a -> Maybe a
Just (() -> Maybe ()) -> STM m () -> STM m (Maybe ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> STM m ()
forall (m :: * -> *). MonadSTM m => Bool -> STM m ()
check (ConnectionState
connState ConnectionState -> ConnectionState -> Bool
forall a. Eq a => a -> a -> Bool
== ConnectionState
ESTABLISHED))
                       )

                case Maybe ()
r of
                  Maybe ()
Nothing -> do
                    FD m (TestAddress addr)
-> SnocketTrace m (TestAddress addr) -> m ()
traceWith' FD m (TestAddress addr)
fd (TimeoutDetail -> SnocketTrace m (TestAddress addr)
forall (m :: * -> *) addr. TimeoutDetail -> SnocketTrace m addr
STConnectTimeout TimeoutDetail
WaitingToBeAccepted)
                    IOError -> m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (ConnectionId (TestAddress addr) -> String -> IOError
connectIOError ConnectionId (TestAddress addr)
connId String
"connect timeout: when waiting for being accepted")
                  Just ()
_  -> FD m (TestAddress addr)
-> SnocketTrace m (TestAddress addr) -> m ()
traceWith' FD m (TestAddress addr)
fd (FD_ m (TestAddress addr)
-> OpenType -> SnocketTrace m (TestAddress addr)
forall (m :: * -> *) addr.
FD_ m addr -> OpenType -> SnocketTrace m addr
STConnected FD_ m (TestAddress addr)
fd_' OpenType
o)

          FDConnecting {} ->
            IOError -> m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (FD_ m (TestAddress addr) -> IOError
invalidError FD_ m (TestAddress addr)
fd_)

          FDConnected {} ->
            IOError -> m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (FD_ m (TestAddress addr) -> IOError
connectedIOError FD_ m (TestAddress addr)
fd_)

          FDListening {} ->
            IOError -> m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (FD_ m (TestAddress addr) -> IOError
connectedIOError FD_ m (TestAddress addr)
fd_)

          FDClosed {} ->
            IOError -> m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO IOError
notConnectedIOError
      where
        notConnectedIOError :: IOError
notConnectedIOError = IOError :: Maybe Handle
-> IOErrorType
-> String
-> String
-> Maybe CInt
-> Maybe String
-> IOError
IOError
          { ioe_handle :: Maybe Handle
ioe_handle      = Maybe Handle
forall a. Maybe a
Nothing
          , ioe_type :: IOErrorType
ioe_type        = IOErrorType
OtherError
          , ioe_location :: String
ioe_location    = String
"Ouroboros.Network.Snocket.Sim.connect"
          , ioe_description :: String
ioe_description = String
"Transport endpoint is not connected"
          , ioe_errno :: Maybe CInt
ioe_errno       = Maybe CInt
forall a. Maybe a
Nothing
          , ioe_filename :: Maybe String
ioe_filename    = Maybe String
forall a. Maybe a
Nothing
          }

        connectIOError :: ConnectionId (TestAddress addr) -> String -> IOError
        connectIOError :: ConnectionId (TestAddress addr) -> String -> IOError
connectIOError ConnectionId (TestAddress addr)
connId String
desc = IOError :: Maybe Handle
-> IOErrorType
-> String
-> String
-> Maybe CInt
-> Maybe String
-> IOError
IOError
          { ioe_handle :: Maybe Handle
ioe_handle      = Maybe Handle
forall a. Maybe a
Nothing
          , ioe_type :: IOErrorType
ioe_type        = IOErrorType
OtherError
          , ioe_location :: String
ioe_location    = String
"Ouroboros.Network.Snocket.Sim.connect"
          , ioe_description :: String
ioe_description = String -> String -> ShowS
forall r. PrintfType r => String -> r
printf String
"connect failure (%s): (%s)" (ConnectionId (TestAddress addr) -> String
forall a. Show a => a -> String
show ConnectionId (TestAddress addr)
connId) String
desc
          , ioe_errno :: Maybe CInt
ioe_errno       = Maybe CInt
forall a. Maybe a
Nothing
          , ioe_filename :: Maybe String
ioe_filename    = Maybe String
forall a. Maybe a
Nothing
          }

        connectedIOError :: FD_ m (TestAddress addr) -> IOError
        connectedIOError :: FD_ m (TestAddress addr) -> IOError
connectedIOError FD_ m (TestAddress addr)
fd_ = IOError :: Maybe Handle
-> IOErrorType
-> String
-> String
-> Maybe CInt
-> Maybe String
-> IOError
IOError
          { ioe_handle :: Maybe Handle
ioe_handle      = Maybe Handle
forall a. Maybe a
Nothing
          , ioe_type :: IOErrorType
ioe_type        = IOErrorType
AlreadyExists
          , ioe_location :: String
ioe_location    = String
"Ouroboros.Network.Snocket.Sim.connect"
          , ioe_description :: String
ioe_description = String -> ShowS
forall r. PrintfType r => String -> r
printf String
"Transport endpoint (%s) is already connected" (FD_ m (TestAddress addr) -> String
forall a. Show a => a -> String
show FD_ m (TestAddress addr)
fd_)
          , ioe_errno :: Maybe CInt
ioe_errno       = Maybe CInt
forall a. Maybe a
Nothing
          , ioe_filename :: Maybe String
ioe_filename    = Maybe String
forall a. Maybe a
Nothing
          }

        invalidError :: FD_ m (TestAddress addr) -> IOError
        invalidError :: FD_ m (TestAddress addr) -> IOError
invalidError FD_ m (TestAddress addr)
fd_ = IOError :: Maybe Handle
-> IOErrorType
-> String
-> String
-> Maybe CInt
-> Maybe String
-> IOError
IOError
          { ioe_handle :: Maybe Handle
ioe_handle      = Maybe Handle
forall a. Maybe a
Nothing
          , ioe_type :: IOErrorType
ioe_type        = IOErrorType
InvalidArgument
          , ioe_location :: String
ioe_location    = String
"Ouroboros.Network.Snocket.Sim.bind"
          , ioe_description :: String
ioe_description = String -> ShowS
forall r. PrintfType r => String -> r
printf String
"Invalid argument (%s)" (FD_ m (TestAddress addr) -> String
forall a. Show a => a -> String
show FD_ m (TestAddress addr)
fd_)
          , ioe_errno :: Maybe CInt
ioe_errno       = Maybe CInt
forall a. Maybe a
Nothing
          , ioe_filename :: Maybe String
ioe_filename    = Maybe String
forall a. Maybe a
Nothing
          }


    bind :: FD m (TestAddress addr) -> TestAddress addr -> m ()
    bind :: FD m (TestAddress addr) -> TestAddress addr -> m ()
bind fd :: FD m (TestAddress addr)
fd@FD { StrictTVar m (FD_ m (TestAddress addr))
fdVar :: StrictTVar m (FD_ m (TestAddress addr))
fdVar :: forall (m :: * -> *) peerAddr.
FD m peerAddr -> StrictTVar m (FD_ m peerAddr)
fdVar } TestAddress addr
addr = do
        Maybe (FD_ m (TestAddress addr), IOError)
res <- STM m (Maybe (FD_ m (TestAddress addr), IOError))
-> m (Maybe (FD_ m (TestAddress addr), IOError))
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Maybe (FD_ m (TestAddress addr), IOError))
 -> m (Maybe (FD_ m (TestAddress addr), IOError)))
-> STM m (Maybe (FD_ m (TestAddress addr), IOError))
-> m (Maybe (FD_ m (TestAddress addr), IOError))
forall a b. (a -> b) -> a -> b
$ do
          FD_ m (TestAddress addr)
fd_ <- StrictTVar m (FD_ m (TestAddress addr))
-> STM m (FD_ m (TestAddress addr))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (FD_ m (TestAddress addr))
fdVar
          case FD_ m (TestAddress addr)
fd_ of
            FDUninitialised Maybe (TestAddress addr)
Nothing -> do
              StrictTVar m (FD_ m (TestAddress addr))
-> FD_ m (TestAddress addr) -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (FD_ m (TestAddress addr))
fdVar (Maybe (TestAddress addr) -> FD_ m (TestAddress addr)
forall (m :: * -> *) addr. Maybe addr -> FD_ m addr
FDUninitialised (TestAddress addr -> Maybe (TestAddress addr)
forall a. a -> Maybe a
Just TestAddress addr
addr))
              StrictTVar m (FD_ m (TestAddress addr)) -> String -> STM m ()
forall (m :: * -> *) a.
MonadLabelledSTM m =>
StrictTVar m a -> String -> STM m ()
labelTVar StrictTVar m (FD_ m (TestAddress addr))
fdVar (String
"fd-" String -> ShowS
forall a. [a] -> [a] -> [a]
++ TestAddress addr -> String
forall a. Show a => a -> String
show TestAddress addr
addr)
              Maybe (FD_ m (TestAddress addr), IOError)
-> STM m (Maybe (FD_ m (TestAddress addr), IOError))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (FD_ m (TestAddress addr), IOError)
forall a. Maybe a
Nothing
            FD_ m (TestAddress addr)
_ ->
              Maybe (FD_ m (TestAddress addr), IOError)
-> STM m (Maybe (FD_ m (TestAddress addr), IOError))
forall (m :: * -> *) a. Monad m => a -> m a
return ((FD_ m (TestAddress addr), IOError)
-> Maybe (FD_ m (TestAddress addr), IOError)
forall a. a -> Maybe a
Just (FD_ m (TestAddress addr)
fd_, FD_ m (TestAddress addr) -> IOError
forall a. Show a => a -> IOError
invalidError FD_ m (TestAddress addr)
fd_))
        case Maybe (FD_ m (TestAddress addr), IOError)
res of
          Maybe (FD_ m (TestAddress addr), IOError)
Nothing       -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          Just (FD_ m (TestAddress addr)
fd_, IOError
e) -> FD m (TestAddress addr)
-> SnocketTrace m (TestAddress addr) -> m ()
traceWith' FD m (TestAddress addr)
fd (FD_ m (TestAddress addr)
-> TestAddress addr -> IOError -> SnocketTrace m (TestAddress addr)
forall (m :: * -> *) addr.
FD_ m addr -> addr -> IOError -> SnocketTrace m addr
STBindError FD_ m (TestAddress addr)
fd_ TestAddress addr
addr IOError
e)
                        m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IOError -> m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO IOError
e
      where
        invalidError :: a -> IOError
invalidError a
fd_ = IOError :: Maybe Handle
-> IOErrorType
-> String
-> String
-> Maybe CInt
-> Maybe String
-> IOError
IOError
          { ioe_handle :: Maybe Handle
ioe_handle      = Maybe Handle
forall a. Maybe a
Nothing
          , ioe_type :: IOErrorType
ioe_type        = IOErrorType
InvalidArgument
          , ioe_location :: String
ioe_location    = String
"Ouroboros.Network.Snocket.Sim.bind"
          , ioe_description :: String
ioe_description = String -> ShowS
forall r. PrintfType r => String -> r
printf String
"Invalid argument (%s)" (a -> String
forall a. Show a => a -> String
show a
fd_)
          , ioe_errno :: Maybe CInt
ioe_errno       = Maybe CInt
forall a. Maybe a
Nothing
          , ioe_filename :: Maybe String
ioe_filename    = Maybe String
forall a. Maybe a
Nothing
          }


    listen :: FD m (TestAddress addr) -> m ()
    listen :: FD m (TestAddress addr) -> m ()
listen fd :: FD m (TestAddress addr)
fd@FD { StrictTVar m (FD_ m (TestAddress addr))
fdVar :: StrictTVar m (FD_ m (TestAddress addr))
fdVar :: forall (m :: * -> *) peerAddr.
FD m peerAddr -> StrictTVar m (FD_ m peerAddr)
fdVar } = STM m () -> m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        FD_ m (TestAddress addr)
fd_ <- StrictTVar m (FD_ m (TestAddress addr))
-> STM m (FD_ m (TestAddress addr))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (FD_ m (TestAddress addr))
fdVar
        case FD_ m (TestAddress addr)
fd_ of
          FDUninitialised Maybe (TestAddress addr)
Nothing ->
            -- Berkeley socket would not error; but then 'bind' would fail;
            IOError -> STM m ()
forall (m :: * -> *) e a.
(MonadSTM m, MonadThrow (STM m), Exception e) =>
e -> STM m a
throwSTM (IOError -> STM m ()) -> IOError -> STM m ()
forall a b. (a -> b) -> a -> b
$ FD_ m (TestAddress addr) -> IOError
invalidError FD_ m (TestAddress addr)
fd_

          FDUninitialised (Just TestAddress addr
addr) -> do
            TBQueue m (ChannelWithInfo m (TestAddress addr))
queue <- Natural -> STM m (TBQueue m (ChannelWithInfo m (TestAddress addr)))
forall (m :: * -> *) a.
MonadSTM m =>
Natural -> STM m (TBQueue m a)
newTBQueue Natural
bound
            TBQueue m (ChannelWithInfo m (TestAddress addr))
-> String -> STM m ()
forall (m :: * -> *) a.
MonadLabelledSTM m =>
TBQueue m a -> String -> STM m ()
labelTBQueue TBQueue m (ChannelWithInfo m (TestAddress addr))
queue (String
"aq-" String -> ShowS
forall a. [a] -> [a] -> [a]
++ TestAddress addr -> String
forall a. Show a => a -> String
show TestAddress addr
addr)
            StrictTVar m (FD_ m (TestAddress addr))
-> FD_ m (TestAddress addr) -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (FD_ m (TestAddress addr))
fdVar (TestAddress addr
-> TBQueue m (ChannelWithInfo m (TestAddress addr))
-> FD_ m (TestAddress addr)
forall (m :: * -> *) addr.
addr -> TBQueue m (ChannelWithInfo m addr) -> FD_ m addr
FDListening TestAddress addr
addr TBQueue m (ChannelWithInfo m (TestAddress addr))
queue)
            StrictTVar m (Map (TestAddress addr) (FD m (TestAddress addr)))
-> (Map (TestAddress addr) (FD m (TestAddress addr))
    -> Map (TestAddress addr) (FD m (TestAddress addr)))
-> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar (NetworkState m (TestAddress addr)
-> StrictTVar m (Map (TestAddress addr) (FD m (TestAddress addr)))
forall (m :: * -> *) addr.
NetworkState m addr -> StrictTVar m (Map addr (FD m addr))
nsListeningFDs NetworkState m (TestAddress addr)
state) (TestAddress addr
-> FD m (TestAddress addr)
-> Map (TestAddress addr) (FD m (TestAddress addr))
-> Map (TestAddress addr) (FD m (TestAddress addr))
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert TestAddress addr
addr FD m (TestAddress addr)
fd)

          FDConnected {} ->
            IOError -> STM m ()
forall (m :: * -> *) e a.
(MonadSTM m, MonadThrow (STM m), Exception e) =>
e -> STM m a
throwSTM (IOError -> STM m ()) -> IOError -> STM m ()
forall a b. (a -> b) -> a -> b
$ FD_ m (TestAddress addr) -> IOError
invalidError FD_ m (TestAddress addr)
fd_
          FDConnecting {} ->
            IOError -> STM m ()
forall (m :: * -> *) e a.
(MonadSTM m, MonadThrow (STM m), Exception e) =>
e -> STM m a
throwSTM (IOError -> STM m ()) -> IOError -> STM m ()
forall a b. (a -> b) -> a -> b
$ FD_ m (TestAddress addr) -> IOError
invalidError FD_ m (TestAddress addr)
fd_
          FDListening {} ->
            () -> STM m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          FDClosed {} ->
            IOError -> STM m ()
forall (m :: * -> *) e a.
(MonadSTM m, MonadThrow (STM m), Exception e) =>
e -> STM m a
throwSTM (IOError -> STM m ()) -> IOError -> STM m ()
forall a b. (a -> b) -> a -> b
$ FD_ m (TestAddress addr) -> IOError
invalidError FD_ m (TestAddress addr)
fd_
      where
        -- TODO: 'listen' should take this as an explicit argument
        bound :: Natural
        bound :: Natural
bound = Natural
10

        invalidError :: FD_ m (TestAddress addr) -> IOError
        invalidError :: FD_ m (TestAddress addr) -> IOError
invalidError FD_ m (TestAddress addr)
fd_ = IOError :: Maybe Handle
-> IOErrorType
-> String
-> String
-> Maybe CInt
-> Maybe String
-> IOError
IOError
          { ioe_handle :: Maybe Handle
ioe_handle      = Maybe Handle
forall a. Maybe a
Nothing
          , ioe_type :: IOErrorType
ioe_type        = IOErrorType
InvalidArgument
          , ioe_location :: String
ioe_location    = String
"Ouroboros.Network.Snocket.Sim.listen"
          , ioe_description :: String
ioe_description = String -> ShowS
forall r. PrintfType r => String -> r
printf String
"Invalid argument (%s)" (FD_ m (TestAddress addr) -> String
forall a. Show a => a -> String
show FD_ m (TestAddress addr)
fd_)
          , ioe_errno :: Maybe CInt
ioe_errno       = Maybe CInt
forall a. Maybe a
Nothing
          , ioe_filename :: Maybe String
ioe_filename    = Maybe String
forall a. Maybe a
Nothing
          }


    accept :: FD m (TestAddress addr)
           -> m (Accept m (FD m (TestAddress addr))
                                (TestAddress addr))
    accept :: FD m (TestAddress addr)
-> m (Accept m (FD m (TestAddress addr)) (TestAddress addr))
accept FD { StrictTVar m (FD_ m (TestAddress addr))
fdVar :: StrictTVar m (FD_ m (TestAddress addr))
fdVar :: forall (m :: * -> *) peerAddr.
FD m peerAddr -> StrictTVar m (FD_ m peerAddr)
fdVar } = do Time
time <- m Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime
                             let deltaAndIOErr :: Maybe (DiffTime, IOErrType)
deltaAndIOErr =
                                   BearerInfo -> Maybe (DiffTime, IOErrType)
biAcceptFailures (NetworkState m (TestAddress addr) -> BearerInfo
forall (m :: * -> *) addr. NetworkState m addr -> BearerInfo
nsDefaultBearerInfo NetworkState m (TestAddress addr)
state)
                             Accept m (FD m (TestAddress addr)) (TestAddress addr)
-> m (Accept m (FD m (TestAddress addr)) (TestAddress addr))
forall (m :: * -> *) a. Monad m => a -> m a
return (Accept m (FD m (TestAddress addr)) (TestAddress addr)
 -> m (Accept m (FD m (TestAddress addr)) (TestAddress addr)))
-> Accept m (FD m (TestAddress addr)) (TestAddress addr)
-> m (Accept m (FD m (TestAddress addr)) (TestAddress addr))
forall a b. (a -> b) -> a -> b
$ Time
-> Maybe (DiffTime, IOErrType)
-> Accept m (FD m (TestAddress addr)) (TestAddress addr)
accept_ Time
time Maybe (DiffTime, IOErrType)
deltaAndIOErr
      where
        -- non-blocking; return 'True' if a connection is in 'SYN_SENT' state
        synSent :: TestAddress addr
                -> ChannelWithInfo m (TestAddress addr)
                -> STM m Bool
        synSent :: TestAddress addr
-> ChannelWithInfo m (TestAddress addr) -> STM m Bool
synSent TestAddress addr
localAddress ChannelWithInfo m (TestAddress addr)
cwi = do
          Map
  (NormalisedId (TestAddress addr)) (Connection m (TestAddress addr))
connMap <- StrictTVar
  m
  (Map
     (NormalisedId (TestAddress addr))
     (Connection m (TestAddress addr)))
-> STM
     m
     (Map
        (NormalisedId (TestAddress addr))
        (Connection m (TestAddress addr)))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (NetworkState m (TestAddress addr)
-> StrictTVar
     m
     (Map
        (NormalisedId (TestAddress addr))
        (Connection m (TestAddress addr)))
forall (m :: * -> *) addr.
NetworkState m addr
-> StrictTVar m (Map (NormalisedId addr) (Connection m addr))
nsConnections NetworkState m (TestAddress addr)
state)
          let connId :: ConnectionId (TestAddress addr)
connId = TestAddress addr
-> TestAddress addr -> ConnectionId (TestAddress addr)
forall addr. addr -> addr -> ConnectionId addr
ConnectionId TestAddress addr
localAddress (ChannelWithInfo m (TestAddress addr) -> TestAddress addr
forall (m :: * -> *) addr. ChannelWithInfo m addr -> addr
cwiAddress ChannelWithInfo m (TestAddress addr)
cwi)

          case NormalisedId (TestAddress addr)
-> Map
     (NormalisedId (TestAddress addr)) (Connection m (TestAddress addr))
-> Maybe (Connection m (TestAddress addr))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (ConnectionId (TestAddress addr) -> NormalisedId (TestAddress addr)
forall addr. Ord addr => ConnectionId addr -> NormalisedId addr
normaliseId ConnectionId (TestAddress addr)
connId) Map
  (NormalisedId (TestAddress addr)) (Connection m (TestAddress addr))
connMap of
             Maybe (Connection m (TestAddress addr))
Nothing                                     ->
               Bool -> STM m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
             Just (Connection AttenuatedChannel m
_ AttenuatedChannel m
_ SDUSize
_ ConnectionState
SYN_SENT TestAddress addr
provider) ->
               Bool -> STM m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return ( TestAddress addr
provider TestAddress addr -> TestAddress addr -> Bool
forall a. Eq a => a -> a -> Bool
/= TestAddress addr
localAddress
                     Bool -> Bool -> Bool
|| TestAddress addr
localAddress TestAddress addr -> TestAddress addr -> Bool
forall a. Eq a => a -> a -> Bool
== ChannelWithInfo m (TestAddress addr) -> TestAddress addr
forall (m :: * -> *) addr. ChannelWithInfo m addr -> addr
cwiAddress ChannelWithInfo m (TestAddress addr)
cwi
                      )
             Maybe (Connection m (TestAddress addr))
_                                           ->
               Bool -> STM m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

        accept_ :: Time
                -> Maybe (DiffTime, IOErrType)
                -> Accept m (FD m (TestAddress addr))
                                  (TestAddress addr)
        accept_ :: Time
-> Maybe (DiffTime, IOErrType)
-> Accept m (FD m (TestAddress addr)) (TestAddress addr)
accept_ Time
time Maybe (DiffTime, IOErrType)
deltaAndIOErrType = m (Accepted (FD m (TestAddress addr)) (TestAddress addr),
   Accept m (FD m (TestAddress addr)) (TestAddress addr))
-> Accept m (FD m (TestAddress addr)) (TestAddress addr)
forall (m :: * -> *) fd addr.
m (Accepted fd addr, Accept m fd addr) -> Accept m fd addr
Accept (m (Accepted (FD m (TestAddress addr)) (TestAddress addr),
    Accept m (FD m (TestAddress addr)) (TestAddress addr))
 -> Accept m (FD m (TestAddress addr)) (TestAddress addr))
-> m (Accepted (FD m (TestAddress addr)) (TestAddress addr),
      Accept m (FD m (TestAddress addr)) (TestAddress addr))
-> Accept m (FD m (TestAddress addr)) (TestAddress addr)
forall a b. (a -> b) -> a -> b
$ do
            Time
ctime <- m Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime
            m (Either
     (SomeException, Maybe (TestAddress addr),
      Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
      SockType)
     (ChannelWithInfo m (TestAddress addr),
      ConnectionId (TestAddress addr)))
-> (Either
      (SomeException, Maybe (TestAddress addr),
       Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
       SockType)
      (ChannelWithInfo m (TestAddress addr),
       ConnectionId (TestAddress addr))
    -> m ())
-> (Either
      (SomeException, Maybe (TestAddress addr),
       Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
       SockType)
      (ChannelWithInfo m (TestAddress addr),
       ConnectionId (TestAddress addr))
    -> m (Accepted (FD m (TestAddress addr)) (TestAddress addr),
          Accept m (FD m (TestAddress addr)) (TestAddress addr)))
-> m (Accepted (FD m (TestAddress addr)) (TestAddress addr),
      Accept m (FD m (TestAddress addr)) (TestAddress addr))
forall (m :: * -> *) a b c.
MonadCatch m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracketOnError
              (STM
  m
  (Either
     (SomeException, Maybe (TestAddress addr),
      Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
      SockType)
     (ChannelWithInfo m (TestAddress addr),
      ConnectionId (TestAddress addr)))
-> m (Either
        (SomeException, Maybe (TestAddress addr),
         Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
         SockType)
        (ChannelWithInfo m (TestAddress addr),
         ConnectionId (TestAddress addr)))
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM
   m
   (Either
      (SomeException, Maybe (TestAddress addr),
       Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
       SockType)
      (ChannelWithInfo m (TestAddress addr),
       ConnectionId (TestAddress addr)))
 -> m (Either
         (SomeException, Maybe (TestAddress addr),
          Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
          SockType)
         (ChannelWithInfo m (TestAddress addr),
          ConnectionId (TestAddress addr))))
-> STM
     m
     (Either
        (SomeException, Maybe (TestAddress addr),
         Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
         SockType)
        (ChannelWithInfo m (TestAddress addr),
         ConnectionId (TestAddress addr)))
-> m (Either
        (SomeException, Maybe (TestAddress addr),
         Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
         SockType)
        (ChannelWithInfo m (TestAddress addr),
         ConnectionId (TestAddress addr)))
forall a b. (a -> b) -> a -> b
$ do
                FD_ m (TestAddress addr)
fd <- StrictTVar m (FD_ m (TestAddress addr))
-> STM m (FD_ m (TestAddress addr))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (FD_ m (TestAddress addr))
fdVar
                case FD_ m (TestAddress addr)
fd of
                  FDUninitialised Maybe (TestAddress addr)
mbAddr ->
                    -- 'berkeleyAccept' used by 'socketSnocket' will return
                    -- 'IOException's with 'AcceptFailure', we match this behaviour
                    -- here.
                    Either
  (SomeException, Maybe (TestAddress addr),
   Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
   SockType)
  (ChannelWithInfo m (TestAddress addr),
   ConnectionId (TestAddress addr))
-> STM
     m
     (Either
        (SomeException, Maybe (TestAddress addr),
         Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
         SockType)
        (ChannelWithInfo m (TestAddress addr),
         ConnectionId (TestAddress addr)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
   (SomeException, Maybe (TestAddress addr),
    Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
    SockType)
   (ChannelWithInfo m (TestAddress addr),
    ConnectionId (TestAddress addr))
 -> STM
      m
      (Either
         (SomeException, Maybe (TestAddress addr),
          Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
          SockType)
         (ChannelWithInfo m (TestAddress addr),
          ConnectionId (TestAddress addr))))
-> Either
     (SomeException, Maybe (TestAddress addr),
      Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
      SockType)
     (ChannelWithInfo m (TestAddress addr),
      ConnectionId (TestAddress addr))
-> STM
     m
     (Either
        (SomeException, Maybe (TestAddress addr),
         Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
         SockType)
        (ChannelWithInfo m (TestAddress addr),
         ConnectionId (TestAddress addr)))
forall a b. (a -> b) -> a -> b
$ (SomeException, Maybe (TestAddress addr),
 Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
 SockType)
-> Either
     (SomeException, Maybe (TestAddress addr),
      Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
      SockType)
     (ChannelWithInfo m (TestAddress addr),
      ConnectionId (TestAddress addr))
forall a b. a -> Either a b
Left ( IOError -> SomeException
forall e. Exception e => e -> SomeException
toException (IOError -> SomeException) -> IOError -> SomeException
forall a b. (a -> b) -> a -> b
$ FD_ m (TestAddress addr) -> IOError
invalidError FD_ m (TestAddress addr)
fd
                                  , Maybe (TestAddress addr)
mbAddr
                                  , Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m)
forall a. Maybe a
Nothing
                                  , FD_ m (TestAddress addr) -> SockType
forall (m :: * -> *) addr. FD_ m addr -> SockType
mkSockType FD_ m (TestAddress addr)
fd
                                  )
                  FDConnecting ConnectionId (TestAddress addr)
connId Connection m (TestAddress addr)
_ ->
                    Either
  (SomeException, Maybe (TestAddress addr),
   Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
   SockType)
  (ChannelWithInfo m (TestAddress addr),
   ConnectionId (TestAddress addr))
-> STM
     m
     (Either
        (SomeException, Maybe (TestAddress addr),
         Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
         SockType)
        (ChannelWithInfo m (TestAddress addr),
         ConnectionId (TestAddress addr)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
   (SomeException, Maybe (TestAddress addr),
    Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
    SockType)
   (ChannelWithInfo m (TestAddress addr),
    ConnectionId (TestAddress addr))
 -> STM
      m
      (Either
         (SomeException, Maybe (TestAddress addr),
          Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
          SockType)
         (ChannelWithInfo m (TestAddress addr),
          ConnectionId (TestAddress addr))))
-> Either
     (SomeException, Maybe (TestAddress addr),
      Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
      SockType)
     (ChannelWithInfo m (TestAddress addr),
      ConnectionId (TestAddress addr))
-> STM
     m
     (Either
        (SomeException, Maybe (TestAddress addr),
         Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
         SockType)
        (ChannelWithInfo m (TestAddress addr),
         ConnectionId (TestAddress addr)))
forall a b. (a -> b) -> a -> b
$ (SomeException, Maybe (TestAddress addr),
 Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
 SockType)
-> Either
     (SomeException, Maybe (TestAddress addr),
      Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
      SockType)
     (ChannelWithInfo m (TestAddress addr),
      ConnectionId (TestAddress addr))
forall a b. a -> Either a b
Left ( IOError -> SomeException
forall e. Exception e => e -> SomeException
toException (IOError -> SomeException) -> IOError -> SomeException
forall a b. (a -> b) -> a -> b
$ FD_ m (TestAddress addr) -> IOError
invalidError FD_ m (TestAddress addr)
fd
                                  , TestAddress addr -> Maybe (TestAddress addr)
forall a. a -> Maybe a
Just (ConnectionId (TestAddress addr) -> TestAddress addr
forall addr. ConnectionId addr -> addr
localAddress ConnectionId (TestAddress addr)
connId)
                                  , Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m)
forall a. Maybe a
Nothing
                                  , FD_ m (TestAddress addr) -> SockType
forall (m :: * -> *) addr. FD_ m addr -> SockType
mkSockType FD_ m (TestAddress addr)
fd
                                  )
                  FDConnected ConnectionId (TestAddress addr)
connId Connection m (TestAddress addr)
_ ->
                    Either
  (SomeException, Maybe (TestAddress addr),
   Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
   SockType)
  (ChannelWithInfo m (TestAddress addr),
   ConnectionId (TestAddress addr))
-> STM
     m
     (Either
        (SomeException, Maybe (TestAddress addr),
         Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
         SockType)
        (ChannelWithInfo m (TestAddress addr),
         ConnectionId (TestAddress addr)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
   (SomeException, Maybe (TestAddress addr),
    Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
    SockType)
   (ChannelWithInfo m (TestAddress addr),
    ConnectionId (TestAddress addr))
 -> STM
      m
      (Either
         (SomeException, Maybe (TestAddress addr),
          Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
          SockType)
         (ChannelWithInfo m (TestAddress addr),
          ConnectionId (TestAddress addr))))
-> Either
     (SomeException, Maybe (TestAddress addr),
      Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
      SockType)
     (ChannelWithInfo m (TestAddress addr),
      ConnectionId (TestAddress addr))
-> STM
     m
     (Either
        (SomeException, Maybe (TestAddress addr),
         Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
         SockType)
        (ChannelWithInfo m (TestAddress addr),
         ConnectionId (TestAddress addr)))
forall a b. (a -> b) -> a -> b
$ (SomeException, Maybe (TestAddress addr),
 Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
 SockType)
-> Either
     (SomeException, Maybe (TestAddress addr),
      Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
      SockType)
     (ChannelWithInfo m (TestAddress addr),
      ConnectionId (TestAddress addr))
forall a b. a -> Either a b
Left ( IOError -> SomeException
forall e. Exception e => e -> SomeException
toException (IOError -> SomeException) -> IOError -> SomeException
forall a b. (a -> b) -> a -> b
$ FD_ m (TestAddress addr) -> IOError
invalidError FD_ m (TestAddress addr)
fd
                                  , TestAddress addr -> Maybe (TestAddress addr)
forall a. a -> Maybe a
Just (ConnectionId (TestAddress addr) -> TestAddress addr
forall addr. ConnectionId addr -> addr
localAddress ConnectionId (TestAddress addr)
connId)
                                  , Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m)
forall a. Maybe a
Nothing
                                  , FD_ m (TestAddress addr) -> SockType
forall (m :: * -> *) addr. FD_ m addr -> SockType
mkSockType FD_ m (TestAddress addr)
fd
                                  )

                  FDListening TestAddress addr
localAddress TBQueue m (ChannelWithInfo m (TestAddress addr))
queue -> do
                    -- We should not accept nor fail the 'accept' call in the
                    -- presence of a connection that is __not__ in SYN_SENT
                    -- state. So we take from the TBQueue until we have found
                    -- one that is SYN_SENT state.
                    ChannelWithInfo m (TestAddress addr)
cwi <- (ChannelWithInfo m (TestAddress addr) -> STM m Bool)
-> TBQueue m (ChannelWithInfo m (TestAddress addr))
-> STM m (ChannelWithInfo m (TestAddress addr))
forall (m :: * -> *) a.
MonadSTM m =>
(a -> STM m Bool) -> TBQueue m a -> STM m a
readTBQueueUntil (TestAddress addr
-> ChannelWithInfo m (TestAddress addr) -> STM m Bool
synSent TestAddress addr
localAddress) TBQueue m (ChannelWithInfo m (TestAddress addr))
queue
                    let connId :: ConnectionId (TestAddress addr)
connId = TestAddress addr
-> TestAddress addr -> ConnectionId (TestAddress addr)
forall addr. addr -> addr -> ConnectionId addr
ConnectionId TestAddress addr
localAddress (ChannelWithInfo m (TestAddress addr) -> TestAddress addr
forall (m :: * -> *) addr. ChannelWithInfo m addr -> addr
cwiAddress ChannelWithInfo m (TestAddress addr)
cwi)

                    case Maybe (DiffTime, IOErrType)
deltaAndIOErrType of
                      -- the `ctime` is the time when we issued 'accept' not
                      -- when read something from the queue.
                      Just (DiffTime
delta, IOErrType
ioErrType) | DiffTime
delta DiffTime -> Time -> Time
`addTime` Time
time Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
>= Time
ctime ->
                        case IOErrType
ioErrType of
                          IOErrType
IOErrConnectionAborted ->
                            Either
  (SomeException, Maybe (TestAddress addr),
   Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
   SockType)
  (ChannelWithInfo m (TestAddress addr),
   ConnectionId (TestAddress addr))
-> STM
     m
     (Either
        (SomeException, Maybe (TestAddress addr),
         Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
         SockType)
        (ChannelWithInfo m (TestAddress addr),
         ConnectionId (TestAddress addr)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
   (SomeException, Maybe (TestAddress addr),
    Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
    SockType)
   (ChannelWithInfo m (TestAddress addr),
    ConnectionId (TestAddress addr))
 -> STM
      m
      (Either
         (SomeException, Maybe (TestAddress addr),
          Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
          SockType)
         (ChannelWithInfo m (TestAddress addr),
          ConnectionId (TestAddress addr))))
-> Either
     (SomeException, Maybe (TestAddress addr),
      Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
      SockType)
     (ChannelWithInfo m (TestAddress addr),
      ConnectionId (TestAddress addr))
-> STM
     m
     (Either
        (SomeException, Maybe (TestAddress addr),
         Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
         SockType)
        (ChannelWithInfo m (TestAddress addr),
         ConnectionId (TestAddress addr)))
forall a b. (a -> b) -> a -> b
$ (SomeException, Maybe (TestAddress addr),
 Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
 SockType)
-> Either
     (SomeException, Maybe (TestAddress addr),
      Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
      SockType)
     (ChannelWithInfo m (TestAddress addr),
      ConnectionId (TestAddress addr))
forall a b. a -> Either a b
Left ( IOError -> SomeException
forall e. Exception e => e -> SomeException
toException IOError
connectionAbortedError
                                          , TestAddress addr -> Maybe (TestAddress addr)
forall a. a -> Maybe a
Just TestAddress addr
localAddress
                                          , (ConnectionId (TestAddress addr), AttenuatedChannel m)
-> Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m)
forall a. a -> Maybe a
Just (ConnectionId (TestAddress addr)
connId, ChannelWithInfo m (TestAddress addr) -> AttenuatedChannel m
forall (m :: * -> *) addr.
ChannelWithInfo m addr -> AttenuatedChannel m
cwiChannelLocal ChannelWithInfo m (TestAddress addr)
cwi)
                                          , FD_ m (TestAddress addr) -> SockType
forall (m :: * -> *) addr. FD_ m addr -> SockType
mkSockType FD_ m (TestAddress addr)
fd
                                          )
                          IOErrType
IOErrResourceExhausted ->
                            Either
  (SomeException, Maybe (TestAddress addr),
   Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
   SockType)
  (ChannelWithInfo m (TestAddress addr),
   ConnectionId (TestAddress addr))
-> STM
     m
     (Either
        (SomeException, Maybe (TestAddress addr),
         Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
         SockType)
        (ChannelWithInfo m (TestAddress addr),
         ConnectionId (TestAddress addr)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
   (SomeException, Maybe (TestAddress addr),
    Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
    SockType)
   (ChannelWithInfo m (TestAddress addr),
    ConnectionId (TestAddress addr))
 -> STM
      m
      (Either
         (SomeException, Maybe (TestAddress addr),
          Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
          SockType)
         (ChannelWithInfo m (TestAddress addr),
          ConnectionId (TestAddress addr))))
-> Either
     (SomeException, Maybe (TestAddress addr),
      Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
      SockType)
     (ChannelWithInfo m (TestAddress addr),
      ConnectionId (TestAddress addr))
-> STM
     m
     (Either
        (SomeException, Maybe (TestAddress addr),
         Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
         SockType)
        (ChannelWithInfo m (TestAddress addr),
         ConnectionId (TestAddress addr)))
forall a b. (a -> b) -> a -> b
$ (SomeException, Maybe (TestAddress addr),
 Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
 SockType)
-> Either
     (SomeException, Maybe (TestAddress addr),
      Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
      SockType)
     (ChannelWithInfo m (TestAddress addr),
      ConnectionId (TestAddress addr))
forall a b. a -> Either a b
Left ( IOError -> SomeException
forall e. Exception e => e -> SomeException
toException (IOError -> SomeException) -> IOError -> SomeException
forall a b. (a -> b) -> a -> b
$ FD_ m (TestAddress addr) -> IOError
resourceExhaustedError FD_ m (TestAddress addr)
fd
                                          , TestAddress addr -> Maybe (TestAddress addr)
forall a. a -> Maybe a
Just TestAddress addr
localAddress
                                          , (ConnectionId (TestAddress addr), AttenuatedChannel m)
-> Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m)
forall a. a -> Maybe a
Just (ConnectionId (TestAddress addr)
connId, ChannelWithInfo m (TestAddress addr) -> AttenuatedChannel m
forall (m :: * -> *) addr.
ChannelWithInfo m addr -> AttenuatedChannel m
cwiChannelLocal ChannelWithInfo m (TestAddress addr)
cwi)
                                          , FD_ m (TestAddress addr) -> SockType
forall (m :: * -> *) addr. FD_ m addr -> SockType
mkSockType FD_ m (TestAddress addr)
fd
                                          )
                      Maybe (DiffTime, IOErrType)
_  -> Either
  (SomeException, Maybe (TestAddress addr),
   Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
   SockType)
  (ChannelWithInfo m (TestAddress addr),
   ConnectionId (TestAddress addr))
-> STM
     m
     (Either
        (SomeException, Maybe (TestAddress addr),
         Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
         SockType)
        (ChannelWithInfo m (TestAddress addr),
         ConnectionId (TestAddress addr)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
   (SomeException, Maybe (TestAddress addr),
    Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
    SockType)
   (ChannelWithInfo m (TestAddress addr),
    ConnectionId (TestAddress addr))
 -> STM
      m
      (Either
         (SomeException, Maybe (TestAddress addr),
          Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
          SockType)
         (ChannelWithInfo m (TestAddress addr),
          ConnectionId (TestAddress addr))))
-> Either
     (SomeException, Maybe (TestAddress addr),
      Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
      SockType)
     (ChannelWithInfo m (TestAddress addr),
      ConnectionId (TestAddress addr))
-> STM
     m
     (Either
        (SomeException, Maybe (TestAddress addr),
         Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
         SockType)
        (ChannelWithInfo m (TestAddress addr),
         ConnectionId (TestAddress addr)))
forall a b. (a -> b) -> a -> b
$ (ChannelWithInfo m (TestAddress addr),
 ConnectionId (TestAddress addr))
-> Either
     (SomeException, Maybe (TestAddress addr),
      Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
      SockType)
     (ChannelWithInfo m (TestAddress addr),
      ConnectionId (TestAddress addr))
forall a b. b -> Either a b
Right ( ChannelWithInfo m (TestAddress addr)
cwi
                                           , ConnectionId (TestAddress addr)
connId
                                           )

                  FDClosed {} ->
                    Either
  (SomeException, Maybe (TestAddress addr),
   Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
   SockType)
  (ChannelWithInfo m (TestAddress addr),
   ConnectionId (TestAddress addr))
-> STM
     m
     (Either
        (SomeException, Maybe (TestAddress addr),
         Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
         SockType)
        (ChannelWithInfo m (TestAddress addr),
         ConnectionId (TestAddress addr)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
   (SomeException, Maybe (TestAddress addr),
    Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
    SockType)
   (ChannelWithInfo m (TestAddress addr),
    ConnectionId (TestAddress addr))
 -> STM
      m
      (Either
         (SomeException, Maybe (TestAddress addr),
          Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
          SockType)
         (ChannelWithInfo m (TestAddress addr),
          ConnectionId (TestAddress addr))))
-> Either
     (SomeException, Maybe (TestAddress addr),
      Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
      SockType)
     (ChannelWithInfo m (TestAddress addr),
      ConnectionId (TestAddress addr))
-> STM
     m
     (Either
        (SomeException, Maybe (TestAddress addr),
         Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
         SockType)
        (ChannelWithInfo m (TestAddress addr),
         ConnectionId (TestAddress addr)))
forall a b. (a -> b) -> a -> b
$ (SomeException, Maybe (TestAddress addr),
 Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
 SockType)
-> Either
     (SomeException, Maybe (TestAddress addr),
      Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
      SockType)
     (ChannelWithInfo m (TestAddress addr),
      ConnectionId (TestAddress addr))
forall a b. a -> Either a b
Left ( IOError -> SomeException
forall e. Exception e => e -> SomeException
toException (IOError -> SomeException) -> IOError -> SomeException
forall a b. (a -> b) -> a -> b
$ FD_ m (TestAddress addr) -> IOError
invalidError FD_ m (TestAddress addr)
fd
                                  , Maybe (TestAddress addr)
forall a. Maybe a
Nothing
                                  , Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m)
forall a. Maybe a
Nothing
                                  , FD_ m (TestAddress addr) -> SockType
forall (m :: * -> *) addr. FD_ m addr -> SockType
mkSockType FD_ m (TestAddress addr)
fd
                                  )
              )
              ( \ Either
  (SomeException, Maybe (TestAddress addr),
   Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
   SockType)
  (ChannelWithInfo m (TestAddress addr),
   ConnectionId (TestAddress addr))
result ->
                  case Either
  (SomeException, Maybe (TestAddress addr),
   Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
   SockType)
  (ChannelWithInfo m (TestAddress addr),
   ConnectionId (TestAddress addr))
result of
                    Left {} -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                    Right (ChannelWithInfo m (TestAddress addr)
chann, ConnectionId (TestAddress addr)
connId) -> m () -> m ()
forall (m :: * -> *) a. MonadMask m => m a -> m a
uninterruptibleMask_ (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
                      AttenuatedChannel m -> m ()
forall (m :: * -> *). AttenuatedChannel m -> m ()
acClose (ChannelWithInfo m (TestAddress addr) -> AttenuatedChannel m
forall (m :: * -> *) addr.
ChannelWithInfo m addr -> AttenuatedChannel m
cwiChannelLocal ChannelWithInfo m (TestAddress addr)
chann)
                      STM m () -> m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$
                        StrictTVar
  m
  (Map
     (NormalisedId (TestAddress addr))
     (Connection m (TestAddress addr)))
-> (Map
      (NormalisedId (TestAddress addr)) (Connection m (TestAddress addr))
    -> Map
         (NormalisedId (TestAddress addr))
         (Connection m (TestAddress addr)))
-> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar (NetworkState m (TestAddress addr)
-> StrictTVar
     m
     (Map
        (NormalisedId (TestAddress addr))
        (Connection m (TestAddress addr)))
forall (m :: * -> *) addr.
NetworkState m addr
-> StrictTVar m (Map (NormalisedId addr) (Connection m addr))
nsConnections NetworkState m (TestAddress addr)
state)
                                   ((Connection m (TestAddress addr)
 -> Maybe (Connection m (TestAddress addr)))
-> NormalisedId (TestAddress addr)
-> Map
     (NormalisedId (TestAddress addr)) (Connection m (TestAddress addr))
-> Map
     (NormalisedId (TestAddress addr)) (Connection m (TestAddress addr))
forall k a. Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a
Map.update
                                     (\conn :: Connection m (TestAddress addr)
conn@Connection { ConnectionState
connState :: ConnectionState
connState :: forall (m :: * -> *) addr. Connection m addr -> ConnectionState
connState } ->
                                       case ConnectionState
connState of
                                         ConnectionState
FIN ->
                                           Maybe (Connection m (TestAddress addr))
forall a. Maybe a
Nothing
                                         ConnectionState
_ ->
                                           Connection m (TestAddress addr)
-> Maybe (Connection m (TestAddress addr))
forall a. a -> Maybe a
Just Connection m (TestAddress addr)
conn { connState :: ConnectionState
connState = ConnectionState
FIN })
                                     (ConnectionId (TestAddress addr) -> NormalisedId (TestAddress addr)
forall addr. Ord addr => ConnectionId addr -> NormalisedId addr
normaliseId ConnectionId (TestAddress addr)
connId))
              )
              ((Either
    (SomeException, Maybe (TestAddress addr),
     Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
     SockType)
    (ChannelWithInfo m (TestAddress addr),
     ConnectionId (TestAddress addr))
  -> m (Accepted (FD m (TestAddress addr)) (TestAddress addr),
        Accept m (FD m (TestAddress addr)) (TestAddress addr)))
 -> m (Accepted (FD m (TestAddress addr)) (TestAddress addr),
       Accept m (FD m (TestAddress addr)) (TestAddress addr)))
-> (Either
      (SomeException, Maybe (TestAddress addr),
       Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
       SockType)
      (ChannelWithInfo m (TestAddress addr),
       ConnectionId (TestAddress addr))
    -> m (Accepted (FD m (TestAddress addr)) (TestAddress addr),
          Accept m (FD m (TestAddress addr)) (TestAddress addr)))
-> m (Accepted (FD m (TestAddress addr)) (TestAddress addr),
      Accept m (FD m (TestAddress addr)) (TestAddress addr))
forall a b. (a -> b) -> a -> b
$ \ Either
  (SomeException, Maybe (TestAddress addr),
   Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
   SockType)
  (ChannelWithInfo m (TestAddress addr),
   ConnectionId (TestAddress addr))
result ->
                case Either
  (SomeException, Maybe (TestAddress addr),
   Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
   SockType)
  (ChannelWithInfo m (TestAddress addr),
   ConnectionId (TestAddress addr))
result of
                  Left (SomeException
err, Maybe (TestAddress addr)
mbLocalAddr, Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m)
mbConnIdAndChann, SockType
fdType) -> do
                    m () -> m ()
forall (m :: * -> *) a. MonadMask m => m a -> m a
uninterruptibleMask_ (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
                      ((ConnectionId (TestAddress addr), AttenuatedChannel m) -> m ())
-> Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m)
-> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\(ConnectionId (TestAddress addr)
connId, AttenuatedChannel m
chann) -> do
                                   AttenuatedChannel m -> m ()
forall (m :: * -> *). AttenuatedChannel m -> m ()
acClose AttenuatedChannel m
chann
                                   STM m () -> m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ StrictTVar
  m
  (Map
     (NormalisedId (TestAddress addr))
     (Connection m (TestAddress addr)))
-> (Map
      (NormalisedId (TestAddress addr)) (Connection m (TestAddress addr))
    -> Map
         (NormalisedId (TestAddress addr))
         (Connection m (TestAddress addr)))
-> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar
                                     (NetworkState m (TestAddress addr)
-> StrictTVar
     m
     (Map
        (NormalisedId (TestAddress addr))
        (Connection m (TestAddress addr)))
forall (m :: * -> *) addr.
NetworkState m addr
-> StrictTVar m (Map (NormalisedId addr) (Connection m addr))
nsConnections NetworkState m (TestAddress addr)
state)
                                     ((Connection m (TestAddress addr)
 -> Maybe (Connection m (TestAddress addr)))
-> NormalisedId (TestAddress addr)
-> Map
     (NormalisedId (TestAddress addr)) (Connection m (TestAddress addr))
-> Map
     (NormalisedId (TestAddress addr)) (Connection m (TestAddress addr))
forall k a. Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a
Map.update
                                       (\conn :: Connection m (TestAddress addr)
conn@Connection { ConnectionState
connState :: ConnectionState
connState :: forall (m :: * -> *) addr. Connection m addr -> ConnectionState
connState } ->
                                         case ConnectionState
connState of
                                           ConnectionState
FIN -> Maybe (Connection m (TestAddress addr))
forall a. Maybe a
Nothing
                                           ConnectionState
_   -> Connection m (TestAddress addr)
-> Maybe (Connection m (TestAddress addr))
forall a. a -> Maybe a
Just Connection m (TestAddress addr)
conn { connState :: ConnectionState
connState = ConnectionState
FIN })
                                       (ConnectionId (TestAddress addr) -> NormalisedId (TestAddress addr)
forall addr. Ord addr => ConnectionId addr -> NormalisedId addr
normaliseId ConnectionId (TestAddress addr)
connId))
                                )
                                Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m)
mbConnIdAndChann
                    Tracer
  m (WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr)))
-> WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr))
-> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer
  m (WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr)))
tr (Maybe (TestAddress addr)
-> Maybe (TestAddress addr)
-> SnocketTrace m (TestAddress addr)
-> WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr))
forall addr event.
Maybe addr -> Maybe addr -> event -> WithAddr addr event
WithAddr Maybe (TestAddress addr)
mbLocalAddr Maybe (TestAddress addr)
forall a. Maybe a
Nothing (SockType -> SomeException -> SnocketTrace m (TestAddress addr)
forall (m :: * -> *) addr.
SockType -> SomeException -> SnocketTrace m addr
STAcceptFailure SockType
fdType SomeException
err))
                    (Accepted (FD m (TestAddress addr)) (TestAddress addr),
 Accept m (FD m (TestAddress addr)) (TestAddress addr))
-> m (Accepted (FD m (TestAddress addr)) (TestAddress addr),
      Accept m (FD m (TestAddress addr)) (TestAddress addr))
forall (m :: * -> *) a. Monad m => a -> m a
return (SomeException
-> Accepted (FD m (TestAddress addr)) (TestAddress addr)
forall fd addr. SomeException -> Accepted fd addr
AcceptFailure SomeException
err, Time
-> Maybe (DiffTime, IOErrType)
-> Accept m (FD m (TestAddress addr)) (TestAddress addr)
accept_ Time
time Maybe (DiffTime, IOErrType)
deltaAndIOErrType)

                  Right (ChannelWithInfo m (TestAddress addr)
chann, connId :: ConnectionId (TestAddress addr)
connId@ConnectionId { TestAddress addr
localAddress :: TestAddress addr
localAddress :: forall addr. ConnectionId addr -> addr
localAddress, TestAddress addr
remoteAddress :: TestAddress addr
remoteAddress :: forall addr. ConnectionId addr -> addr
remoteAddress }) -> do
                    Tracer
  m (WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr)))
-> WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr))
-> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer
  m (WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr)))
tr (Maybe (TestAddress addr)
-> Maybe (TestAddress addr)
-> SnocketTrace m (TestAddress addr)
-> WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr))
forall addr event.
Maybe addr -> Maybe addr -> event -> WithAddr addr event
WithAddr (TestAddress addr -> Maybe (TestAddress addr)
forall a. a -> Maybe a
Just TestAddress addr
localAddress) (TestAddress addr -> Maybe (TestAddress addr)
forall a. a -> Maybe a
Just TestAddress addr
remoteAddress)
                                           SnocketTrace m (TestAddress addr)
forall (m :: * -> *) addr. SnocketTrace m addr
STAccepting)
                    let ChannelWithInfo
                          { cwiSDUSize :: forall (m :: * -> *) addr. ChannelWithInfo m addr -> SDUSize
cwiSDUSize       = SDUSize
sduSize
                          , cwiChannelLocal :: forall (m :: * -> *) addr.
ChannelWithInfo m addr -> AttenuatedChannel m
cwiChannelLocal  = AttenuatedChannel m
channelLocal
                          , cwiChannelRemote :: forall (m :: * -> *) addr.
ChannelWithInfo m addr -> AttenuatedChannel m
cwiChannelRemote = AttenuatedChannel m
channelRemote
                          } = ChannelWithInfo m (TestAddress addr)
chann

                    FD m (TestAddress addr)
fdRemote <- STM m (FD m (TestAddress addr)) -> m (FD m (TestAddress addr))
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (FD m (TestAddress addr)) -> m (FD m (TestAddress addr)))
-> STM m (FD m (TestAddress addr)) -> m (FD m (TestAddress addr))
forall a b. (a -> b) -> a -> b
$ do

                      StrictTVar
  m
  (Map
     (NormalisedId (TestAddress addr))
     (Connection m (TestAddress addr)))
-> (Map
      (NormalisedId (TestAddress addr)) (Connection m (TestAddress addr))
    -> Map
         (NormalisedId (TestAddress addr))
         (Connection m (TestAddress addr)))
-> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar (NetworkState m (TestAddress addr)
-> StrictTVar
     m
     (Map
        (NormalisedId (TestAddress addr))
        (Connection m (TestAddress addr)))
forall (m :: * -> *) addr.
NetworkState m addr
-> StrictTVar m (Map (NormalisedId addr) (Connection m addr))
nsConnections NetworkState m (TestAddress addr)
state)
                                 ((Connection m (TestAddress addr)
 -> Connection m (TestAddress addr))
-> NormalisedId (TestAddress addr)
-> Map
     (NormalisedId (TestAddress addr)) (Connection m (TestAddress addr))
-> Map
     (NormalisedId (TestAddress addr)) (Connection m (TestAddress addr))
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust (\Connection m (TestAddress addr)
s -> Connection m (TestAddress addr)
s { connState :: ConnectionState
connState = ConnectionState
ESTABLISHED })
                                             (ConnectionId (TestAddress addr) -> NormalisedId (TestAddress addr)
forall addr. Ord addr => ConnectionId addr -> NormalisedId addr
normaliseId ConnectionId (TestAddress addr)
connId))

                      StrictTVar m (FD_ m (TestAddress addr)) -> FD m (TestAddress addr)
forall (m :: * -> *) peerAddr.
StrictTVar m (FD_ m peerAddr) -> FD m peerAddr
FD (StrictTVar m (FD_ m (TestAddress addr))
 -> FD m (TestAddress addr))
-> STM m (StrictTVar m (FD_ m (TestAddress addr)))
-> STM m (FD m (TestAddress addr))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FD_ m (TestAddress addr)
-> STM m (StrictTVar m (FD_ m (TestAddress addr)))
forall (m :: * -> *) a. MonadSTM m => a -> STM m (StrictTVar m a)
newTVar (ConnectionId (TestAddress addr)
-> Connection m (TestAddress addr) -> FD_ m (TestAddress addr)
forall (m :: * -> *) addr.
ConnectionId addr -> Connection m addr -> FD_ m addr
FDConnected
                                          ConnectionId (TestAddress addr)
connId
                                          Connection :: forall (m :: * -> *) addr.
AttenuatedChannel m
-> AttenuatedChannel m
-> SDUSize
-> ConnectionState
-> addr
-> Connection m addr
Connection
                                            { connChannelLocal :: AttenuatedChannel m
connChannelLocal  = AttenuatedChannel m
channelLocal
                                            , connChannelRemote :: AttenuatedChannel m
connChannelRemote = AttenuatedChannel m
channelRemote
                                            , connSDUSize :: SDUSize
connSDUSize       = SDUSize
sduSize
                                            , connState :: ConnectionState
connState         = ConnectionState
ESTABLISHED
                                            , connProvider :: TestAddress addr
connProvider      = TestAddress addr
remoteAddress
                                            })

                    Tracer
  m (WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr)))
-> WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr))
-> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer
  m (WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr)))
tr (Maybe (TestAddress addr)
-> Maybe (TestAddress addr)
-> SnocketTrace m (TestAddress addr)
-> WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr))
forall addr event.
Maybe addr -> Maybe addr -> event -> WithAddr addr event
WithAddr (TestAddress addr -> Maybe (TestAddress addr)
forall a. a -> Maybe a
Just TestAddress addr
localAddress) Maybe (TestAddress addr)
forall a. Maybe a
Nothing
                                           (TestAddress addr -> SnocketTrace m (TestAddress addr)
forall (m :: * -> *) addr. addr -> SnocketTrace m addr
STAccepted TestAddress addr
remoteAddress))

                    (Accepted (FD m (TestAddress addr)) (TestAddress addr),
 Accept m (FD m (TestAddress addr)) (TestAddress addr))
-> m (Accepted (FD m (TestAddress addr)) (TestAddress addr),
      Accept m (FD m (TestAddress addr)) (TestAddress addr))
forall (m :: * -> *) a. Monad m => a -> m a
return (FD m (TestAddress addr)
-> TestAddress addr
-> Accepted (FD m (TestAddress addr)) (TestAddress addr)
forall fd addr. fd -> addr -> Accepted fd addr
Accepted FD m (TestAddress addr)
fdRemote TestAddress addr
remoteAddress, Time
-> Maybe (DiffTime, IOErrType)
-> Accept m (FD m (TestAddress addr)) (TestAddress addr)
accept_ Time
time Maybe (DiffTime, IOErrType)
deltaAndIOErrType)


        invalidError :: FD_ m (TestAddress addr) -> IOError
        invalidError :: FD_ m (TestAddress addr) -> IOError
invalidError FD_ m (TestAddress addr)
fd = IOError :: Maybe Handle
-> IOErrorType
-> String
-> String
-> Maybe CInt
-> Maybe String
-> IOError
IOError
          { ioe_handle :: Maybe Handle
ioe_handle      = Maybe Handle
forall a. Maybe a
Nothing
          , ioe_type :: IOErrorType
ioe_type        = IOErrorType
InvalidArgument
          , ioe_location :: String
ioe_location    = String
"Ouroboros.Network.Snocket.Sim.accept"
          , ioe_description :: String
ioe_description = String -> ShowS
forall r. PrintfType r => String -> r
printf String
"Invalid argument (%s)" (FD_ m (TestAddress addr) -> String
forall a. Show a => a -> String
show FD_ m (TestAddress addr)
fd)
          , ioe_errno :: Maybe CInt
ioe_errno       = Maybe CInt
forall a. Maybe a
Nothing
          , ioe_filename :: Maybe String
ioe_filename    = Maybe String
forall a. Maybe a
Nothing
          }

        connectionAbortedError :: IOError
        connectionAbortedError :: IOError
connectionAbortedError = IOError :: Maybe Handle
-> IOErrorType
-> String
-> String
-> Maybe CInt
-> Maybe String
-> IOError
IOError
          { ioe_handle :: Maybe Handle
ioe_handle      = Maybe Handle
forall a. Maybe a
Nothing
          , ioe_type :: IOErrorType
ioe_type        = IOErrorType
OtherError
          , ioe_location :: String
ioe_location    = String
"Ouroboros.Network.Snocket.Sim.accept"
            -- Note: this matches the `iseCONNABORTED` on Windows, see
            -- 'Ouroboros.Network.Server2`
          , ioe_description :: String
ioe_description = String
"Software caused connection abort (WSAECONNABORTED)"
          , ioe_errno :: Maybe CInt
ioe_errno       = CInt -> Maybe CInt
forall a. a -> Maybe a
Just (case Errno
eCONNABORTED of Errno CInt
errno -> CInt
errno)
          , ioe_filename :: Maybe String
ioe_filename    = Maybe String
forall a. Maybe a
Nothing
          }

        resourceExhaustedError :: FD_ m (TestAddress addr) -> IOError
        resourceExhaustedError :: FD_ m (TestAddress addr) -> IOError
resourceExhaustedError FD_ m (TestAddress addr)
fd = IOError :: Maybe Handle
-> IOErrorType
-> String
-> String
-> Maybe CInt
-> Maybe String
-> IOError
IOError
          { ioe_handle :: Maybe Handle
ioe_handle      = Maybe Handle
forall a. Maybe a
Nothing
          , ioe_type :: IOErrorType
ioe_type        = IOErrorType
ResourceExhausted
          , ioe_location :: String
ioe_location    = String
"Ouroboros.Netowrk.Snocket.Sim.accept"
          , ioe_description :: String
ioe_description = String -> ShowS
forall r. PrintfType r => String -> r
printf String
"Resource exhausted (%s)" (FD_ m (TestAddress addr) -> String
forall a. Show a => a -> String
show FD_ m (TestAddress addr)
fd)
          , ioe_errno :: Maybe CInt
ioe_errno       = Maybe CInt
forall a. Maybe a
Nothing
          , ioe_filename :: Maybe String
ioe_filename    = Maybe String
forall a. Maybe a
Nothing
          }


    close :: FD m (TestAddress addr)
          -> m ()
    close :: FD m (TestAddress addr) -> m ()
close FD { StrictTVar m (FD_ m (TestAddress addr))
fdVar :: StrictTVar m (FD_ m (TestAddress addr))
fdVar :: forall (m :: * -> *) peerAddr.
FD m peerAddr -> StrictTVar m (FD_ m peerAddr)
fdVar } =
      m () -> m ()
forall (m :: * -> *) a. MonadMask m => m a -> m a
uninterruptibleMask_ (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        Wedge
  (ConnectionId (TestAddress addr), SockType, AttenuatedChannel m)
  (TestAddress addr, SockType,
   [(TestAddress addr, AttenuatedChannel m)])
wChannel <- STM
  m
  (Wedge
     (ConnectionId (TestAddress addr), SockType, AttenuatedChannel m)
     (TestAddress addr, SockType,
      [(TestAddress addr, AttenuatedChannel m)]))
-> m (Wedge
        (ConnectionId (TestAddress addr), SockType, AttenuatedChannel m)
        (TestAddress addr, SockType,
         [(TestAddress addr, AttenuatedChannel m)]))
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM
   m
   (Wedge
      (ConnectionId (TestAddress addr), SockType, AttenuatedChannel m)
      (TestAddress addr, SockType,
       [(TestAddress addr, AttenuatedChannel m)]))
 -> m (Wedge
         (ConnectionId (TestAddress addr), SockType, AttenuatedChannel m)
         (TestAddress addr, SockType,
          [(TestAddress addr, AttenuatedChannel m)])))
-> STM
     m
     (Wedge
        (ConnectionId (TestAddress addr), SockType, AttenuatedChannel m)
        (TestAddress addr, SockType,
         [(TestAddress addr, AttenuatedChannel m)]))
-> m (Wedge
        (ConnectionId (TestAddress addr), SockType, AttenuatedChannel m)
        (TestAddress addr, SockType,
         [(TestAddress addr, AttenuatedChannel m)]))
forall a b. (a -> b) -> a -> b
$ do
          FD_ m (TestAddress addr)
fd_ <- StrictTVar m (FD_ m (TestAddress addr))
-> STM m (FD_ m (TestAddress addr))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (FD_ m (TestAddress addr))
fdVar
          case FD_ m (TestAddress addr)
fd_ of
            FDUninitialised Maybe (TestAddress addr)
Nothing
              -> StrictTVar m (FD_ m (TestAddress addr))
-> FD_ m (TestAddress addr) -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (FD_ m (TestAddress addr))
fdVar (Wedge (ConnectionId (TestAddress addr)) (TestAddress addr)
-> FD_ m (TestAddress addr)
forall (m :: * -> *) addr.
Wedge (ConnectionId addr) addr -> FD_ m addr
FDClosed Wedge (ConnectionId (TestAddress addr)) (TestAddress addr)
forall a b. Wedge a b
Nowhere)
              STM m ()
-> Wedge
     (ConnectionId (TestAddress addr), SockType, AttenuatedChannel m)
     (TestAddress addr, SockType,
      [(TestAddress addr, AttenuatedChannel m)])
-> STM
     m
     (Wedge
        (ConnectionId (TestAddress addr), SockType, AttenuatedChannel m)
        (TestAddress addr, SockType,
         [(TestAddress addr, AttenuatedChannel m)]))
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Wedge
  (ConnectionId (TestAddress addr), SockType, AttenuatedChannel m)
  (TestAddress addr, SockType,
   [(TestAddress addr, AttenuatedChannel m)])
forall a b. Wedge a b
Nowhere
            FDUninitialised (Just TestAddress addr
addr)
              -> StrictTVar m (FD_ m (TestAddress addr))
-> FD_ m (TestAddress addr) -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (FD_ m (TestAddress addr))
fdVar (Wedge (ConnectionId (TestAddress addr)) (TestAddress addr)
-> FD_ m (TestAddress addr)
forall (m :: * -> *) addr.
Wedge (ConnectionId addr) addr -> FD_ m addr
FDClosed (TestAddress addr
-> Wedge (ConnectionId (TestAddress addr)) (TestAddress addr)
forall a b. b -> Wedge a b
There TestAddress addr
addr))
              STM m ()
-> Wedge
     (ConnectionId (TestAddress addr), SockType, AttenuatedChannel m)
     (TestAddress addr, SockType,
      [(TestAddress addr, AttenuatedChannel m)])
-> STM
     m
     (Wedge
        (ConnectionId (TestAddress addr), SockType, AttenuatedChannel m)
        (TestAddress addr, SockType,
         [(TestAddress addr, AttenuatedChannel m)]))
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Wedge
  (ConnectionId (TestAddress addr), SockType, AttenuatedChannel m)
  (TestAddress addr, SockType,
   [(TestAddress addr, AttenuatedChannel m)])
forall a b. Wedge a b
Nowhere
            FDConnecting ConnectionId (TestAddress addr)
connId Connection m (TestAddress addr)
conn
              -> StrictTVar m (FD_ m (TestAddress addr))
-> FD_ m (TestAddress addr) -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (FD_ m (TestAddress addr))
fdVar (Wedge (ConnectionId (TestAddress addr)) (TestAddress addr)
-> FD_ m (TestAddress addr)
forall (m :: * -> *) addr.
Wedge (ConnectionId addr) addr -> FD_ m addr
FDClosed (ConnectionId (TestAddress addr)
-> Wedge (ConnectionId (TestAddress addr)) (TestAddress addr)
forall a b. a -> Wedge a b
Here ConnectionId (TestAddress addr)
connId))
              STM m ()
-> Wedge
     (ConnectionId (TestAddress addr), SockType, AttenuatedChannel m)
     (TestAddress addr, SockType,
      [(TestAddress addr, AttenuatedChannel m)])
-> STM
     m
     (Wedge
        (ConnectionId (TestAddress addr), SockType, AttenuatedChannel m)
        (TestAddress addr, SockType,
         [(TestAddress addr, AttenuatedChannel m)]))
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> (ConnectionId (TestAddress addr), SockType, AttenuatedChannel m)
-> Wedge
     (ConnectionId (TestAddress addr), SockType, AttenuatedChannel m)
     (TestAddress addr, SockType,
      [(TestAddress addr, AttenuatedChannel m)])
forall a b. a -> Wedge a b
Here (ConnectionId (TestAddress addr)
connId, FD_ m (TestAddress addr) -> SockType
forall (m :: * -> *) addr. FD_ m addr -> SockType
mkSockType FD_ m (TestAddress addr)
fd_, Connection m (TestAddress addr) -> AttenuatedChannel m
forall (m :: * -> *) addr. Connection m addr -> AttenuatedChannel m
connChannelLocal Connection m (TestAddress addr)
conn)
            FDConnected ConnectionId (TestAddress addr)
connId Connection m (TestAddress addr)
conn
              -> StrictTVar m (FD_ m (TestAddress addr))
-> FD_ m (TestAddress addr) -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (FD_ m (TestAddress addr))
fdVar (Wedge (ConnectionId (TestAddress addr)) (TestAddress addr)
-> FD_ m (TestAddress addr)
forall (m :: * -> *) addr.
Wedge (ConnectionId addr) addr -> FD_ m addr
FDClosed (ConnectionId (TestAddress addr)
-> Wedge (ConnectionId (TestAddress addr)) (TestAddress addr)
forall a b. a -> Wedge a b
Here ConnectionId (TestAddress addr)
connId))
              STM m ()
-> Wedge
     (ConnectionId (TestAddress addr), SockType, AttenuatedChannel m)
     (TestAddress addr, SockType,
      [(TestAddress addr, AttenuatedChannel m)])
-> STM
     m
     (Wedge
        (ConnectionId (TestAddress addr), SockType, AttenuatedChannel m)
        (TestAddress addr, SockType,
         [(TestAddress addr, AttenuatedChannel m)]))
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> (ConnectionId (TestAddress addr), SockType, AttenuatedChannel m)
-> Wedge
     (ConnectionId (TestAddress addr), SockType, AttenuatedChannel m)
     (TestAddress addr, SockType,
      [(TestAddress addr, AttenuatedChannel m)])
forall a b. a -> Wedge a b
Here (ConnectionId (TestAddress addr)
connId, FD_ m (TestAddress addr) -> SockType
forall (m :: * -> *) addr. FD_ m addr -> SockType
mkSockType FD_ m (TestAddress addr)
fd_, Connection m (TestAddress addr) -> AttenuatedChannel m
forall (m :: * -> *) addr. Connection m addr -> AttenuatedChannel m
connChannelLocal Connection m (TestAddress addr)
conn)
            FDListening TestAddress addr
localAddress TBQueue m (ChannelWithInfo m (TestAddress addr))
queue -> do
              StrictTVar m (FD_ m (TestAddress addr))
-> FD_ m (TestAddress addr) -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (FD_ m (TestAddress addr))
fdVar (Wedge (ConnectionId (TestAddress addr)) (TestAddress addr)
-> FD_ m (TestAddress addr)
forall (m :: * -> *) addr.
Wedge (ConnectionId addr) addr -> FD_ m addr
FDClosed (TestAddress addr
-> Wedge (ConnectionId (TestAddress addr)) (TestAddress addr)
forall a b. b -> Wedge a b
There TestAddress addr
localAddress))
              (\[ChannelWithInfo m (TestAddress addr)]
as -> (TestAddress addr, SockType,
 [(TestAddress addr, AttenuatedChannel m)])
-> Wedge
     (ConnectionId (TestAddress addr), SockType, AttenuatedChannel m)
     (TestAddress addr, SockType,
      [(TestAddress addr, AttenuatedChannel m)])
forall a b. b -> Wedge a b
There ( TestAddress addr
localAddress
                            , FD_ m (TestAddress addr) -> SockType
forall (m :: * -> *) addr. FD_ m addr -> SockType
mkSockType FD_ m (TestAddress addr)
fd_
                            , (ChannelWithInfo m (TestAddress addr)
 -> (TestAddress addr, AttenuatedChannel m))
-> [ChannelWithInfo m (TestAddress addr)]
-> [(TestAddress addr, AttenuatedChannel m)]
forall a b. (a -> b) -> [a] -> [b]
map (\ChannelWithInfo m (TestAddress addr)
a -> ( ChannelWithInfo m (TestAddress addr) -> TestAddress addr
forall (m :: * -> *) addr. ChannelWithInfo m addr -> addr
cwiAddress ChannelWithInfo m (TestAddress addr)
a, ChannelWithInfo m (TestAddress addr) -> AttenuatedChannel m
forall (m :: * -> *) addr.
ChannelWithInfo m addr -> AttenuatedChannel m
cwiChannelLocal ChannelWithInfo m (TestAddress addr)
a)) [ChannelWithInfo m (TestAddress addr)]
as
                            )) ([ChannelWithInfo m (TestAddress addr)]
 -> Wedge
      (ConnectionId (TestAddress addr), SockType, AttenuatedChannel m)
      (TestAddress addr, SockType,
       [(TestAddress addr, AttenuatedChannel m)]))
-> STM m [ChannelWithInfo m (TestAddress addr)]
-> STM
     m
     (Wedge
        (ConnectionId (TestAddress addr), SockType, AttenuatedChannel m)
        (TestAddress addr, SockType,
         [(TestAddress addr, AttenuatedChannel m)]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TBQueue m (ChannelWithInfo m (TestAddress addr))
-> STM m [ChannelWithInfo m (TestAddress addr)]
forall (m :: * -> *) a. MonadSTM m => TBQueue m a -> STM m [a]
drainTBQueue TBQueue m (ChannelWithInfo m (TestAddress addr))
queue
            FDClosed {} ->
              Wedge
  (ConnectionId (TestAddress addr), SockType, AttenuatedChannel m)
  (TestAddress addr, SockType,
   [(TestAddress addr, AttenuatedChannel m)])
-> STM
     m
     (Wedge
        (ConnectionId (TestAddress addr), SockType, AttenuatedChannel m)
        (TestAddress addr, SockType,
         [(TestAddress addr, AttenuatedChannel m)]))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Wedge
  (ConnectionId (TestAddress addr), SockType, AttenuatedChannel m)
  (TestAddress addr, SockType,
   [(TestAddress addr, AttenuatedChannel m)])
forall a b. Wedge a b
Nowhere

        -- trace 'STClosing'
        ((ConnectionId (TestAddress addr), SockType, AttenuatedChannel m)
 -> m ())
-> ((TestAddress addr, SockType,
     [(TestAddress addr, AttenuatedChannel m)])
    -> m ())
-> Wedge
     (ConnectionId (TestAddress addr), SockType, AttenuatedChannel m)
     (TestAddress addr, SockType,
      [(TestAddress addr, AttenuatedChannel m)])
-> m ()
forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bifoldable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f ()
bitraverse_
          (\(ConnectionId (TestAddress addr)
connId, SockType
fdType, AttenuatedChannel m
_) ->
              Tracer
  m (WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr)))
-> WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr))
-> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer
  m (WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr)))
tr (Maybe (TestAddress addr)
-> Maybe (TestAddress addr)
-> SnocketTrace m (TestAddress addr)
-> WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr))
forall addr event.
Maybe addr -> Maybe addr -> event -> WithAddr addr event
WithAddr (TestAddress addr -> Maybe (TestAddress addr)
forall a. a -> Maybe a
Just (ConnectionId (TestAddress addr) -> TestAddress addr
forall addr. ConnectionId addr -> addr
localAddress ConnectionId (TestAddress addr)
connId))
                                     (TestAddress addr -> Maybe (TestAddress addr)
forall a. a -> Maybe a
Just (ConnectionId (TestAddress addr) -> TestAddress addr
forall addr. ConnectionId addr -> addr
remoteAddress ConnectionId (TestAddress addr)
connId))
                                     (SockType
-> Wedge (ConnectionId (TestAddress addr)) [TestAddress addr]
-> SnocketTrace m (TestAddress addr)
forall (m :: * -> *) addr.
SockType -> Wedge (ConnectionId addr) [addr] -> SnocketTrace m addr
STClosing SockType
fdType (ConnectionId (TestAddress addr)
-> Wedge (ConnectionId (TestAddress addr)) [TestAddress addr]
forall a b. a -> Wedge a b
Here ConnectionId (TestAddress addr)
connId))))
          (\(TestAddress addr
addr, SockType
fdType, [(TestAddress addr, AttenuatedChannel m)]
as) ->
              Tracer
  m (WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr)))
-> WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr))
-> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer
  m (WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr)))
tr (Maybe (TestAddress addr)
-> Maybe (TestAddress addr)
-> SnocketTrace m (TestAddress addr)
-> WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr))
forall addr event.
Maybe addr -> Maybe addr -> event -> WithAddr addr event
WithAddr (TestAddress addr -> Maybe (TestAddress addr)
forall a. a -> Maybe a
Just TestAddress addr
addr)
                                     Maybe (TestAddress addr)
forall a. Maybe a
Nothing
                                     (SockType
-> Wedge (ConnectionId (TestAddress addr)) [TestAddress addr]
-> SnocketTrace m (TestAddress addr)
forall (m :: * -> *) addr.
SockType -> Wedge (ConnectionId addr) [addr] -> SnocketTrace m addr
STClosing SockType
fdType ([TestAddress addr]
-> Wedge (ConnectionId (TestAddress addr)) [TestAddress addr]
forall a b. b -> Wedge a b
There (((TestAddress addr, AttenuatedChannel m) -> TestAddress addr)
-> [(TestAddress addr, AttenuatedChannel m)] -> [TestAddress addr]
forall a b. (a -> b) -> [a] -> [b]
map (TestAddress addr, AttenuatedChannel m) -> TestAddress addr
forall a b. (a, b) -> a
fst [(TestAddress addr, AttenuatedChannel m)]
as)))))
          Wedge
  (ConnectionId (TestAddress addr), SockType, AttenuatedChannel m)
  (TestAddress addr, SockType,
   [(TestAddress addr, AttenuatedChannel m)])
wChannel

        -- close channels
        ((ConnectionId (TestAddress addr), SockType, AttenuatedChannel m)
 -> m ())
-> ((TestAddress addr, SockType,
     [(TestAddress addr, AttenuatedChannel m)])
    -> m ())
-> Wedge
     (ConnectionId (TestAddress addr), SockType, AttenuatedChannel m)
     (TestAddress addr, SockType,
      [(TestAddress addr, AttenuatedChannel m)])
-> m ()
forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bifoldable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f ()
bitraverse_
          (\(ConnectionId (TestAddress addr)
_, SockType
_, AttenuatedChannel m
chann)  -> AttenuatedChannel m -> m ()
forall (m :: * -> *). AttenuatedChannel m -> m ()
acClose AttenuatedChannel m
chann)
          (\(TestAddress addr
_, SockType
_, [(TestAddress addr, AttenuatedChannel m)]
channs) -> ((TestAddress addr, AttenuatedChannel m) -> m ())
-> [(TestAddress addr, AttenuatedChannel m)] -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (AttenuatedChannel m -> m ()
forall (m :: * -> *). AttenuatedChannel m -> m ()
acClose (AttenuatedChannel m -> m ())
-> ((TestAddress addr, AttenuatedChannel m) -> AttenuatedChannel m)
-> (TestAddress addr, AttenuatedChannel m)
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TestAddress addr, AttenuatedChannel m) -> AttenuatedChannel m
forall a b. (a, b) -> b
snd) [(TestAddress addr, AttenuatedChannel m)]
channs)
          Wedge
  (ConnectionId (TestAddress addr), SockType, AttenuatedChannel m)
  (TestAddress addr, SockType,
   [(TestAddress addr, AttenuatedChannel m)])
wChannel

        -- update NetworkState
        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
$ ((ConnectionId (TestAddress addr), SockType, AttenuatedChannel m)
 -> STM m ())
-> ((TestAddress addr, SockType,
     [(TestAddress addr, AttenuatedChannel m)])
    -> STM m ())
-> Wedge
     (ConnectionId (TestAddress addr), SockType, AttenuatedChannel m)
     (TestAddress addr, SockType,
      [(TestAddress addr, AttenuatedChannel m)])
-> STM m ()
forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bifoldable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f ()
bitraverse_
          (\(ConnectionId (TestAddress addr)
connId, SockType
_, AttenuatedChannel m
_) ->
             StrictTVar
  m
  (Map
     (NormalisedId (TestAddress addr))
     (Connection m (TestAddress addr)))
-> (Map
      (NormalisedId (TestAddress addr)) (Connection m (TestAddress addr))
    -> Map
         (NormalisedId (TestAddress addr))
         (Connection m (TestAddress addr)))
-> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar (NetworkState m (TestAddress addr)
-> StrictTVar
     m
     (Map
        (NormalisedId (TestAddress addr))
        (Connection m (TestAddress addr)))
forall (m :: * -> *) addr.
NetworkState m addr
-> StrictTVar m (Map (NormalisedId addr) (Connection m addr))
nsConnections NetworkState m (TestAddress addr)
state)
                        ((Connection m (TestAddress addr)
 -> Maybe (Connection m (TestAddress addr)))
-> NormalisedId (TestAddress addr)
-> Map
     (NormalisedId (TestAddress addr)) (Connection m (TestAddress addr))
-> Map
     (NormalisedId (TestAddress addr)) (Connection m (TestAddress addr))
forall k a. Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a
Map.update
                          (\conn :: Connection m (TestAddress addr)
conn@Connection { ConnectionState
connState :: ConnectionState
connState :: forall (m :: * -> *) addr. Connection m addr -> ConnectionState
connState } ->
                            case ConnectionState
connState of
                              ConnectionState
FIN ->
                                Maybe (Connection m (TestAddress addr))
forall a. Maybe a
Nothing
                              ConnectionState
_ ->
                                Connection m (TestAddress addr)
-> Maybe (Connection m (TestAddress addr))
forall a. a -> Maybe a
Just Connection m (TestAddress addr)
conn { connState :: ConnectionState
connState = ConnectionState
FIN })
                          (ConnectionId (TestAddress addr) -> NormalisedId (TestAddress addr)
forall addr. Ord addr => ConnectionId addr -> NormalisedId addr
normaliseId ConnectionId (TestAddress addr)
connId)))
          (\(TestAddress addr
addr,   SockType
_, [(TestAddress addr, AttenuatedChannel m)]
_) ->
             StrictTVar m (Map (TestAddress addr) (FD m (TestAddress addr)))
-> (Map (TestAddress addr) (FD m (TestAddress addr))
    -> Map (TestAddress addr) (FD m (TestAddress addr)))
-> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar (NetworkState m (TestAddress addr)
-> StrictTVar m (Map (TestAddress addr) (FD m (TestAddress addr)))
forall (m :: * -> *) addr.
NetworkState m addr -> StrictTVar m (Map addr (FD m addr))
nsListeningFDs NetworkState m (TestAddress addr)
state)
                        (TestAddress addr
-> Map (TestAddress addr) (FD m (TestAddress addr))
-> Map (TestAddress addr) (FD m (TestAddress addr))
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete TestAddress addr
addr))
          Wedge
  (ConnectionId (TestAddress addr), SockType, AttenuatedChannel m)
  (TestAddress addr, SockType,
   [(TestAddress addr, AttenuatedChannel m)])
wChannel

        -- trace 'STClosed'
        ((ConnectionId (TestAddress addr), SockType, AttenuatedChannel m)
 -> m ())
-> ((TestAddress addr, SockType,
     [(TestAddress addr, AttenuatedChannel m)])
    -> m ())
-> Wedge
     (ConnectionId (TestAddress addr), SockType, AttenuatedChannel m)
     (TestAddress addr, SockType,
      [(TestAddress addr, AttenuatedChannel m)])
-> m ()
forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bifoldable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f ()
bitraverse_
          (\(ConnectionId (TestAddress addr)
connId, SockType
fdType, AttenuatedChannel m
_) -> do
            Maybe ConnectionState
openState <- (Connection m (TestAddress addr) -> ConnectionState)
-> Maybe (Connection m (TestAddress addr)) -> Maybe ConnectionState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Connection m (TestAddress addr) -> ConnectionState
forall (m :: * -> *) addr. Connection m addr -> ConnectionState
connState (Maybe (Connection m (TestAddress addr)) -> Maybe ConnectionState)
-> (Map
      (NormalisedId (TestAddress addr)) (Connection m (TestAddress addr))
    -> Maybe (Connection m (TestAddress addr)))
-> Map
     (NormalisedId (TestAddress addr)) (Connection m (TestAddress addr))
-> Maybe ConnectionState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NormalisedId (TestAddress addr)
-> Map
     (NormalisedId (TestAddress addr)) (Connection m (TestAddress addr))
-> Maybe (Connection m (TestAddress addr))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (ConnectionId (TestAddress addr) -> NormalisedId (TestAddress addr)
forall addr. Ord addr => ConnectionId addr -> NormalisedId addr
normaliseId ConnectionId (TestAddress addr)
connId)
                     (Map
   (NormalisedId (TestAddress addr)) (Connection m (TestAddress addr))
 -> Maybe ConnectionState)
-> m (Map
        (NormalisedId (TestAddress addr))
        (Connection m (TestAddress addr)))
-> m (Maybe ConnectionState)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM
  m
  (Map
     (NormalisedId (TestAddress addr))
     (Connection m (TestAddress addr)))
-> m (Map
        (NormalisedId (TestAddress addr))
        (Connection m (TestAddress addr)))
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (StrictTVar
  m
  (Map
     (NormalisedId (TestAddress addr))
     (Connection m (TestAddress addr)))
-> STM
     m
     (Map
        (NormalisedId (TestAddress addr))
        (Connection m (TestAddress addr)))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (NetworkState m (TestAddress addr)
-> StrictTVar
     m
     (Map
        (NormalisedId (TestAddress addr))
        (Connection m (TestAddress addr)))
forall (m :: * -> *) addr.
NetworkState m addr
-> StrictTVar m (Map (NormalisedId addr) (Connection m addr))
nsConnections NetworkState m (TestAddress addr)
state))
            Tracer
  m (WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr)))
-> WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr))
-> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer
  m (WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr)))
tr (Maybe (TestAddress addr)
-> Maybe (TestAddress addr)
-> SnocketTrace m (TestAddress addr)
-> WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr))
forall addr event.
Maybe addr -> Maybe addr -> event -> WithAddr addr event
WithAddr (TestAddress addr -> Maybe (TestAddress addr)
forall a. a -> Maybe a
Just (ConnectionId (TestAddress addr) -> TestAddress addr
forall addr. ConnectionId addr -> addr
localAddress ConnectionId (TestAddress addr)
connId))
                                   (TestAddress addr -> Maybe (TestAddress addr)
forall a. a -> Maybe a
Just (ConnectionId (TestAddress addr) -> TestAddress addr
forall addr. ConnectionId addr -> addr
remoteAddress ConnectionId (TestAddress addr)
connId))
                                   (SockType
-> Maybe (Maybe ConnectionState)
-> SnocketTrace m (TestAddress addr)
forall (m :: * -> *) addr.
SockType -> Maybe (Maybe ConnectionState) -> SnocketTrace m addr
STClosed SockType
fdType (Maybe ConnectionState -> Maybe (Maybe ConnectionState)
forall a. a -> Maybe a
Just Maybe ConnectionState
openState)))

          )
          (\(TestAddress addr
addr, SockType
fdType, [(TestAddress addr, AttenuatedChannel m)]
_) ->
            Tracer
  m (WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr)))
-> WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr))
-> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer
  m (WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr)))
tr (Maybe (TestAddress addr)
-> Maybe (TestAddress addr)
-> SnocketTrace m (TestAddress addr)
-> WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr))
forall addr event.
Maybe addr -> Maybe addr -> event -> WithAddr addr event
WithAddr (TestAddress addr -> Maybe (TestAddress addr)
forall a. a -> Maybe a
Just TestAddress addr
addr)
                                   Maybe (TestAddress addr)
forall a. Maybe a
Nothing
                                   (SockType
-> Maybe (Maybe ConnectionState)
-> SnocketTrace m (TestAddress addr)
forall (m :: * -> *) addr.
SockType -> Maybe (Maybe ConnectionState) -> SnocketTrace m addr
STClosed SockType
fdType Maybe (Maybe ConnectionState)
forall a. Maybe a
Nothing))

          )
          Wedge
  (ConnectionId (TestAddress addr), SockType, AttenuatedChannel m)
  (TestAddress addr, SockType,
   [(TestAddress addr, AttenuatedChannel m)])
wChannel


    toBearer :: DiffTime
             -> Tracer m MuxTrace
             -> FD m (TestAddress addr)
             -> m (MuxBearer m)
    toBearer :: DiffTime
-> Tracer m MuxTrace -> FD m (TestAddress addr) -> m (MuxBearer m)
toBearer DiffTime
sduTimeout Tracer m MuxTrace
muxTracer fd :: FD m (TestAddress addr)
fd@FD { StrictTVar m (FD_ m (TestAddress addr))
fdVar :: StrictTVar m (FD_ m (TestAddress addr))
fdVar :: forall (m :: * -> *) peerAddr.
FD m peerAddr -> StrictTVar m (FD_ m peerAddr)
fdVar } = do
        FD_ m (TestAddress addr)
fd_ <- STM m (FD_ m (TestAddress addr)) -> m (FD_ m (TestAddress addr))
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (StrictTVar m (FD_ m (TestAddress addr))
-> STM m (FD_ m (TestAddress addr))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (FD_ m (TestAddress addr))
fdVar)
        case FD_ m (TestAddress addr)
fd_ of
          FDUninitialised {} ->
            IOError -> m (MuxBearer m)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (FD_ m (TestAddress addr) -> IOError
invalidError FD_ m (TestAddress addr)
fd_)
          FDListening {} ->
            IOError -> m (MuxBearer m)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (FD_ m (TestAddress addr) -> IOError
invalidError FD_ m (TestAddress addr)
fd_)
          FDConnecting ConnectionId (TestAddress addr)
_ Connection m (TestAddress addr)
_ -> do
            IOError -> m (MuxBearer m)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (FD_ m (TestAddress addr) -> IOError
invalidError FD_ m (TestAddress addr)
fd_)
          FDConnected ConnectionId (TestAddress addr)
_ Connection m (TestAddress addr)
conn -> do
            FD m (TestAddress addr)
-> SnocketTrace m (TestAddress addr) -> m ()
traceWith' FD m (TestAddress addr)
fd (FD_ m (TestAddress addr) -> SnocketTrace m (TestAddress addr)
forall (m :: * -> *) addr. FD_ m addr -> SnocketTrace m addr
STBearer FD_ m (TestAddress addr)
fd_)
            MuxBearer m -> m (MuxBearer m)
forall (m :: * -> *) a. Monad m => a -> m a
return (MuxBearer m -> m (MuxBearer m)) -> MuxBearer m -> m (MuxBearer m)
forall a b. (a -> b) -> a -> b
$ SDUSize
-> DiffTime
-> Tracer m MuxTrace
-> AttenuatedChannel m
-> MuxBearer m
forall (m :: * -> *).
(MonadThrow m, MonadMonotonicTime m) =>
SDUSize
-> DiffTime
-> Tracer m MuxTrace
-> AttenuatedChannel m
-> MuxBearer m
attenuationChannelAsMuxBearer (Connection m (TestAddress addr) -> SDUSize
forall (m :: * -> *) addr. Connection m addr -> SDUSize
connSDUSize Connection m (TestAddress addr)
conn)
                                                   DiffTime
sduTimeout Tracer m MuxTrace
muxTracer
                                                   (Connection m (TestAddress addr) -> AttenuatedChannel m
forall (m :: * -> *) addr. Connection m addr -> AttenuatedChannel m
connChannelLocal Connection m (TestAddress addr)
conn)
          FDClosed {} ->
            IOError -> m (MuxBearer m)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (FD_ m (TestAddress addr) -> IOError
invalidError FD_ m (TestAddress addr)
fd_)
      where
        -- io errors
        invalidError :: FD_ m (TestAddress addr) -> IOError
        invalidError :: FD_ m (TestAddress addr) -> IOError
invalidError FD_ m (TestAddress addr)
fd_ = IOError :: Maybe Handle
-> IOErrorType
-> String
-> String
-> Maybe CInt
-> Maybe String
-> IOError
IOError
          { ioe_handle :: Maybe Handle
ioe_handle      = Maybe Handle
forall a. Maybe a
Nothing
          , ioe_type :: IOErrorType
ioe_type        = IOErrorType
InvalidArgument
          , ioe_location :: String
ioe_location    = String
"Ouroboros.Network.Snocket.Sim.toBearer"
          , ioe_description :: String
ioe_description = String -> ShowS
forall r. PrintfType r => String -> r
printf String
"Invalid argument (%s)" (FD_ m (TestAddress addr) -> String
forall a. Show a => a -> String
show FD_ m (TestAddress addr)
fd_)
          , ioe_errno :: Maybe CInt
ioe_errno       = Maybe CInt
forall a. Maybe a
Nothing
          , ioe_filename :: Maybe String
ioe_filename    = Maybe String
forall a. Maybe a
Nothing
          }

--
-- Utils
--

hush :: Either a b -> Maybe b
hush :: Either a b -> Maybe b
hush Left {}   = Maybe b
forall a. Maybe a
Nothing
hush (Right b
a) = b -> Maybe b
forall a. a -> Maybe a
Just b
a
{-# INLINE hush #-}

drainTBQueue :: MonadSTM m => TBQueue m a -> STM m [a]
drainTBQueue :: TBQueue m a -> STM m [a]
drainTBQueue TBQueue m a
q = do
  Maybe a
ma <- TBQueue m a -> STM m (Maybe a)
forall (m :: * -> *) a.
MonadSTM m =>
TBQueue m a -> STM m (Maybe a)
tryReadTBQueue TBQueue m a
q
  case Maybe a
ma of
    Maybe a
Nothing -> [a] -> STM m [a]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    Just a
a  -> (a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
:) ([a] -> [a]) -> STM m [a] -> STM m [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TBQueue m a -> STM m [a]
forall (m :: * -> *) a. MonadSTM m => TBQueue m a -> STM m [a]
drainTBQueue TBQueue m a
q


-- | Return first element which satisfy the given predicate.
--
readTBQueueUntil :: MonadSTM m
                 => (a -> STM m Bool) -- ^ a monadic predicate
                 -> TBQueue m a  -- ^ queue
                 -> STM m a
readTBQueueUntil :: (a -> STM m Bool) -> TBQueue m a -> STM m a
readTBQueueUntil a -> STM m Bool
p TBQueue m a
q = do
  a
a <- TBQueue m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TBQueue m a -> STM m a
readTBQueue TBQueue m a
q
  Bool
b <- a -> STM m Bool
p a
a
  if Bool
b
     then a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
     else (a -> STM m Bool) -> TBQueue m a -> STM m a
forall (m :: * -> *) a.
MonadSTM m =>
(a -> STM m Bool) -> TBQueue m a -> STM m a
readTBQueueUntil a -> STM m Bool
p TBQueue m a
q