{-# LANGUAGE DerivingStrategies    #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE InstanceSigs          #-}
{-# LANGUAGE KindSignatures        #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# 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
  , makeFDBearer
  , GlobalAddressScheme (..)
  , AddressType (..)
  , WithAddr (..)
  ) where

import           Prelude hiding (read)

import           Control.Applicative (Alternative)
import qualified Control.Concurrent.Class.MonadSTM as LazySTM
import           Control.Concurrent.Class.MonadSTM.Strict
import           Control.Monad (when)
import           Control.Monad.Class.MonadThrow
import           Control.Monad.Class.MonadTime.SI
import           Control.Monad.Class.MonadTimer.SI
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 (SDUSize (..))
import           Network.Mux.Bearer.AttenuatedChannel

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.
      --
      forall (m :: * -> *) addr. Connection m addr -> AttenuatedChannel m
connChannelLocal  :: !(AttenuatedChannel m)
    , forall (m :: * -> *) addr. Connection m addr -> AttenuatedChannel m
connChannelRemote :: !(AttenuatedChannel m)

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

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

      -- | Provider of this Connection, so one can know its origin and decide
      -- accordingly when accepting/connecting a connection.
    , forall (m :: * -> *) addr. 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
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
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 :: forall (m :: * -> *) addr. 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 :: ( MonadDelay         m
                , MonadLabelledSTM   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 :: forall (m :: * -> *) addr.
(MonadDelay m, MonadLabelledSTM 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 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 } =
    (\(AttenuatedChannel m
connChannelLocal, AttenuatedChannel m
connChannelRemote) ->
      Connection {
          AttenuatedChannel m
connChannelLocal :: AttenuatedChannel m
connChannelLocal :: AttenuatedChannel m
connChannelLocal,
          AttenuatedChannel m
connChannelRemote :: AttenuatedChannel m
connChannelRemote :: AttenuatedChannel m
connChannelRemote,
          connSDUSize :: SDUSize
connSDUSize  = BearerInfo -> SDUSize
biSDUSize BearerInfo
bearerInfo,
          connState :: ConnectionState
connState    = ConnectionState
SYN_SENT,
          connProvider :: TestAddress addr
connProvider = TestAddress addr
localAddress
        })
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    forall (m :: * -> *).
(MonadDelay m, MonadLabelledSTM m, MonadTimer m, MonadThrow m,
 MonadThrow (STM m)) =>
Tracer m AttenuatedChannelTrace
-> Tracer m AttenuatedChannelTrace
-> Attenuation
-> Attenuation
-> STM m (AttenuatedChannel m, AttenuatedChannel m)
newConnectedAttenuatedChannelPair
      ( ( forall addr event.
Maybe addr -> Maybe addr -> event -> WithAddr addr event
WithAddr (forall a. a -> Maybe a
Just TestAddress addr
localAddress) (forall a. a -> Maybe a
Just TestAddress addr
remoteAddress)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) addr.
ConnectionId addr -> AttenuatedChannelTrace -> SnocketTrace m addr
STAttenuatedChannelTrace ConnectionId (TestAddress addr)
connId
        )
        forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
`contramap` Tracer
  m (WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr)))
tr)
      ( ( forall addr event.
Maybe addr -> Maybe addr -> event -> WithAddr addr event
WithAddr (forall a. a -> Maybe a
Just TestAddress addr
remoteAddress) (forall a. a -> Maybe a
Just TestAddress addr
localAddress)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) addr.
ConnectionId addr -> AttenuatedChannelTrace -> SnocketTrace m addr
STAttenuatedChannelTrace ConnectionId
            { localAddress :: TestAddress addr
localAddress  = TestAddress addr
remoteAddress
            , remoteAddress :: TestAddress addr
remoteAddress = TestAddress addr
localAddress
            }
        )
       forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
`contramap` Tracer
  m (WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr)))
tr)
      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
        { 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 id independent of who provisioned the connection. 'NormalisedId'
-- satisfies the invariant that for @NormalisedId {nidLow, nidHight}@ we have
-- @nidLow <= nidHigh@.
--
data NormalisedId addr = UnsafeNormalisedId
    { forall addr. NormalisedId addr -> addr
nidLow  :: !addr
    , forall addr. NormalisedId addr -> addr
nidHigh :: !addr
    }
  deriving (NormalisedId addr -> NormalisedId addr -> Bool
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, NormalisedId addr -> NormalisedId addr -> Bool
NormalisedId addr -> NormalisedId addr -> Ordering
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
Ord, Int -> NormalisedId addr -> ShowS
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 :: forall addr. Ord addr => 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 forall a. Ord a => a -> a -> Bool
<= addr
remoteAddress
    = forall addr. addr -> addr -> NormalisedId addr
UnsafeNormalisedId addr
localAddress addr
remoteAddress
    | Bool
otherwise
    = 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.
      --
      forall (m :: * -> *) addr.
NetworkState m addr -> StrictTVar m (Map addr (FD m addr))
nsListeningFDs      :: StrictTVar m (Map addr (FD m addr)),

      -- | Registry of active connections.
      --
      forall (m :: * -> *) addr.
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.
      --
      forall (m :: * -> *) addr.
NetworkState m addr -> AddressType -> STM m addr
nsNextEphemeralAddr :: AddressType -> STM m addr,

      forall (m :: * -> *) addr. NetworkState m addr -> BearerInfo
nsDefaultBearerInfo :: BearerInfo,

      -- | Get the BearerInfo Script for a given connection.
      --
      forall (m :: * -> *) addr.
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
      --
      forall addr.
ObservableNetworkState addr -> Map (NormalisedId addr) addr
onsConnections :: Map (NormalisedId addr) addr
    }
    deriving Int -> ObservableNetworkState addr -> ShowS
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
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
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} =
      forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"BearerInfo "
        , forall a. Show a => a -> String
show DiffTime
biConnectionDelay
        , String
" ("
        , forall a. Show a => a -> String
show Maybe Int
biInboundWriteFailure
        , String
") ("
        , forall a. Show a => a -> String
show Maybe Int
biOutboundWriteFailure
        , 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 { 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  = forall a. Maybe a
Nothing
                           , biOutboundWriteFailure :: Maybe Int
biOutboundWriteFailure = forall a. Maybe a
Nothing
                           , biAcceptFailures :: Maybe (DiffTime, IOErrType)
biAcceptFailures       = 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 :: 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 = forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically forall a b. (a -> b) -> a -> b
$ do
  (StrictTVar m Natural
v :: 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 <- 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' = forall a. Enum a => a -> a
succ Natural
s in (Natural
s', Natural
s'))
         forall (m :: * -> *) a. Monad m => a -> m a
return (forall addr.
GlobalAddressScheme addr =>
AddressType -> Natural -> TestAddress addr
ephemeralAddress AddressType
addrType Natural
a)

  Map
  (NormalisedId (TestAddress peerAddr)) (TVar m (Script BearerInfo))
scriptMapVars <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse 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 <- 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
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadSTM m => a -> STM m (StrictTVar m a)
newTVar forall k a. Map k a
Map.empty
    -- nsConnections
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a. MonadSTM m => a -> STM m (StrictTVar m a)
newTVar forall k a. Map k a
Map.empty
    -- nsNextEphemeralAddr
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure AddressType -> STM m (TestAddress peerAddr)
nextEphemeralAddr
    -- nsBearerInfo
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure BearerInfo
defaultBearerInfo
    -- attenuationMap
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Map
  (NormalisedId (TestAddress peerAddr)) (TVar m (Script BearerInfo))
scriptMapVars

  forall (m :: * -> *) a.
MonadLabelledSTM m =>
StrictTVar m a -> String -> STM m ()
labelTVar (forall (m :: * -> *) addr.
NetworkState m addr -> StrictTVar m (Map addr (FD m addr))
nsListeningFDs NetworkState m (TestAddress peerAddr)
s)   String
"nsListeningFDs"
  forall (m :: * -> *) a.
MonadLabelledSTM m =>
StrictTVar m a -> String -> STM m ()
labelTVar (forall (m :: * -> *) addr.
NetworkState m addr
-> StrictTVar m (Map (NormalisedId addr) (Connection m addr))
nsConnections NetworkState m (TestAddress peerAddr)
s)    String
"nsConnections"
  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
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 forall a. Integral a => a -> a -> a
`mod` Int
2 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 = forall addr. addr -> TestAddress addr
TestAddress forall a b. (a -> b) -> a -> b
$ (-Int
2) forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
n
    ephemeralAddress AddressType
IPv6Address Natural
n = forall addr. addr -> TestAddress addr
TestAddress forall a b. (a -> b) -> a -> b
$ (-Int
1) forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
n 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.
       ( Alternative (STM m)
       , MonadDelay       m
       , MonadLabelledSTM m
       , MonadMask        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 :: forall (m :: * -> *) peerAddr a.
(Alternative (STM m), MonadDelay m, MonadLabelledSTM m,
 MonadMask 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)))
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 <- 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 (forall (m :: * -> *) addr.
(Alternative (STM m), MonadDelay m, MonadLabelledSTM m,
 MonadThrow (STM m), MonadMask 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)
         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 (forall a. a -> Maybe a
Just SomeException
e)
                  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO Maybe (ResourceException (TestAddress peerAddr))
re
                  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 forall a. Maybe a
Nothing
    forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO Maybe (ResourceException (TestAddress peerAddr))
re
    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) <- forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically forall a b. (a -> b) -> a -> b
$ (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar
  m (Map (TestAddress peerAddr) (FD m (TestAddress peerAddr)))
nsListeningFDs
                                              forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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 (forall k a. Map k a -> Bool
Map.null Map (TestAddress peerAddr) (FD m (TestAddress peerAddr))
lstFDMap)
         -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (forall addr.
[addr] -> Maybe SomeException -> ResourceException addr
NotReleasedListeningSockets (forall k a. Map k a -> [k]
Map.keys Map (TestAddress peerAddr) (FD m (TestAddress peerAddr))
lstFDMap) Maybe SomeException
err)

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

         |  Bool
otherwise
         -> forall (m :: * -> *) a. Monad m => a -> m a
return   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 = forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically forall a b. (a -> b) -> a -> b
$ do
        Map (NormalisedId (TestAddress peerAddr)) (TestAddress peerAddr)
onsConnections <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (m :: * -> *) addr. Connection m addr -> addr
connProvider forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (forall (m :: * -> *) addr.
NetworkState m addr
-> StrictTVar m (Map (NormalisedId addr) (Connection m addr))
nsConnections NetworkState m (TestAddress peerAddr)
ns)
        forall (m :: * -> *) a. Monad m => a -> m a
return (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 {
    forall (m :: * -> *) addr. ChannelWithInfo m addr -> addr
cwiAddress       :: !addr,
    forall (m :: * -> *) addr. ChannelWithInfo m addr -> SDUSize
cwiSDUSize       :: !SDUSize,
    forall (m :: * -> *) addr.
ChannelWithInfo m addr -> AttenuatedChannel m
cwiChannelLocal  :: !(AttenuatedChannel m),
    forall (m :: * -> *) addr.
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

        !(StrictTBQueue 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 " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Maybe addr
mbAddr
    show (FDListening addr
addr StrictTBQueue m (ChannelWithInfo m addr)
_)       = String
"FDListening " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show addr
addr
    show (FDConnecting ConnectionId addr
connId Connection m addr
conn) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                                    [ String
"FDConnecting "
                                    , forall a. Show a => a -> String
show ConnectionId addr
connId
                                    , String
" "
                                    , forall a. Show a => a -> String
show (forall (m :: * -> *) addr. Connection m addr -> SDUSize
connSDUSize Connection m addr
conn)
                                    ]
    show (FDConnected ConnectionId addr
connId Connection m addr
conn)  = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                                    [ String
"FDConnected "
                                    , forall a. Show a => a -> String
show ConnectionId addr
connId
                                    , String
" "
                                    , forall a. Show a => a -> String
show (forall (m :: * -> *) addr. Connection m addr -> SDUSize
connSDUSize Connection m addr
conn)
                                    ]
    show (FDClosed Wedge (ConnectionId addr) addr
mbConnId)        = String
"FDClosed " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Wedge (ConnectionId addr) addr
mbConnId


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


makeFDBearer :: forall addr m.
                ( MonadMonotonicTime m
                , MonadSTM   m
                , MonadThrow m
                , Show addr
                )
             => MakeBearer m (FD m (TestAddress addr))
makeFDBearer :: forall addr (m :: * -> *).
(MonadMonotonicTime m, MonadSTM m, MonadThrow m, Show addr) =>
MakeBearer m (FD m (TestAddress addr))
makeFDBearer = forall (m :: * -> *) fd.
(DiffTime -> Tracer m MuxTrace -> fd -> m (MuxBearer m))
-> MakeBearer m fd
MakeBearer forall a b. (a -> b) -> a -> b
$ \DiffTime
sduTimeout Tracer m MuxTrace
muxTracer 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_ <- forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (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 {} ->
            forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (FD_ m (TestAddress addr) -> IOError
invalidError FD_ m (TestAddress addr)
fd_)
          FDListening {} ->
            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
            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
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadThrow m, MonadMonotonicTime m) =>
SDUSize
-> DiffTime
-> Tracer m MuxTrace
-> AttenuatedChannel m
-> MuxBearer m
attenuationChannelAsMuxBearer (forall (m :: * -> *) addr. Connection m addr -> SDUSize
connSDUSize Connection m (TestAddress addr)
conn)
                                                   DiffTime
sduTimeout Tracer m MuxTrace
muxTracer
                                                   (forall (m :: * -> *) addr. Connection m addr -> AttenuatedChannel m
connChannelLocal Connection m (TestAddress addr)
conn)
          FDClosed {} ->
            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
          { ioe_handle :: Maybe Handle
ioe_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 = forall r. PrintfType r => String -> r
printf String
"Invalid argument (%s)" (forall a. Show a => a -> String
show FD_ m (TestAddress addr)
fd_)
          , ioe_errno :: Maybe CInt
ioe_errno       = forall a. Maybe a
Nothing
          , ioe_filename :: Maybe String
ioe_filename    = forall a. Maybe a
Nothing
          }

--
-- Simulated snockets
--

-- TODO: use `Ouroboros.Network.ExitPolicy.WithAddr`
data WithAddr addr event =
    WithAddr { forall addr event. WithAddr addr event -> Maybe addr
waLocalAddr  :: Maybe addr
             , forall addr event. WithAddr addr event -> Maybe addr
waRemoteAddr :: Maybe addr
             , forall addr event. WithAddr addr event -> event
waEvent      :: event
             }
  deriving Int -> WithAddr addr event -> ShowS
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
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 :: forall (m :: * -> *) addr. 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
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
    | STAttenuatedChannelTrace (ConnectionId addr) AttenuatedChannelTrace
  deriving Int -> SnocketTrace m addr -> ShowS
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
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.
             ( Alternative   (STM m)
             , MonadDelay         m
             , MonadLabelledSTM   m
             , MonadThrow    (STM m)
             , MonadMask          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 :: forall (m :: * -> *) addr.
(Alternative (STM m), MonadDelay m, MonadLabelledSTM m,
 MonadThrow (STM m), MonadMask 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)
state Tracer
  m (WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr)))
tr = 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
                             }
  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_ <- forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (FD_ m (TestAddress addr))
fdVar)
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case FD_ m (TestAddress addr)
fd_ of
          FDUninitialised Maybe (TestAddress addr)
Nothing         -> forall a b. a -> Either a b
Left FD_ m (TestAddress addr)
fd_
          FDUninitialised (Just TestAddress addr
peerAddr) -> forall a b. b -> Either a b
Right TestAddress addr
peerAddr
          FDListening TestAddress addr
peerAddr StrictTBQueue m (ChannelWithInfo m (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)
_
                                          -> 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)
_
                                          -> forall a b. b -> Either a b
Right TestAddress addr
localAddress
          FDClosed {}                     -> 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_ <- forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (FD_ m (TestAddress addr))
fdVar)
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case FD_ m (TestAddress addr)
fd_ of
          FDUninitialised {}         -> forall a b. a -> Either a b
Left FD_ m (TestAddress addr)
fd_
          FDListening {}             -> 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)
_
                                     -> 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)
_
                                     -> forall a b. b -> Either a b
Right TestAddress addr
remoteAddress
          FDClosed {}                -> 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 -> forall addr event.
Maybe addr -> Maybe addr -> event -> WithAddr addr event
WithAddr (forall a b. Either a b -> Maybe b
hush Either (FD_ m (TestAddress addr)) (TestAddress addr)
a)
                                          (forall a b. Either a b -> Maybe b
hush Either (FD_ m (TestAddress addr)) (TestAddress addr)
b) SnocketTrace m (TestAddress addr)
ev)
                    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
                    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)
                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 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 -> 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_   -> 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
                { ioe_handle :: Maybe Handle
ioe_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 = forall r. PrintfType r => String -> r
printf String
"Transport endpoint (%s) is not connected" (forall a. Show a => a -> String
show FD_ m (TestAddress addr)
fd_)
                , ioe_errno :: Maybe CInt
ioe_errno       = forall a. Maybe a
Nothing
                , ioe_filename :: Maybe String
ioe_filename    = 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return TestAddress addr
addr
        Left FD_ m (TestAddress addr)
fd_   -> 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
          { ioe_handle :: Maybe Handle
ioe_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 = forall r. PrintfType r => String -> r
printf String
"Transport endpoint is not connected" (forall a. Show a => a -> String
show FD_ m (TestAddress addr)
fd_)
          , ioe_errno :: Maybe CInt
ioe_errno       = forall a. Maybe a
Nothing
          , ioe_filename :: Maybe String
ioe_filename    = forall a. Maybe a
Nothing
          }


    addrFamily :: TestAddress addr -> AddressFamily (TestAddress addr)
    addrFamily :: TestAddress addr -> AddressFamily (TestAddress addr)
addrFamily 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)
_ = forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically forall a b. (a -> b) -> a -> b
$ do
      StrictTVar m (FD_ m (TestAddress addr))
fdVar <- forall (m :: * -> *) a. MonadSTM m => a -> STM m (StrictTVar m a)
newTVar (forall (m :: * -> *) addr. Maybe addr -> FD_ m addr
FDUninitialised forall a. Maybe a
Nothing)
      forall (m :: * -> *) a.
MonadLabelledSTM m =>
StrictTVar m a -> String -> STM m ()
labelTVar StrictTVar m (FD_ m (TestAddress addr))
fdVar String
"fd"
      forall (m :: * -> *) a. Monad m => a -> m a
return 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 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_ <- forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (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 (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 (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
mask forall a b. (a -> b) -> a -> b
$ \forall a. m a -> m a
unmask -> do
            (ConnectionId (TestAddress addr)
connId, BearerInfo
bearerInfo, OpenType
simOpen) <- forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically forall a b. (a -> b) -> a -> b
$ do
              TestAddress addr
localAddress <-
                case Maybe (TestAddress addr)
mbLocalAddr of
                  Just TestAddress addr
addr -> forall (m :: * -> *) a. Monad m => a -> m a
return TestAddress addr
addr
                  Maybe (TestAddress addr)
Nothing   -> forall (m :: * -> *) addr.
NetworkState m addr -> AddressType -> STM m addr
nsNextEphemeralAddr NetworkState m (TestAddress addr)
state (forall addr.
GlobalAddressScheme addr =>
TestAddress addr -> AddressType
getAddressType TestAddress addr
remoteAddress)

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

              BearerInfo
bearerInfo <- case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup NormalisedId (TestAddress addr)
normalisedId (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     -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall (m :: * -> *) addr. NetworkState m addr -> BearerInfo
nsDefaultBearerInfo NetworkState m (TestAddress addr)
state)
                Just TVar m (Script BearerInfo)
script -> 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 <- forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (forall (m :: * -> *) addr.
NetworkState m addr
-> StrictTVar m (Map (NormalisedId addr) (Connection m addr))
nsConnections NetworkState m (TestAddress addr)
state)
              case 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 } ->
                  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_)

                Just      Connection { connState :: forall (m :: * -> *) addr. Connection m addr -> ConnectionState
connState = ConnectionState
SYN_SENT, TestAddress addr
connProvider :: TestAddress addr
connProvider :: forall (m :: * -> *) addr. Connection m addr -> addr
connProvider }
                        | TestAddress addr
connProvider forall a. Eq a => a -> a -> Bool
== TestAddress addr
localAddress ->
                  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 }
                  forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (FD_ m (TestAddress addr))
fdVarLocal (forall (m :: * -> *) addr.
ConnectionId addr -> Connection m addr -> FD_ m addr
FDConnecting ConnectionId (TestAddress addr)
connId Connection m (TestAddress addr)
conn')
                  forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar (forall (m :: * -> *) addr.
NetworkState m addr
-> StrictTVar m (Map (NormalisedId addr) (Connection m addr))
nsConnections NetworkState m (TestAddress addr)
state)
                             (forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust (forall a b. a -> b -> a
const Connection m (TestAddress addr)
conn')
                                         (forall addr. Ord addr => ConnectionId addr -> NormalisedId addr
normaliseId ConnectionId (TestAddress addr)
connId))
                  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 } ->
                  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 <- forall (m :: * -> *) addr.
(MonadDelay m, MonadLabelledSTM 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
                  forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (FD_ m (TestAddress addr))
fdVarLocal (forall (m :: * -> *) addr.
ConnectionId addr -> Connection m addr -> FD_ m addr
FDConnecting ConnectionId (TestAddress addr)
connId Connection m (TestAddress addr)
conn)
                  forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar (forall (m :: * -> *) addr.
NetworkState m addr
-> StrictTVar m (Map (NormalisedId addr) (Connection m addr))
nsConnections NetworkState m (TestAddress addr)
state)
                             (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (forall addr. Ord addr => ConnectionId addr -> NormalisedId addr
normaliseId ConnectionId (TestAddress addr)
connId) 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
                  forall (m :: * -> *) a. Monad m => a -> m a
return (ConnectionId (TestAddress addr)
connId, BearerInfo
bearerInfo, OpenType
NormalOpen)

            forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer
  m (WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr)))
tr (forall addr event.
Maybe addr -> Maybe addr -> event -> WithAddr addr event
WithAddr (forall a. a -> Maybe a
Just (forall addr. ConnectionId addr -> addr
localAddress ConnectionId (TestAddress addr)
connId))
                                   (forall a. a -> Maybe a
Just TestAddress addr
remoteAddress)
                                   (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 <-
              forall (m :: * -> *). MonadTimer m => DiffTime -> m (TVar m Bool)
registerDelay (BearerInfo -> DiffTime
biConnectionDelay BearerInfo
bearerInfo forall a. Ord a => a -> a -> a
`min` DiffTime
connectTimeout)
            forall a. m a -> m a
unmask
              (forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. FirstToFinish m a -> m a
runFirstToFinish forall a b. (a -> b) -> a -> b
$
                  forall (m :: * -> *) a. m a -> FirstToFinish m a
FirstToFinish
                    (forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
LazySTM.readTVar TVar m Bool
connDelayTimeoutVar forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). MonadSTM m => Bool -> STM m ()
check)
                  forall a. Semigroup a => a -> a -> a
<>
                  forall (m :: * -> *) a. m a -> FirstToFinish m a
FirstToFinish (do
                    Bool
b <- Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> Map k a -> Bool
Map.member (forall addr. Ord addr => ConnectionId addr -> NormalisedId addr
normaliseId ConnectionId (TestAddress addr)
connId)
                      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (forall (m :: * -> *) addr.
NetworkState m addr
-> StrictTVar m (Map (NormalisedId addr) (Connection m addr))
nsConnections NetworkState m (TestAddress addr)
state)
                    forall (m :: * -> *). MonadSTM m => Bool -> STM m ()
check Bool
b
                    forall (m :: * -> *) e a.
(MonadSTM m, MonadThrow (STM m), Exception e) =>
e -> STM m a
throwSTM forall a b. (a -> b) -> a -> b
$ ConnectionId (TestAddress addr) -> String -> IOError
connectIOError ConnectionId (TestAddress addr)
connId
                             forall a b. (a -> b) -> a -> b
$ String
"unknown connection: "
                            forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall addr. Ord addr => ConnectionId addr -> NormalisedId addr
normaliseId ConnectionId (TestAddress addr)
connId))
              )
              forall (m :: * -> *) a b. MonadCatch m => m a -> m b -> m a
`onException`
                -- In the SimOpen case, it can happen that 1 end of the
                -- connection receives an asynchronous exception and we don't
                -- want to remove the connection from the state in this case.
                -- This is because in the SimOpen case 1 of the connect calls
                -- would succeed, and right after that the other end (the one
                -- that got the async exception) would remove the connection
                -- wrongfully leading to an inconsistent state where there's an
                -- end of the connection that holds a successful connection that
                -- does not exist in the state.
                (case OpenType
simOpen of
                  OpenType
NormalOpen ->
                    forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar (forall (m :: * -> *) addr.
NetworkState m addr
-> StrictTVar m (Map (NormalisedId addr) (Connection m addr))
nsConnections NetworkState m (TestAddress addr)
state)
                                           (forall k a. Ord k => k -> Map k a -> Map k a
Map.delete (forall addr. Ord addr => ConnectionId addr -> NormalisedId addr
normaliseId ConnectionId (TestAddress addr)
connId)))
                  OpenType
SimOpen -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                )

            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BearerInfo -> DiffTime
biConnectionDelay BearerInfo
bearerInfo forall a. Ord a => a -> a -> Bool
>= DiffTime
connectTimeout) forall a b. (a -> b) -> a -> b
$ do
              FD m (TestAddress addr)
-> SnocketTrace m (TestAddress addr) -> m ()
traceWith' FD m (TestAddress addr)
fd (forall (m :: * -> *) addr. TimeoutDetail -> SnocketTrace m addr
STConnectTimeout TimeoutDetail
WaitingToConnect)
              forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar (forall (m :: * -> *) addr.
NetworkState m addr
-> StrictTVar m (Map (NormalisedId addr) (Connection m addr))
nsConnections NetworkState m (TestAddress addr)
state)
                                      (forall k a. Ord k => k -> Map k a -> Map k a
Map.delete (forall addr. Ord addr => ConnectionId addr -> NormalisedId addr
normaliseId ConnectionId (TestAddress addr)
connId))
              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 <- forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically forall a b. (a -> b) -> a -> b
$ do
              Map (TestAddress addr) (FD m (TestAddress addr))
lstMap <- forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (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  <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) peerAddr.
FD m peerAddr -> StrictTVar m (FD_ m peerAddr)
fdVar)
                                 (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  <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (forall addr. Ord addr => ConnectionId addr -> NormalisedId addr
normaliseId ConnectionId (TestAddress addr)
connId)
                    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (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) ->
                  forall (m :: * -> *) a. Monad m => a -> m a
return (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 {}) ->
                  forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left (ConnectionId (TestAddress addr) -> String -> IOError
connectIOError ConnectionId (TestAddress addr)
connId String
"unitialised listening socket"))
                (Just FDConnecting {}) ->
                  forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left (FD_ m (TestAddress addr) -> IOError
invalidError FD_ m (TestAddress addr)
fd_))
                (Just FDConnected {}) ->
                  forall (m :: * -> *) a. Monad m => a -> m a
return (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 {}) ->
                  forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left IOError
notConnectedIOError)

                (Just (FDListening TestAddress addr
_ StrictTBQueue 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_' = forall (m :: * -> *) addr.
ConnectionId addr -> Connection m addr -> FD_ m addr
FDConnected ConnectionId (TestAddress addr)
connId
                               forall a b. (a -> b) -> a -> b
$ case OpenType
simOpen of
                                   OpenType
SimOpen    -> forall (m :: * -> *) addr. Connection m addr -> Connection m addr
dualConnection Connection m (TestAddress addr)
conn
                                   OpenType
NormalOpen ->                Connection m (TestAddress addr)
conn
                      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_'
                      forall (m :: * -> *) a. Monad m => a -> m a
return (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_' = forall (m :: * -> *) addr.
ConnectionId addr -> Connection m addr -> FD_ m addr
FDConnected ConnectionId (TestAddress addr)
connId Connection m (TestAddress addr)
conn
                      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_'
                      forall (m :: * -> *) a.
MonadSTM m =>
StrictTBQueue m a -> a -> STM m ()
writeTBQueue StrictTBQueue m (ChannelWithInfo m (TestAddress addr))
queue
                                   ChannelWithInfo
                                     { cwiAddress :: TestAddress addr
cwiAddress       = forall addr. ConnectionId addr -> addr
localAddress ConnectionId (TestAddress addr)
connId
                                     , cwiSDUSize :: SDUSize
cwiSDUSize       = BearerInfo -> SDUSize
biSDUSize BearerInfo
bearerInfo
                                     , cwiChannelLocal :: AttenuatedChannel m
cwiChannelLocal  = forall (m :: * -> *) addr. Connection m addr -> AttenuatedChannel m
connChannelRemote Connection m (TestAddress addr)
conn
                                     , cwiChannelRemote :: AttenuatedChannel m
cwiChannelRemote = forall (m :: * -> *) addr. Connection m addr -> AttenuatedChannel m
connChannelLocal Connection m (TestAddress addr)
conn
                                     }
                      forall (m :: * -> *) a. Monad m => a -> m a
return (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
                      forall (m :: * -> *) a. Monad m => a -> m a
return (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 ->
                      forall (m :: * -> *) a. Monad m => a -> m a
return (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 (forall (m :: * -> *) addr.
FD_ m addr -> addr -> IOError -> SnocketTrace m addr
STConnectError FD_ m (TestAddress addr)
fd_ TestAddress addr
remoteAddress IOError
e)
                forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar (forall (m :: * -> *) addr.
NetworkState m addr
-> StrictTVar m (Map (NormalisedId addr) (Connection m addr))
nsConnections NetworkState m (TestAddress addr)
state)
                                        (forall k a. Ord k => k -> Map k a -> Map k a
Map.delete (forall addr. Ord addr => ConnectionId addr -> NormalisedId addr
normaliseId ConnectionId (TestAddress addr)
connId))
                forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO IOError
e

              -- TODO: SimOpen and NormalOpen are irrelevant here
              -- If 'o' is SimOpen then 'connState' is already 'ESTABLISHED'
              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 <-
                  forall (m :: * -> *). MonadTimer m => DiffTime -> m (TVar m Bool)
registerDelay (DiffTime
connectTimeout forall a. Num a => a -> a -> a
- BearerInfo -> DiffTime
biConnectionDelay BearerInfo
bearerInfo)
                Maybe ()
r <-
                  forall (m :: * -> *) e b a.
(MonadCatch m, Exception e) =>
(e -> Maybe b) -> (b -> m a) -> m a -> m a
handleJust
                    (\SomeException
e -> case forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
                             Just SomeAsyncException {} -> forall a. a -> Maybe a
Just SomeException
e
                             Maybe SomeAsyncException
Nothing                    -> forall a. Maybe a
Nothing)
                    (\SomeException
e -> forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar (forall (m :: * -> *) addr.
NetworkState m addr
-> StrictTVar m (Map (NormalisedId addr) (Connection m addr))
nsConnections NetworkState m (TestAddress addr)
state)
                                                   (forall k a. Ord k => k -> Map k a -> Map k a
Map.delete (forall addr. Ord addr => ConnectionId addr -> NormalisedId addr
normaliseId ConnectionId (TestAddress addr)
connId))
                        forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO SomeException
e)
                    forall a b. (a -> b) -> a -> b
$ forall a. m a -> m a
unmask (forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. FirstToFinish m a -> m a
runFirstToFinish forall a b. (a -> b) -> a -> b
$
                        (forall (m :: * -> *) a. m a -> FirstToFinish m a
FirstToFinish forall a b. (a -> b) -> a -> b
$ do
                          forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
LazySTM.readTVar TVar m Bool
timeoutVar forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). MonadSTM m => Bool -> STM m ()
check
                          forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar (forall (m :: * -> *) addr.
NetworkState m addr
-> StrictTVar m (Map (NormalisedId addr) (Connection m addr))
nsConnections NetworkState m (TestAddress addr)
state)
                                     (forall k a. Ord k => k -> Map k a -> Map k a
Map.delete (forall addr. Ord addr => ConnectionId addr -> NormalisedId addr
normaliseId ConnectionId (TestAddress addr)
connId))
                          forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
                        )
                        forall a. Semigroup a => a -> a -> a
<>
                        (forall (m :: * -> *) a. m a -> FirstToFinish m a
FirstToFinish forall a b. (a -> b) -> a -> b
$ do
                          Maybe (Connection m (TestAddress addr))
mbConn <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (forall addr. Ord addr => ConnectionId addr -> NormalisedId addr
normaliseId ConnectionId (TestAddress addr)
connId)
                                forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (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
                              forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar (forall (m :: * -> *) addr.
NetworkState m addr
-> StrictTVar m (Map (NormalisedId addr) (Connection m addr))
nsConnections NetworkState m (TestAddress addr)
state)
                                         (forall k a. Ord k => k -> Map k a -> Map k a
Map.delete (forall addr. Ord addr => ConnectionId addr -> NormalisedId addr
normaliseId ConnectionId (TestAddress addr)
connId))
                              forall (m :: * -> *) e a.
(MonadSTM m, MonadThrow (STM m), Exception e) =>
e -> STM m a
throwSTM forall a b. (a -> b) -> a -> b
$ ConnectionId (TestAddress addr) -> String -> IOError
connectIOError ConnectionId (TestAddress addr)
connId
                                       forall a b. (a -> b) -> a -> b
$ String
"unknown connection: "
                                      forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (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 } ->
                              forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadSTM m => Bool -> STM m ()
check (ConnectionState
connState 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 (forall (m :: * -> *) addr. TimeoutDetail -> SnocketTrace m addr
STConnectTimeout TimeoutDetail
WaitingToBeAccepted)
                    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 (forall (m :: * -> *) addr.
FD_ m addr -> OpenType -> SnocketTrace m addr
STConnected FD_ m (TestAddress addr)
fd_' OpenType
o)

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

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

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

          FDClosed {} ->
            forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO IOError
notConnectedIOError
      where
        notConnectedIOError :: IOError
notConnectedIOError = IOError
          { ioe_handle :: Maybe Handle
ioe_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       = forall a. Maybe a
Nothing
          , ioe_filename :: Maybe String
ioe_filename    = 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
          { ioe_handle :: Maybe Handle
ioe_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 = forall r. PrintfType r => String -> r
printf String
"connect failure (%s): (%s)" (forall a. Show a => a -> String
show ConnectionId (TestAddress addr)
connId) String
desc
          , ioe_errno :: Maybe CInt
ioe_errno       = forall a. Maybe a
Nothing
          , ioe_filename :: Maybe String
ioe_filename    = forall a. Maybe a
Nothing
          }

        connectedIOError :: FD_ m (TestAddress addr) -> IOError
        connectedIOError :: FD_ m (TestAddress addr) -> IOError
connectedIOError FD_ m (TestAddress addr)
fd_ = IOError
          { ioe_handle :: Maybe Handle
ioe_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 = forall r. PrintfType r => String -> r
printf String
"Transport endpoint (%s) is already connected" (forall a. Show a => a -> String
show FD_ m (TestAddress addr)
fd_)
          , ioe_errno :: Maybe CInt
ioe_errno       = forall a. Maybe a
Nothing
          , ioe_filename :: Maybe String
ioe_filename    = forall a. Maybe a
Nothing
          }

        invalidError :: FD_ m (TestAddress addr) -> IOError
        invalidError :: FD_ m (TestAddress addr) -> IOError
invalidError FD_ m (TestAddress addr)
fd_ = IOError
          { ioe_handle :: Maybe Handle
ioe_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 = forall r. PrintfType r => String -> r
printf String
"Invalid argument (%s)" (forall a. Show a => a -> String
show FD_ m (TestAddress addr)
fd_)
          , ioe_errno :: Maybe CInt
ioe_errno       = forall a. Maybe a
Nothing
          , ioe_filename :: Maybe String
ioe_filename    = 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 <- forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically forall a b. (a -> b) -> a -> b
$ do
          FD_ m (TestAddress addr)
fd_ <- 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
              forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (FD_ m (TestAddress addr))
fdVar (forall (m :: * -> *) addr. Maybe addr -> FD_ m addr
FDUninitialised (forall a. a -> Maybe a
Just TestAddress addr
addr))
              forall (m :: * -> *) a.
MonadLabelledSTM m =>
StrictTVar m a -> String -> STM m ()
labelTVar StrictTVar m (FD_ m (TestAddress addr))
fdVar (String
"fd-" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show TestAddress addr
addr)
              forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
            FD_ m (TestAddress addr)
_ ->
              forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (FD_ m (TestAddress addr)
fd_, 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       -> 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 (forall (m :: * -> *) addr.
FD_ m addr -> addr -> IOError -> SnocketTrace m addr
STBindError FD_ m (TestAddress addr)
fd_ TestAddress addr
addr IOError
e)
                        forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO IOError
e
      where
        invalidError :: a -> IOError
invalidError a
fd_ = IOError
          { ioe_handle :: Maybe Handle
ioe_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 = forall r. PrintfType r => String -> r
printf String
"Invalid argument (%s)" (forall a. Show a => a -> String
show a
fd_)
          , ioe_errno :: Maybe CInt
ioe_errno       = forall a. Maybe a
Nothing
          , ioe_filename :: Maybe String
ioe_filename    = 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 } = forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically forall a b. (a -> b) -> a -> b
$ do
        FD_ m (TestAddress addr)
fd_ <- 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;
            forall (m :: * -> *) e a.
(MonadSTM m, MonadThrow (STM m), Exception e) =>
e -> STM m a
throwSTM forall a b. (a -> b) -> a -> b
$ FD_ m (TestAddress addr) -> IOError
invalidError FD_ m (TestAddress addr)
fd_

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

          FDConnected {} ->
            forall (m :: * -> *) e a.
(MonadSTM m, MonadThrow (STM m), Exception e) =>
e -> STM m a
throwSTM forall a b. (a -> b) -> a -> b
$ FD_ m (TestAddress addr) -> IOError
invalidError FD_ m (TestAddress addr)
fd_
          FDConnecting {} ->
            forall (m :: * -> *) e a.
(MonadSTM m, MonadThrow (STM m), Exception e) =>
e -> STM m a
throwSTM forall a b. (a -> b) -> a -> b
$ FD_ m (TestAddress addr) -> IOError
invalidError FD_ m (TestAddress addr)
fd_
          FDListening {} ->
            forall (m :: * -> *) a. Monad m => a -> m a
return ()
          FDClosed {} ->
            forall (m :: * -> *) e a.
(MonadSTM m, MonadThrow (STM m), Exception e) =>
e -> STM m a
throwSTM 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
          { ioe_handle :: Maybe Handle
ioe_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 = forall r. PrintfType r => String -> r
printf String
"Invalid argument (%s)" (forall a. Show a => a -> String
show FD_ m (TestAddress addr)
fd_)
          , ioe_errno :: Maybe CInt
ioe_errno       = forall a. Maybe a
Nothing
          , ioe_filename :: Maybe String
ioe_filename    = 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 <- forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime
                             let deltaAndIOErr :: Maybe (DiffTime, IOErrType)
deltaAndIOErr =
                                   BearerInfo -> Maybe (DiffTime, IOErrType)
biAcceptFailures (forall (m :: * -> *) addr. NetworkState m addr -> BearerInfo
nsDefaultBearerInfo NetworkState m (TestAddress addr)
state)
                             forall (m :: * -> *) a. Monad m => a -> m a
return 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 <- forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (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 = forall addr. addr -> addr -> ConnectionId addr
ConnectionId TestAddress addr
localAddress (forall (m :: * -> *) addr. ChannelWithInfo m addr -> addr
cwiAddress ChannelWithInfo m (TestAddress addr)
cwi)

          case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (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                                     ->
               forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
             Just (Connection AttenuatedChannel m
_ AttenuatedChannel m
_ SDUSize
_ ConnectionState
SYN_SENT TestAddress addr
provider) ->
               forall (m :: * -> *) a. Monad m => a -> m a
return ( TestAddress addr
provider forall a. Eq a => a -> a -> Bool
/= TestAddress addr
localAddress
                     Bool -> Bool -> Bool
|| TestAddress addr
localAddress forall a. Eq a => a -> a -> Bool
== forall (m :: * -> *) addr. ChannelWithInfo m addr -> addr
cwiAddress ChannelWithInfo m (TestAddress addr)
cwi
                      )
             Maybe (Connection m (TestAddress addr))
_                                           ->
               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 = forall (m :: * -> *) fd addr.
m (Accepted fd addr, Accept m fd addr) -> Accept m fd addr
Accept forall a b. (a -> b) -> a -> b
$ do
            Time
ctime <- forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime
            forall (m :: * -> *) a b c.
MonadCatch m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracketOnError
              (forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically forall a b. (a -> b) -> a -> b
$ do
                FD_ m (TestAddress addr)
fd <- 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.
                    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left ( forall e. Exception e => e -> SomeException
toException forall a b. (a -> b) -> a -> b
$ FD_ m (TestAddress addr) -> IOError
invalidError FD_ m (TestAddress addr)
fd
                                  , Maybe (TestAddress addr)
mbAddr
                                  , forall a. Maybe a
Nothing
                                  , forall (m :: * -> *) addr. FD_ m addr -> SockType
mkSockType FD_ m (TestAddress addr)
fd
                                  )
                  FDConnecting ConnectionId (TestAddress addr)
connId Connection m (TestAddress addr)
_ ->
                    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left ( forall e. Exception e => e -> SomeException
toException forall a b. (a -> b) -> a -> b
$ FD_ m (TestAddress addr) -> IOError
invalidError FD_ m (TestAddress addr)
fd
                                  , forall a. a -> Maybe a
Just (forall addr. ConnectionId addr -> addr
localAddress ConnectionId (TestAddress addr)
connId)
                                  , forall a. Maybe a
Nothing
                                  , forall (m :: * -> *) addr. FD_ m addr -> SockType
mkSockType FD_ m (TestAddress addr)
fd
                                  )
                  FDConnected ConnectionId (TestAddress addr)
connId Connection m (TestAddress addr)
_ ->
                    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left ( forall e. Exception e => e -> SomeException
toException forall a b. (a -> b) -> a -> b
$ FD_ m (TestAddress addr) -> IOError
invalidError FD_ m (TestAddress addr)
fd
                                  , forall a. a -> Maybe a
Just (forall addr. ConnectionId addr -> addr
localAddress ConnectionId (TestAddress addr)
connId)
                                  , forall a. Maybe a
Nothing
                                  , forall (m :: * -> *) addr. FD_ m addr -> SockType
mkSockType FD_ m (TestAddress addr)
fd
                                  )

                  FDListening TestAddress addr
localAddress StrictTBQueue 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 StrictTBQueue until we have found
                    -- one that is SYN_SENT state.
                    ChannelWithInfo m (TestAddress addr)
cwi <- forall (m :: * -> *) a.
MonadSTM m =>
(a -> STM m Bool) -> StrictTBQueue m a -> STM m a
readTBQueueUntil (TestAddress addr
-> ChannelWithInfo m (TestAddress addr) -> STM m Bool
synSent TestAddress addr
localAddress) StrictTBQueue m (ChannelWithInfo m (TestAddress addr))
queue
                    let connId :: ConnectionId (TestAddress addr)
connId = forall addr. addr -> addr -> ConnectionId addr
ConnectionId TestAddress addr
localAddress (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 forall a. Ord a => a -> a -> Bool
>= Time
ctime ->
                        case IOErrType
ioErrType of
                          IOErrType
IOErrConnectionAborted ->
                            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left ( forall e. Exception e => e -> SomeException
toException IOError
connectionAbortedError
                                          , forall a. a -> Maybe a
Just TestAddress addr
localAddress
                                          , forall a. a -> Maybe a
Just (ConnectionId (TestAddress addr)
connId, forall (m :: * -> *) addr.
ChannelWithInfo m addr -> AttenuatedChannel m
cwiChannelLocal ChannelWithInfo m (TestAddress addr)
cwi)
                                          , forall (m :: * -> *) addr. FD_ m addr -> SockType
mkSockType FD_ m (TestAddress addr)
fd
                                          )
                          IOErrType
IOErrResourceExhausted ->
                            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left ( forall e. Exception e => e -> SomeException
toException forall a b. (a -> b) -> a -> b
$ FD_ m (TestAddress addr) -> IOError
resourceExhaustedError FD_ m (TestAddress addr)
fd
                                          , forall a. a -> Maybe a
Just TestAddress addr
localAddress
                                          , forall a. a -> Maybe a
Just (ConnectionId (TestAddress addr)
connId, forall (m :: * -> *) addr.
ChannelWithInfo m addr -> AttenuatedChannel m
cwiChannelLocal ChannelWithInfo m (TestAddress addr)
cwi)
                                          , forall (m :: * -> *) addr. FD_ m addr -> SockType
mkSockType FD_ m (TestAddress addr)
fd
                                          )
                      Maybe (DiffTime, IOErrType)
_  -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right ( ChannelWithInfo m (TestAddress addr)
cwi
                                           , ConnectionId (TestAddress addr)
connId
                                           )

                  FDClosed {} ->
                    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left ( forall e. Exception e => e -> SomeException
toException forall a b. (a -> b) -> a -> b
$ FD_ m (TestAddress addr) -> IOError
invalidError FD_ m (TestAddress addr)
fd
                                  , forall a. Maybe a
Nothing
                                  , forall a. Maybe a
Nothing
                                  , 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 {} -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                    Right (ChannelWithInfo m (TestAddress addr)
chann, ConnectionId (TestAddress addr)
connId) -> forall (m :: * -> *) a. MonadMask m => m a -> m a
uninterruptibleMask_ forall a b. (a -> b) -> a -> b
$ do
                      forall (m :: * -> *). AttenuatedChannel m -> m ()
acClose (forall (m :: * -> *) addr.
ChannelWithInfo m addr -> AttenuatedChannel m
cwiChannelLocal ChannelWithInfo m (TestAddress addr)
chann)
                      forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically forall a b. (a -> b) -> a -> b
$
                        forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar (forall (m :: * -> *) addr.
NetworkState m addr
-> StrictTVar m (Map (NormalisedId addr) (Connection m addr))
nsConnections NetworkState m (TestAddress addr)
state)
                                   (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 ->
                                           forall a. Maybe a
Nothing
                                         ConnectionState
_ ->
                                           forall a. a -> Maybe a
Just Connection m (TestAddress addr)
conn { connState :: ConnectionState
connState = ConnectionState
FIN })
                                     (forall addr. Ord addr => ConnectionId addr -> NormalisedId addr
normaliseId ConnectionId (TestAddress addr)
connId))
              )
              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
                    forall (m :: * -> *) a. MonadMask m => m a -> m a
uninterruptibleMask_ forall a b. (a -> b) -> a -> b
$
                      forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\(ConnectionId (TestAddress addr)
connId, AttenuatedChannel m
chann) -> do
                                   forall (m :: * -> *). AttenuatedChannel m -> m ()
acClose AttenuatedChannel m
chann
                                   forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar
                                     (forall (m :: * -> *) addr.
NetworkState m addr
-> StrictTVar m (Map (NormalisedId addr) (Connection m addr))
nsConnections NetworkState m (TestAddress addr)
state)
                                     (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 -> forall a. Maybe a
Nothing
                                           ConnectionState
_   -> forall a. a -> Maybe a
Just Connection m (TestAddress addr)
conn { connState :: ConnectionState
connState = ConnectionState
FIN })
                                       (forall addr. Ord addr => ConnectionId addr -> NormalisedId addr
normaliseId ConnectionId (TestAddress addr)
connId))
                                )
                                Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m)
mbConnIdAndChann
                    forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer
  m (WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr)))
tr (forall addr event.
Maybe addr -> Maybe addr -> event -> WithAddr addr event
WithAddr Maybe (TestAddress addr)
mbLocalAddr forall a. Maybe a
Nothing (forall (m :: * -> *) addr.
SockType -> SomeException -> SnocketTrace m addr
STAcceptFailure SockType
fdType SomeException
err))
                    forall (m :: * -> *) a. Monad m => a -> m a
return (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
                    forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer
  m (WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr)))
tr (forall addr event.
Maybe addr -> Maybe addr -> event -> WithAddr addr event
WithAddr (forall a. a -> Maybe a
Just TestAddress addr
localAddress) (forall a. a -> Maybe a
Just TestAddress addr
remoteAddress)
                                           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 <- forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically forall a b. (a -> b) -> a -> b
$ do

                      forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar (forall (m :: * -> *) addr.
NetworkState m addr
-> StrictTVar m (Map (NormalisedId addr) (Connection m addr))
nsConnections NetworkState m (TestAddress addr)
state)
                                 (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 })
                                             (forall addr. Ord addr => ConnectionId addr -> NormalisedId addr
normaliseId ConnectionId (TestAddress addr)
connId))

                      forall (m :: * -> *) peerAddr.
StrictTVar m (FD_ m peerAddr) -> FD m peerAddr
FD forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadSTM m => a -> STM m (StrictTVar m a)
newTVar (forall (m :: * -> *) addr.
ConnectionId addr -> Connection m addr -> FD_ m addr
FDConnected
                                          ConnectionId (TestAddress addr)
connId
                                          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
                                            })

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

                    forall (m :: * -> *) a. Monad m => a -> m a
return (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
          { ioe_handle :: Maybe Handle
ioe_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 = forall r. PrintfType r => String -> r
printf String
"Invalid argument (%s)" (forall a. Show a => a -> String
show FD_ m (TestAddress addr)
fd)
          , ioe_errno :: Maybe CInt
ioe_errno       = forall a. Maybe a
Nothing
          , ioe_filename :: Maybe String
ioe_filename    = forall a. Maybe a
Nothing
          }

        connectionAbortedError :: IOError
        connectionAbortedError :: IOError
connectionAbortedError = IOError
          { ioe_handle :: Maybe Handle
ioe_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       = forall a. a -> Maybe a
Just (case Errno
eCONNABORTED of Errno CInt
errno -> CInt
errno)
          , ioe_filename :: Maybe String
ioe_filename    = forall a. Maybe a
Nothing
          }

        resourceExhaustedError :: FD_ m (TestAddress addr) -> IOError
        resourceExhaustedError :: FD_ m (TestAddress addr) -> IOError
resourceExhaustedError FD_ m (TestAddress addr)
fd = IOError
          { ioe_handle :: Maybe Handle
ioe_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 = forall r. PrintfType r => String -> r
printf String
"Resource exhausted (%s)" (forall a. Show a => a -> String
show FD_ m (TestAddress addr)
fd)
          , ioe_errno :: Maybe CInt
ioe_errno       = forall a. Maybe a
Nothing
          , ioe_filename :: Maybe String
ioe_filename    = 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 } =
      forall (m :: * -> *) a. MonadMask m => m a -> m a
uninterruptibleMask_ forall a b. (a -> b) -> a -> b
$ do
        Wedge
  (ConnectionId (TestAddress addr), SockType, AttenuatedChannel m)
  (TestAddress addr, SockType,
   [(TestAddress addr, AttenuatedChannel m)])
wChannel <- forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically forall a b. (a -> b) -> a -> b
$ do
          FD_ m (TestAddress addr)
fd_ <- 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
              -> forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (FD_ m (TestAddress addr))
fdVar (forall (m :: * -> *) addr.
Wedge (ConnectionId addr) addr -> FD_ m addr
FDClosed forall a b. Wedge a b
Nowhere)
              forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> forall a b. Wedge a b
Nowhere
            FDUninitialised (Just TestAddress addr
addr)
              -> forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (FD_ m (TestAddress addr))
fdVar (forall (m :: * -> *) addr.
Wedge (ConnectionId addr) addr -> FD_ m addr
FDClosed (forall a b. b -> Wedge a b
There TestAddress addr
addr))
              forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> forall a b. Wedge a b
Nowhere
            FDConnecting ConnectionId (TestAddress addr)
connId Connection m (TestAddress addr)
conn
              -> forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (FD_ m (TestAddress addr))
fdVar (forall (m :: * -> *) addr.
Wedge (ConnectionId addr) addr -> FD_ m addr
FDClosed (forall a b. a -> Wedge a b
Here ConnectionId (TestAddress addr)
connId))
              forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> forall a b. a -> Wedge a b
Here (ConnectionId (TestAddress addr)
connId, forall (m :: * -> *) addr. FD_ m addr -> SockType
mkSockType FD_ m (TestAddress addr)
fd_, forall (m :: * -> *) addr. Connection m addr -> AttenuatedChannel m
connChannelLocal Connection m (TestAddress addr)
conn)
            FDConnected ConnectionId (TestAddress addr)
connId Connection m (TestAddress addr)
conn
              -> forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (FD_ m (TestAddress addr))
fdVar (forall (m :: * -> *) addr.
Wedge (ConnectionId addr) addr -> FD_ m addr
FDClosed (forall a b. a -> Wedge a b
Here ConnectionId (TestAddress addr)
connId))
              forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> forall a b. a -> Wedge a b
Here (ConnectionId (TestAddress addr)
connId, forall (m :: * -> *) addr. FD_ m addr -> SockType
mkSockType FD_ m (TestAddress addr)
fd_, forall (m :: * -> *) addr. Connection m addr -> AttenuatedChannel m
connChannelLocal Connection m (TestAddress addr)
conn)
            FDListening TestAddress addr
localAddress StrictTBQueue m (ChannelWithInfo m (TestAddress addr))
queue -> do
              forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (FD_ m (TestAddress addr))
fdVar (forall (m :: * -> *) addr.
Wedge (ConnectionId addr) addr -> FD_ m addr
FDClosed (forall a b. b -> Wedge a b
There TestAddress addr
localAddress))
              (\[ChannelWithInfo m (TestAddress addr)]
as -> forall a b. b -> Wedge a b
There ( TestAddress addr
localAddress
                            , forall (m :: * -> *) addr. FD_ m addr -> SockType
mkSockType FD_ m (TestAddress addr)
fd_
                            , forall a b. (a -> b) -> [a] -> [b]
map (\ChannelWithInfo m (TestAddress addr)
a -> ( forall (m :: * -> *) addr. ChannelWithInfo m addr -> addr
cwiAddress ChannelWithInfo m (TestAddress addr)
a, forall (m :: * -> *) addr.
ChannelWithInfo m addr -> AttenuatedChannel m
cwiChannelLocal ChannelWithInfo m (TestAddress addr)
a)) [ChannelWithInfo m (TestAddress addr)]
as
                            )) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
MonadSTM m =>
StrictTBQueue m a -> STM m [a]
drainTBQueue StrictTBQueue m (ChannelWithInfo m (TestAddress addr))
queue
            FDClosed {} ->
              forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. Wedge a b
Nowhere

        -- trace 'STClosing'
        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
_) ->
              forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer
  m (WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr)))
tr (forall addr event.
Maybe addr -> Maybe addr -> event -> WithAddr addr event
WithAddr (forall a. a -> Maybe a
Just (forall addr. ConnectionId addr -> addr
localAddress ConnectionId (TestAddress addr)
connId))
                                     (forall a. a -> Maybe a
Just (forall addr. ConnectionId addr -> addr
remoteAddress ConnectionId (TestAddress addr)
connId))
                                     (forall (m :: * -> *) addr.
SockType -> Wedge (ConnectionId addr) [addr] -> SnocketTrace m addr
STClosing SockType
fdType (forall a b. a -> Wedge a b
Here ConnectionId (TestAddress addr)
connId))))
          (\(TestAddress addr
addr, SockType
fdType, [(TestAddress addr, AttenuatedChannel m)]
as) ->
              forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer
  m (WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr)))
tr (forall addr event.
Maybe addr -> Maybe addr -> event -> WithAddr addr event
WithAddr (forall a. a -> Maybe a
Just TestAddress addr
addr)
                                     forall a. Maybe a
Nothing
                                     (forall (m :: * -> *) addr.
SockType -> Wedge (ConnectionId addr) [addr] -> SnocketTrace m addr
STClosing SockType
fdType (forall a b. b -> Wedge a b
There (forall a b. (a -> b) -> [a] -> [b]
map 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
        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)  -> forall (m :: * -> *). AttenuatedChannel m -> m ()
acClose AttenuatedChannel m
chann)
          (\(TestAddress addr
_, SockType
_, [(TestAddress addr, AttenuatedChannel m)]
channs) -> forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (forall (m :: * -> *). AttenuatedChannel m -> m ()
acClose forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
        forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically forall a b. (a -> b) -> a -> b
$ 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
_) ->
             forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar (forall (m :: * -> *) addr.
NetworkState m addr
-> StrictTVar m (Map (NormalisedId addr) (Connection m addr))
nsConnections NetworkState m (TestAddress addr)
state)
                        (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 ->
                                forall a. Maybe a
Nothing
                              ConnectionState
_ ->
                                forall a. a -> Maybe a
Just Connection m (TestAddress addr)
conn { connState :: ConnectionState
connState = ConnectionState
FIN })
                          (forall addr. Ord addr => ConnectionId addr -> NormalisedId addr
normaliseId ConnectionId (TestAddress addr)
connId)))
          (\(TestAddress addr
addr,   SockType
_, [(TestAddress addr, AttenuatedChannel m)]
_) ->
             forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar (forall (m :: * -> *) addr.
NetworkState m addr -> StrictTVar m (Map addr (FD m addr))
nsListeningFDs NetworkState m (TestAddress addr)
state)
                        (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'
        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 <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (m :: * -> *) addr. Connection m addr -> ConnectionState
connState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (forall addr. Ord addr => ConnectionId addr -> NormalisedId addr
normaliseId ConnectionId (TestAddress addr)
connId)
                     forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (forall (m :: * -> *) addr.
NetworkState m addr
-> StrictTVar m (Map (NormalisedId addr) (Connection m addr))
nsConnections NetworkState m (TestAddress addr)
state))
            forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer
  m (WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr)))
tr (forall addr event.
Maybe addr -> Maybe addr -> event -> WithAddr addr event
WithAddr (forall a. a -> Maybe a
Just (forall addr. ConnectionId addr -> addr
localAddress ConnectionId (TestAddress addr)
connId))
                                   (forall a. a -> Maybe a
Just (forall addr. ConnectionId addr -> addr
remoteAddress ConnectionId (TestAddress addr)
connId))
                                   (forall (m :: * -> *) addr.
SockType -> Maybe (Maybe ConnectionState) -> SnocketTrace m addr
STClosed SockType
fdType (forall a. a -> Maybe a
Just Maybe ConnectionState
openState)))

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

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


--
-- Utils
--

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

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


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