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

-- | 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
  , makeFDRawBearer
  , makeFDBearer
  , GlobalAddressScheme (..)
  , AddressType (..)
  , WithAddr (..)
  ) where

import Prelude hiding (read)

import Control.Applicative (Alternative)
import Control.Concurrent.Class.MonadSTM qualified as LazySTM
import Control.Concurrent.Class.MonadSTM.Strict
import Control.Monad (when)
import Control.Monad.Class.MonadST
import Control.Monad.Class.MonadThrow
import Control.Monad.Class.MonadTime.SI
import Control.Monad.Class.MonadTimer.SI
import Control.Monad.ST.Unsafe (unsafeIOToST)
import Control.Tracer (Tracer, contramap, contramapM, traceWith)

import GHC.IO.Exception

import Data.Bifoldable (bitraverse_)
import Data.ByteString qualified as BS
import Data.ByteString.Lazy qualified as LBS
import Data.Foldable (traverse_)
import Data.Functor (($>))
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Typeable (Typeable)
import Foreign.Marshal (copyBytes)
import Foreign.Ptr (castPtr)
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.RawBearer
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
(ConnectionState -> ConnectionState -> Bool)
-> (ConnectionState -> ConnectionState -> Bool)
-> Eq ConnectionState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ConnectionState -> ConnectionState -> Bool
== :: ConnectionState -> ConnectionState -> Bool
$c/= :: ConnectionState -> ConnectionState -> Bool
/= :: ConnectionState -> ConnectionState -> Bool
Eq, Int -> ConnectionState -> ShowS
[ConnectionState] -> ShowS
ConnectionState -> String
(Int -> ConnectionState -> ShowS)
-> (ConnectionState -> String)
-> ([ConnectionState] -> ShowS)
-> Show ConnectionState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ConnectionState -> ShowS
showsPrec :: Int -> ConnectionState -> ShowS
$cshow :: ConnectionState -> String
show :: ConnectionState -> String
$cshowList :: [ConnectionState] -> ShowS
showList :: [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 :: forall (m :: * -> *) addr. Connection m addr -> AttenuatedChannel m
connChannelLocal :: AttenuatedChannel m
connChannelLocal, AttenuatedChannel m
connChannelRemote :: forall (m :: * -> *) addr. Connection m addr -> AttenuatedChannel m
connChannelRemote :: AttenuatedChannel m
connChannelRemote } =
    Connection m addr
conn { connChannelLocal  = connChannelRemote
         , connChannelRemote = connChannelLocal
         }


mkConnection :: ( MonadDelay         m
                , MonadLabelledSTM   m
                , MonadTimer         m
                , MonadThrow         m
                , MonadThrow    (STM m)
                , Eq addr
                )
             => 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), Eq addr) =>
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 :: TestAddress addr
localAddress :: forall addr. ConnectionId addr -> addr
localAddress, TestAddress addr
remoteAddress :: TestAddress addr
remoteAddress :: forall addr. ConnectionId addr -> addr
remoteAddress } | TestAddress addr
localAddress TestAddress addr -> TestAddress addr -> Bool
forall a. Eq a => a -> a -> Bool
== TestAddress addr
remoteAddress = do
  -- we are connecting to onself.  On Linux this returns a connection which
  -- mirrors all sent data.
  qc <- STM m (QueueChannel m)
forall (m :: * -> *). MonadSTM m => STM m (QueueChannel m)
echoQueueChannel
  channel <- newAttenuatedChannel
      ( ( WithAddr (Just localAddress) (Just remoteAddress)
        . STAttenuatedChannelTrace connId
        )
        `contramap` tr)
      Attenuation
        { aReadAttenuation  = biOutboundAttenuation  bearerInfo
        , aWriteAttenuation = biOutboundWriteFailure bearerInfo
        }
      qc
  return Connection {
    connChannelLocal  = channel,
    connChannelRemote = undefined,
    connSDUSize  = biSDUSize bearerInfo,
    connState    = SYN_SENT,
    connProvider = localAddress
  }

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
        })
  ((AttenuatedChannel m, AttenuatedChannel m)
 -> Connection m (TestAddress addr))
-> STM m (AttenuatedChannel m, AttenuatedChannel m)
-> STM m (Connection m (TestAddress addr))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    Tracer m AttenuatedChannelTrace
-> Tracer m AttenuatedChannelTrace
-> Attenuation
-> Attenuation
-> STM m (AttenuatedChannel m, AttenuatedChannel m)
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
      ( ( Maybe (TestAddress addr)
-> Maybe (TestAddress addr)
-> SnocketTrace m (TestAddress addr)
-> WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr))
forall addr event.
Maybe addr -> Maybe addr -> event -> WithAddr addr event
WithAddr (TestAddress addr -> Maybe (TestAddress addr)
forall a. a -> Maybe a
Just TestAddress addr
localAddress) (TestAddress addr -> Maybe (TestAddress addr)
forall a. a -> Maybe a
Just TestAddress addr
remoteAddress)
        (SnocketTrace m (TestAddress addr)
 -> WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr)))
-> (AttenuatedChannelTrace -> SnocketTrace m (TestAddress addr))
-> AttenuatedChannelTrace
-> WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConnectionId (TestAddress addr)
-> AttenuatedChannelTrace -> SnocketTrace m (TestAddress addr)
forall (m :: * -> *) addr.
ConnectionId addr -> AttenuatedChannelTrace -> SnocketTrace m addr
STAttenuatedChannelTrace ConnectionId (TestAddress addr)
connId
        )
        (AttenuatedChannelTrace
 -> WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr)))
-> Tracer
     m (WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr)))
-> Tracer m AttenuatedChannelTrace
forall a' a. (a' -> a) -> Tracer m a -> Tracer m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
`contramap` Tracer
  m (WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr)))
tr)
      ( ( Maybe (TestAddress addr)
-> Maybe (TestAddress addr)
-> SnocketTrace m (TestAddress addr)
-> WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr))
forall addr event.
Maybe addr -> Maybe addr -> event -> WithAddr addr event
WithAddr (TestAddress addr -> Maybe (TestAddress addr)
forall a. a -> Maybe a
Just TestAddress addr
remoteAddress) (TestAddress addr -> Maybe (TestAddress addr)
forall a. a -> Maybe a
Just TestAddress addr
localAddress)
        (SnocketTrace m (TestAddress addr)
 -> WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr)))
-> (AttenuatedChannelTrace -> SnocketTrace m (TestAddress addr))
-> AttenuatedChannelTrace
-> WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConnectionId (TestAddress addr)
-> AttenuatedChannelTrace -> SnocketTrace m (TestAddress addr)
forall (m :: * -> *) addr.
ConnectionId addr -> AttenuatedChannelTrace -> SnocketTrace m addr
STAttenuatedChannelTrace ConnectionId
            { localAddress :: TestAddress addr
localAddress  = TestAddress addr
remoteAddress
            , remoteAddress :: TestAddress addr
remoteAddress = TestAddress addr
localAddress
            }
        )
       (AttenuatedChannelTrace
 -> WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr)))
-> Tracer
     m (WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr)))
-> Tracer m AttenuatedChannelTrace
forall a' a. (a' -> a) -> Tracer m a -> Tracer m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
`contramap` Tracer
  m (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
(NormalisedId addr -> NormalisedId addr -> Bool)
-> (NormalisedId addr -> NormalisedId addr -> Bool)
-> Eq (NormalisedId addr)
forall addr.
Eq addr =>
NormalisedId addr -> NormalisedId addr -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$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
/= :: NormalisedId addr -> NormalisedId addr -> Bool
Eq, Eq (NormalisedId addr)
Eq (NormalisedId addr) =>
(NormalisedId addr -> NormalisedId addr -> Ordering)
-> (NormalisedId addr -> NormalisedId addr -> Bool)
-> (NormalisedId addr -> NormalisedId addr -> Bool)
-> (NormalisedId addr -> NormalisedId addr -> Bool)
-> (NormalisedId addr -> NormalisedId addr -> Bool)
-> (NormalisedId addr -> NormalisedId addr -> NormalisedId addr)
-> (NormalisedId addr -> NormalisedId addr -> NormalisedId addr)
-> Ord (NormalisedId addr)
NormalisedId addr -> NormalisedId addr -> Bool
NormalisedId addr -> NormalisedId addr -> Ordering
NormalisedId addr -> NormalisedId addr -> NormalisedId addr
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall addr. Ord addr => Eq (NormalisedId addr)
forall addr.
Ord addr =>
NormalisedId addr -> NormalisedId addr -> Bool
forall addr.
Ord addr =>
NormalisedId addr -> NormalisedId addr -> Ordering
forall addr.
Ord addr =>
NormalisedId addr -> NormalisedId addr -> NormalisedId addr
$ccompare :: forall addr.
Ord addr =>
NormalisedId addr -> NormalisedId addr -> Ordering
compare :: NormalisedId addr -> NormalisedId addr -> Ordering
$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
>= :: NormalisedId addr -> NormalisedId addr -> Bool
$cmax :: forall addr.
Ord addr =>
NormalisedId addr -> NormalisedId addr -> NormalisedId addr
max :: NormalisedId addr -> NormalisedId addr -> NormalisedId addr
$cmin :: forall addr.
Ord addr =>
NormalisedId addr -> NormalisedId addr -> NormalisedId addr
min :: NormalisedId addr -> NormalisedId addr -> NormalisedId addr
Ord, Int -> NormalisedId addr -> ShowS
[NormalisedId addr] -> ShowS
NormalisedId addr -> String
(Int -> NormalisedId addr -> ShowS)
-> (NormalisedId addr -> String)
-> ([NormalisedId addr] -> ShowS)
-> Show (NormalisedId addr)
forall addr. Show addr => Int -> NormalisedId addr -> ShowS
forall addr. Show addr => [NormalisedId addr] -> ShowS
forall addr. Show addr => NormalisedId addr -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall addr. Show addr => Int -> NormalisedId addr -> ShowS
showsPrec :: Int -> NormalisedId addr -> ShowS
$cshow :: forall addr. Show addr => NormalisedId addr -> String
show :: NormalisedId addr -> String
$cshowList :: forall addr. Show addr => [NormalisedId addr] -> ShowS
showList :: [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 :: forall addr. ConnectionId addr -> addr
localAddress :: addr
localAddress, addr
remoteAddress :: forall addr. ConnectionId addr -> addr
remoteAddress :: addr
remoteAddress}
    | addr
localAddress addr -> addr -> Bool
forall a. Ord a => a -> a -> Bool
<= addr
remoteAddress
    = addr -> addr -> NormalisedId addr
forall addr. addr -> addr -> NormalisedId addr
UnsafeNormalisedId addr
localAddress addr
remoteAddress
    | Bool
otherwise
    = addr -> addr -> NormalisedId addr
forall addr. addr -> addr -> NormalisedId addr
UnsafeNormalisedId addr
remoteAddress addr
localAddress


-- | Simulation network environment consumed by 'simSnocket'.
--
data NetworkState m addr = NetworkState {
      -- | All listening 'FD's.
      --
      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
[ObservableNetworkState addr] -> ShowS
ObservableNetworkState addr -> String
(Int -> ObservableNetworkState addr -> ShowS)
-> (ObservableNetworkState addr -> String)
-> ([ObservableNetworkState addr] -> ShowS)
-> Show (ObservableNetworkState addr)
forall addr.
Show addr =>
Int -> ObservableNetworkState addr -> ShowS
forall addr. Show addr => [ObservableNetworkState addr] -> ShowS
forall addr. Show addr => ObservableNetworkState addr -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall addr.
Show addr =>
Int -> ObservableNetworkState addr -> ShowS
showsPrec :: Int -> ObservableNetworkState addr -> ShowS
$cshow :: forall addr. Show addr => ObservableNetworkState addr -> String
show :: ObservableNetworkState addr -> String
$cshowList :: forall addr. Show addr => [ObservableNetworkState addr] -> ShowS
showList :: [ObservableNetworkState addr] -> ShowS
Show


-- | Error types.
--
data IOErrType = IOErrConnectionAborted
               | IOErrResourceExhausted
  deriving (IOErrType -> IOErrType -> Bool
(IOErrType -> IOErrType -> Bool)
-> (IOErrType -> IOErrType -> Bool) -> Eq IOErrType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: IOErrType -> IOErrType -> Bool
== :: IOErrType -> IOErrType -> Bool
$c/= :: IOErrType -> IOErrType -> Bool
/= :: IOErrType -> IOErrType -> Bool
Eq, Int -> IOErrType -> ShowS
[IOErrType] -> ShowS
IOErrType -> String
(Int -> IOErrType -> ShowS)
-> (IOErrType -> String)
-> ([IOErrType] -> ShowS)
-> Show IOErrType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> IOErrType -> ShowS
showsPrec :: Int -> IOErrType -> ShowS
$cshow :: IOErrType -> String
show :: IOErrType -> String
$cshowList :: [IOErrType] -> ShowS
showList :: [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, IOError)
biAcceptFailures       :: !(Maybe (DiffTime, IOError))

      -- | 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 :: BearerInfo -> DiffTime
biConnectionDelay :: DiffTime
biConnectionDelay, Maybe Int
biInboundWriteFailure :: BearerInfo -> Maybe Int
biInboundWriteFailure :: Maybe Int
biInboundWriteFailure, Maybe Int
biOutboundWriteFailure :: BearerInfo -> Maybe Int
biOutboundWriteFailure :: Maybe Int
biOutboundWriteFailure, Maybe (DiffTime, IOError)
biAcceptFailures :: BearerInfo -> Maybe (DiffTime, IOError)
biAcceptFailures :: Maybe (DiffTime, IOError)
biAcceptFailures, SDUSize
biSDUSize :: BearerInfo -> SDUSize
biSDUSize :: SDUSize
biSDUSize} =
      [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"BearerInfo "
        , DiffTime -> String
forall a. Show a => a -> String
show DiffTime
biConnectionDelay
        , String
" ("
        , Maybe Int -> String
forall a. Show a => a -> String
show Maybe Int
biInboundWriteFailure
        , String
") ("
        , Maybe Int -> String
forall a. Show a => a -> String
show Maybe Int
biOutboundWriteFailure
        , String
") ("
        , Maybe (DiffTime, IOError) -> String
forall a. Show a => a -> String
show Maybe (DiffTime, IOError)
biAcceptFailures
        , String
") ("
        , SDUSize -> String
forall a. Show a => a -> String
show SDUSize
biSDUSize
        , String
")"
        ]


-- | '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  = Maybe Int
forall a. Maybe a
Nothing
                           , biOutboundWriteFailure :: Maybe Int
biOutboundWriteFailure = Maybe Int
forall a. Maybe a
Nothing
                           , biAcceptFailures :: Maybe (DiffTime, IOError)
biAcceptFailures       = Maybe (DiffTime, IOError)
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 = STM m (NetworkState m (TestAddress peerAddr))
-> m (NetworkState m (TestAddress peerAddr))
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (NetworkState m (TestAddress peerAddr))
 -> m (NetworkState m (TestAddress peerAddr)))
-> STM m (NetworkState m (TestAddress peerAddr))
-> m (NetworkState m (TestAddress peerAddr))
forall a b. (a -> b) -> a -> b
$ do
  (v :: StrictTVar m Natural) <- Natural -> STM m (StrictTVar m Natural)
forall (m :: * -> *) a. MonadSTM m => a -> STM m (StrictTVar m a)
newTVar Natural
0
  let nextEphemeralAddr :: AddressType -> STM m (TestAddress peerAddr)
      nextEphemeralAddr AddressType
addrType = do
        -- TODO: we should use `(\s -> (succ s, s)` but p2p-master does not
        -- include PR #3172.
         a <- StrictTVar m Natural
-> (Natural -> (Natural, Natural)) -> STM m Natural
forall (m :: * -> *) s a.
MonadSTM m =>
StrictTVar m s -> (s -> (a, s)) -> STM m a
stateTVar StrictTVar m Natural
v (\Natural
s -> let s' :: Natural
s' = Natural -> Natural
forall a. Enum a => a -> a
succ Natural
s in (Natural
s', Natural
s'))
         return (ephemeralAddress addrType a)

  scriptMapVars <- traverse LazySTM.newTVar scriptMap
  s <- NetworkState
    -- nsListeningFDs
    <$> newTVar Map.empty
    -- nsConnections
    <*> newTVar Map.empty
    -- nsNextEphemeralAddr
    <*> pure nextEphemeralAddr
    -- nsBearerInfo
    <*> pure defaultBearerInfo
    -- attenuationMap
    <*> pure scriptMapVars

  labelTVar (nsListeningFDs s)   "nsListeningFDs"
  labelTVar (nsConnections s)    "nsConnections"
  return s


data ResourceException
  = forall addr. (Typeable addr, Show addr)
              => NotReleasedListeningSockets [addr] (Maybe SomeException)
  | forall addr. (Typeable addr, Ord addr, Show addr)
              => NotReleasedConnections (Map (NormalisedId addr) ConnectionState)
                                        (Maybe SomeException)

deriving instance Show ResourceException
deriving instance Typeable ResourceException
instance Exception ResourceException where


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



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


-- | A bracket which runs a network simulation.  When the simulation
-- terminates it verifies that all listening sockets and all connections are
-- closed.  It might throw 'ResourceException'.
--
withSnocket
    :: forall m peerAddr a.
       ( 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
    st <- BearerInfo
-> Map (NormalisedId (TestAddress peerAddr)) (Script BearerInfo)
-> m (NetworkState m (TestAddress peerAddr))
forall (m :: * -> *) peerAddr.
(MonadLabelledSTM m, GlobalAddressScheme peerAddr) =>
BearerInfo
-> Map (NormalisedId (TestAddress peerAddr)) (Script BearerInfo)
-> m (NetworkState m (TestAddress peerAddr))
newNetworkState BearerInfo
defaultBearerInfo Map (NormalisedId (TestAddress peerAddr)) (Script BearerInfo)
scriptMap
    a <- k (mkSnocket st tr) (toState st)
         `catch`
         \SomeException
e -> do re <- NetworkState m (TestAddress peerAddr)
-> Maybe SomeException -> m (Maybe ResourceException)
checkResources NetworkState m (TestAddress peerAddr)
st (SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just SomeException
e)
                  traverse_ throwIO re
                  throwIO e
    re <- checkResources st Nothing
    traverse_ throwIO re
    return a
  where
    -- verify that all sockets are closed
    checkResources :: NetworkState m (TestAddress peerAddr)
                   -> Maybe SomeException
                   -> m (Maybe ResourceException)
    checkResources :: NetworkState m (TestAddress peerAddr)
-> Maybe SomeException -> m (Maybe ResourceException)
checkResources NetworkState { 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 (TestAddress peerAddr) (FD m (TestAddress peerAddr)))
nsListeningFDs, 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 :: StrictTVar
  m
  (Map
     (NormalisedId (TestAddress peerAddr))
     (Connection m (TestAddress peerAddr)))
nsConnections } Maybe SomeException
err = do
      (lstFDMap, connMap) <- STM
  m
  (Map (TestAddress peerAddr) (FD m (TestAddress peerAddr)),
   Map
     (NormalisedId (TestAddress peerAddr))
     (Connection m (TestAddress peerAddr)))
-> m (Map (TestAddress peerAddr) (FD m (TestAddress peerAddr)),
      Map
        (NormalisedId (TestAddress peerAddr))
        (Connection m (TestAddress peerAddr)))
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM
   m
   (Map (TestAddress peerAddr) (FD m (TestAddress peerAddr)),
    Map
      (NormalisedId (TestAddress peerAddr))
      (Connection m (TestAddress peerAddr)))
 -> m (Map (TestAddress peerAddr) (FD m (TestAddress peerAddr)),
       Map
         (NormalisedId (TestAddress peerAddr))
         (Connection m (TestAddress peerAddr))))
-> STM
     m
     (Map (TestAddress peerAddr) (FD m (TestAddress peerAddr)),
      Map
        (NormalisedId (TestAddress peerAddr))
        (Connection m (TestAddress peerAddr)))
-> m (Map (TestAddress peerAddr) (FD m (TestAddress peerAddr)),
      Map
        (NormalisedId (TestAddress peerAddr))
        (Connection m (TestAddress peerAddr)))
forall a b. (a -> b) -> a -> b
$ (,) (Map (TestAddress peerAddr) (FD m (TestAddress peerAddr))
 -> Map
      (NormalisedId (TestAddress peerAddr))
      (Connection m (TestAddress peerAddr))
 -> (Map (TestAddress peerAddr) (FD m (TestAddress peerAddr)),
     Map
       (NormalisedId (TestAddress peerAddr))
       (Connection m (TestAddress peerAddr))))
-> STM m (Map (TestAddress peerAddr) (FD m (TestAddress peerAddr)))
-> STM
     m
     (Map
        (NormalisedId (TestAddress peerAddr))
        (Connection m (TestAddress peerAddr))
      -> (Map (TestAddress peerAddr) (FD m (TestAddress peerAddr)),
          Map
            (NormalisedId (TestAddress peerAddr))
            (Connection m (TestAddress peerAddr))))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar
  m (Map (TestAddress peerAddr) (FD m (TestAddress peerAddr)))
-> STM m (Map (TestAddress peerAddr) (FD m (TestAddress peerAddr)))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar
  m (Map (TestAddress peerAddr) (FD m (TestAddress peerAddr)))
nsListeningFDs
                                              STM
  m
  (Map
     (NormalisedId (TestAddress peerAddr))
     (Connection m (TestAddress peerAddr))
   -> (Map (TestAddress peerAddr) (FD m (TestAddress peerAddr)),
       Map
         (NormalisedId (TestAddress peerAddr))
         (Connection m (TestAddress peerAddr))))
-> STM
     m
     (Map
        (NormalisedId (TestAddress peerAddr))
        (Connection m (TestAddress peerAddr)))
-> STM
     m
     (Map (TestAddress peerAddr) (FD m (TestAddress peerAddr)),
      Map
        (NormalisedId (TestAddress peerAddr))
        (Connection m (TestAddress peerAddr)))
forall a b. STM m (a -> b) -> STM m a -> STM m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StrictTVar
  m
  (Map
     (NormalisedId (TestAddress peerAddr))
     (Connection m (TestAddress peerAddr)))
-> STM
     m
     (Map
        (NormalisedId (TestAddress peerAddr))
        (Connection m (TestAddress peerAddr)))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar
  m
  (Map
     (NormalisedId (TestAddress peerAddr))
     (Connection m (TestAddress peerAddr)))
nsConnections
      if |  not (Map.null lstFDMap)
         -> return $ Just (NotReleasedListeningSockets (Map.keys lstFDMap) err)

         |  not (Map.null connMap)
         -> return $ Just (NotReleasedConnections      ( fmap connState
                                                       $ connMap
                                                       ) err)

         |  otherwise
         -> return   Nothing

    toState :: NetworkState m (TestAddress peerAddr)
               -> m (ObservableNetworkState (TestAddress peerAddr))
    toState :: NetworkState m (TestAddress peerAddr)
-> m (ObservableNetworkState (TestAddress peerAddr))
toState NetworkState m (TestAddress peerAddr)
ns = STM m (ObservableNetworkState (TestAddress peerAddr))
-> m (ObservableNetworkState (TestAddress peerAddr))
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (ObservableNetworkState (TestAddress peerAddr))
 -> m (ObservableNetworkState (TestAddress peerAddr)))
-> STM m (ObservableNetworkState (TestAddress peerAddr))
-> m (ObservableNetworkState (TestAddress peerAddr))
forall a b. (a -> b) -> a -> b
$ do
        onsConnections <- (Connection m (TestAddress peerAddr) -> TestAddress peerAddr)
-> Map
     (NormalisedId (TestAddress peerAddr))
     (Connection m (TestAddress peerAddr))
-> Map (NormalisedId (TestAddress peerAddr)) (TestAddress peerAddr)
forall a b.
(a -> b)
-> Map (NormalisedId (TestAddress peerAddr)) a
-> Map (NormalisedId (TestAddress peerAddr)) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Connection m (TestAddress peerAddr) -> TestAddress peerAddr
forall (m :: * -> *) addr. Connection m addr -> addr
connProvider (Map
   (NormalisedId (TestAddress peerAddr))
   (Connection m (TestAddress peerAddr))
 -> Map
      (NormalisedId (TestAddress peerAddr)) (TestAddress peerAddr))
-> STM
     m
     (Map
        (NormalisedId (TestAddress peerAddr))
        (Connection m (TestAddress peerAddr)))
-> STM
     m
     (Map (NormalisedId (TestAddress peerAddr)) (TestAddress peerAddr))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar
  m
  (Map
     (NormalisedId (TestAddress peerAddr))
     (Connection m (TestAddress peerAddr)))
-> STM
     m
     (Map
        (NormalisedId (TestAddress peerAddr))
        (Connection m (TestAddress peerAddr)))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (NetworkState m (TestAddress peerAddr)
-> StrictTVar
     m
     (Map
        (NormalisedId (TestAddress peerAddr))
        (Connection m (TestAddress peerAddr)))
forall (m :: * -> *) addr.
NetworkState m addr
-> StrictTVar m (Map (NormalisedId addr) (Connection m addr))
nsConnections NetworkState m (TestAddress peerAddr)
ns)
        return (ObservableNetworkState 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 " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Maybe addr -> String
forall a. Show a => a -> String
show Maybe addr
mbAddr
    show (FDListening addr
addr StrictTBQueue m (ChannelWithInfo m addr)
_)       = String
"FDListening " String -> ShowS
forall a. [a] -> [a] -> [a]
++ addr -> String
forall a. Show a => a -> String
show addr
addr
    show (FDConnecting ConnectionId addr
connId Connection m addr
conn) = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                                    [ String
"FDConnecting "
                                    , ConnectionId addr -> String
forall a. Show a => a -> String
show ConnectionId addr
connId
                                    , String
" "
                                    , SDUSize -> String
forall a. Show a => a -> String
show (Connection m addr -> SDUSize
forall (m :: * -> *) addr. Connection m addr -> SDUSize
connSDUSize Connection m addr
conn)
                                    ]
    show (FDConnected ConnectionId addr
connId Connection m addr
conn)  = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                                    [ String
"FDConnected "
                                    , ConnectionId addr -> String
forall a. Show a => a -> String
show ConnectionId addr
connId
                                    , String
" "
                                    , SDUSize -> String
forall a. Show a => a -> String
show (Connection m addr -> SDUSize
forall (m :: * -> *) addr. Connection m addr -> SDUSize
connSDUSize Connection m addr
conn)
                                    ]
    show (FDClosed Wedge (ConnectionId addr) addr
mbConnId)        = String
"FDClosed " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Wedge (ConnectionId addr) addr -> String
forall a. Show a => a -> String
show Wedge (ConnectionId addr) addr
mbConnId


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

data FDRawBearerSendTrace
  = SendingBytes Int
  | SentBytes Int
  deriving (Int -> FDRawBearerSendTrace -> ShowS
[FDRawBearerSendTrace] -> ShowS
FDRawBearerSendTrace -> String
(Int -> FDRawBearerSendTrace -> ShowS)
-> (FDRawBearerSendTrace -> String)
-> ([FDRawBearerSendTrace] -> ShowS)
-> Show FDRawBearerSendTrace
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FDRawBearerSendTrace -> ShowS
showsPrec :: Int -> FDRawBearerSendTrace -> ShowS
$cshow :: FDRawBearerSendTrace -> String
show :: FDRawBearerSendTrace -> String
$cshowList :: [FDRawBearerSendTrace] -> ShowS
showList :: [FDRawBearerSendTrace] -> ShowS
Show, FDRawBearerSendTrace -> FDRawBearerSendTrace -> Bool
(FDRawBearerSendTrace -> FDRawBearerSendTrace -> Bool)
-> (FDRawBearerSendTrace -> FDRawBearerSendTrace -> Bool)
-> Eq FDRawBearerSendTrace
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FDRawBearerSendTrace -> FDRawBearerSendTrace -> Bool
== :: FDRawBearerSendTrace -> FDRawBearerSendTrace -> Bool
$c/= :: FDRawBearerSendTrace -> FDRawBearerSendTrace -> Bool
/= :: FDRawBearerSendTrace -> FDRawBearerSendTrace -> Bool
Eq)

data FDRawBearerRecvTrace
  = ReceivingBytes Int
  | ReceivedBytes Int
  | ReadingFromBuffer Int
  | ReadingFromSocket Int
  | CheckingBuffer
  | BufferSize Int
  | UpdateBuffer
      Int -- ^ take
      Int -- ^ keep
  | BufferUpdated
  | EndOfStream
  | Copying
  deriving (Int -> FDRawBearerRecvTrace -> ShowS
[FDRawBearerRecvTrace] -> ShowS
FDRawBearerRecvTrace -> String
(Int -> FDRawBearerRecvTrace -> ShowS)
-> (FDRawBearerRecvTrace -> String)
-> ([FDRawBearerRecvTrace] -> ShowS)
-> Show FDRawBearerRecvTrace
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FDRawBearerRecvTrace -> ShowS
showsPrec :: Int -> FDRawBearerRecvTrace -> ShowS
$cshow :: FDRawBearerRecvTrace -> String
show :: FDRawBearerRecvTrace -> String
$cshowList :: [FDRawBearerRecvTrace] -> ShowS
showList :: [FDRawBearerRecvTrace] -> ShowS
Show, FDRawBearerRecvTrace -> FDRawBearerRecvTrace -> Bool
(FDRawBearerRecvTrace -> FDRawBearerRecvTrace -> Bool)
-> (FDRawBearerRecvTrace -> FDRawBearerRecvTrace -> Bool)
-> Eq FDRawBearerRecvTrace
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FDRawBearerRecvTrace -> FDRawBearerRecvTrace -> Bool
== :: FDRawBearerRecvTrace -> FDRawBearerRecvTrace -> Bool
$c/= :: FDRawBearerRecvTrace -> FDRawBearerRecvTrace -> Bool
/= :: FDRawBearerRecvTrace -> FDRawBearerRecvTrace -> Bool
Eq)

data FDRawBearerTrace
  = TraceSend FDRawBearerSendTrace
  | TraceRecv FDRawBearerRecvTrace
  deriving (Int -> FDRawBearerTrace -> ShowS
[FDRawBearerTrace] -> ShowS
FDRawBearerTrace -> String
(Int -> FDRawBearerTrace -> ShowS)
-> (FDRawBearerTrace -> String)
-> ([FDRawBearerTrace] -> ShowS)
-> Show FDRawBearerTrace
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FDRawBearerTrace -> ShowS
showsPrec :: Int -> FDRawBearerTrace -> ShowS
$cshow :: FDRawBearerTrace -> String
show :: FDRawBearerTrace -> String
$cshowList :: [FDRawBearerTrace] -> ShowS
showList :: [FDRawBearerTrace] -> ShowS
Show, FDRawBearerTrace -> FDRawBearerTrace -> Bool
(FDRawBearerTrace -> FDRawBearerTrace -> Bool)
-> (FDRawBearerTrace -> FDRawBearerTrace -> Bool)
-> Eq FDRawBearerTrace
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FDRawBearerTrace -> FDRawBearerTrace -> Bool
== :: FDRawBearerTrace -> FDRawBearerTrace -> Bool
$c/= :: FDRawBearerTrace -> FDRawBearerTrace -> Bool
/= :: FDRawBearerTrace -> FDRawBearerTrace -> Bool
Eq)

-- | Make a 'RawBearer' from an 'FD'. Since this is only used for testing, we
-- can bypass the requirement of moving raw bytes directly between file
-- descriptors and provided memory buffers, and we can instead covertly use
-- plain old 'ByteString' under the hood. This allows us to use the
-- 'AttenuatedChannel' inside the `FD_`, even though its send and receive
-- methods do not have the right format.
makeFDRawBearer :: forall m addr.
                   ( MonadST m
                   , MonadThrow m
                   , MonadLabelledSTM m
                   , Show addr
                   )
                => Tracer m FDRawBearerTrace
                -> MakeRawBearer m (FD m (TestAddress addr))
makeFDRawBearer :: forall (m :: * -> *) addr.
(MonadST m, MonadThrow m, MonadLabelledSTM m, Show addr) =>
Tracer m FDRawBearerTrace
-> MakeRawBearer m (FD m (TestAddress addr))
makeFDRawBearer Tracer m FDRawBearerTrace
tracer = (FD m (TestAddress addr) -> m (RawBearer m))
-> MakeRawBearer m (FD m (TestAddress addr))
forall (m :: * -> *) fd.
(fd -> m (RawBearer m)) -> MakeRawBearer m fd
MakeRawBearer FD m (TestAddress addr) -> m (RawBearer m)
go
  where
    traceSend :: FDRawBearerSendTrace -> m ()
traceSend = Tracer m FDRawBearerTrace -> FDRawBearerTrace -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m FDRawBearerTrace
tracer (FDRawBearerTrace -> m ())
-> (FDRawBearerSendTrace -> FDRawBearerTrace)
-> FDRawBearerSendTrace
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FDRawBearerSendTrace -> FDRawBearerTrace
TraceSend

    traceRecv :: FDRawBearerRecvTrace -> m ()
traceRecv = Tracer m FDRawBearerTrace -> FDRawBearerTrace -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m FDRawBearerTrace
tracer (FDRawBearerTrace -> m ())
-> (FDRawBearerRecvTrace -> FDRawBearerTrace)
-> FDRawBearerRecvTrace
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FDRawBearerRecvTrace -> FDRawBearerTrace
TraceRecv

    go :: FD m (TestAddress addr) -> m (RawBearer m)
go (FD {StrictTVar m (FD_ m (TestAddress addr))
fdVar :: forall (m :: * -> *) peerAddr.
FD m peerAddr -> StrictTVar m (FD_ m peerAddr)
fdVar :: StrictTVar m (FD_ m (TestAddress addr))
fdVar}) = do
      (bufVar :: StrictTMVar m LBS.ByteString) <- ByteString -> m (StrictTMVar m ByteString)
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTMVar m a)
newTMVarIO ByteString
LBS.empty
      return RawBearer
                { send = \Ptr Word8
src Int
srcSize -> do
                    StrictTVar m (FD_ m (TestAddress addr)) -> String -> m ()
forall (m :: * -> *) a.
MonadLabelledSTM m =>
StrictTVar m a -> String -> m ()
labelTVarIO StrictTVar m (FD_ m (TestAddress addr))
fdVar String
"sender"
                    FDRawBearerSendTrace -> m ()
traceSend (FDRawBearerSendTrace -> m ()) -> FDRawBearerSendTrace -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> FDRawBearerSendTrace
SendingBytes Int
srcSize
                    fd_ <- StrictTVar m (FD_ m (TestAddress addr))
-> m (FD_ m (TestAddress addr))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> m a
readTVarIO StrictTVar m (FD_ m (TestAddress addr))
fdVar
                    case fd_ of
                      FDConnected ConnectionId (TestAddress addr)
_ Connection m (TestAddress addr)
conn -> do
                        bs <- ST (PrimState m) StrictByteString -> m StrictByteString
forall a. ST (PrimState m) a -> m a
forall (m :: * -> *) a. MonadST m => ST (PrimState m) a -> m a
stToIO (ST (PrimState m) StrictByteString -> m StrictByteString)
-> (IO StrictByteString -> ST (PrimState m) StrictByteString)
-> IO StrictByteString
-> m StrictByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO StrictByteString -> ST (PrimState m) StrictByteString
forall a s. IO a -> ST s a
unsafeIOToST (IO StrictByteString -> m StrictByteString)
-> IO StrictByteString -> m StrictByteString
forall a b. (a -> b) -> a -> b
$ CStringLen -> IO StrictByteString
BS.packCStringLen (Ptr Word8 -> Ptr CChar
forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
src, Int
srcSize)
                        let bsl = StrictByteString -> ByteString
LBS.fromStrict StrictByteString
bs
                        acWrite (connChannelLocal conn) bsl
                        traceSend $ SentBytes srcSize
                        return srcSize
                      FD_ m (TestAddress addr)
_ ->
                        IOError -> m Int
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (FD_ m (TestAddress addr) -> IOError
invalidError FD_ m (TestAddress addr)
fd_)
                , recv = \Ptr Word8
dst Int
size -> do
                    StrictTVar m (FD_ m (TestAddress addr)) -> String -> m ()
forall (m :: * -> *) a.
MonadLabelledSTM m =>
StrictTVar m a -> String -> m ()
labelTVarIO StrictTVar m (FD_ m (TestAddress addr))
fdVar String
"receiver"
                    let size64 :: Size
size64 = Int -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
size
                    FDRawBearerRecvTrace -> m ()
traceRecv (FDRawBearerRecvTrace -> m ()) -> FDRawBearerRecvTrace -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> FDRawBearerRecvTrace
ReceivingBytes Int
size
                    fd_ <- StrictTVar m (FD_ m (TestAddress addr))
-> m (FD_ m (TestAddress addr))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> m a
readTVarIO StrictTVar m (FD_ m (TestAddress addr))
fdVar
                    case fd_ of
                      FDConnected ConnectionId (TestAddress addr)
_ Connection m (TestAddress addr)
conn -> do
                        FDRawBearerRecvTrace -> m ()
traceRecv FDRawBearerRecvTrace
CheckingBuffer
                        bytesFromBuffer <- STM m ByteString -> m ByteString
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m ByteString -> m ByteString)
-> STM m ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ StrictTMVar m ByteString -> STM m ByteString
forall (m :: * -> *) a. MonadSTM m => StrictTMVar m a -> STM m a
takeTMVar StrictTMVar m ByteString
bufVar
                        traceRecv $ BufferSize (fromIntegral $ LBS.length bytesFromBuffer)
                        (lhs, rhs) <- if not (LBS.null bytesFromBuffer)
                          then do
                            traceRecv $ ReadingFromBuffer size
                            return (LBS.take size64 bytesFromBuffer, LBS.drop size64 bytesFromBuffer)
                          else do
                            traceRecv $ ReadingFromSocket size
                            bytesRead <- acRead (connChannelLocal conn)
                            traceRecv $ ReceivedBytes (fromIntegral . LBS.length $ LBS.take size64 bytesRead)
                            return (LBS.take size64 bytesRead, LBS.drop size64 bytesRead)
                        traceRecv $ UpdateBuffer (fromIntegral $ LBS.length lhs) (fromIntegral $ LBS.length rhs)
                        atomically $ putTMVar bufVar rhs
                        traceRecv $ BufferUpdated
                        if LBS.null lhs then do
                          traceRecv EndOfStream
                          return 0
                        else do
                          traceRecv Copying
                          let bs = ByteString -> StrictByteString
LBS.toStrict ByteString
lhs
                          stToIO . unsafeIOToST $ BS.useAsCStringLen bs $ \(Ptr CChar
src, Int
srcSize) -> do
                              Ptr Word8 -> Ptr Word8 -> Int -> IO ()
forall a. Ptr a -> Ptr a -> Int -> IO ()
copyBytes Ptr Word8
dst (Ptr CChar -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
src) Int
srcSize
                              Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
srcSize
                      FD_ m (TestAddress addr)
_ ->
                        IOError -> m Int
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (FD_ m (TestAddress addr) -> IOError
invalidError FD_ m (TestAddress addr)
fd_)
                }

    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      = Maybe Handle
forall a. Maybe a
Nothing
      , ioe_type :: IOErrorType
ioe_type        = IOErrorType
InvalidArgument
      , ioe_location :: String
ioe_location    = String
"Ouroboros.Network.Snocket.Sim.toRawBearer"
      , ioe_description :: String
ioe_description = String -> ShowS
forall r. PrintfType r => String -> r
printf String
"Invalid argument (%s)" (FD_ m (TestAddress addr) -> String
forall a. Show a => a -> String
show FD_ m (TestAddress addr)
fd_)
      , ioe_errno :: Maybe CInt
ioe_errno       = Maybe CInt
forall a. Maybe a
Nothing
      , ioe_filename :: Maybe String
ioe_filename    = Maybe String
forall a. Maybe a
Nothing
      }

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

--
-- 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
[WithAddr addr event] -> ShowS
WithAddr addr event -> String
(Int -> WithAddr addr event -> ShowS)
-> (WithAddr addr event -> String)
-> ([WithAddr addr event] -> ShowS)
-> Show (WithAddr addr event)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall addr event.
(Show addr, Show event) =>
Int -> WithAddr addr event -> ShowS
forall addr event.
(Show addr, Show event) =>
[WithAddr addr event] -> ShowS
forall addr event.
(Show addr, Show event) =>
WithAddr addr event -> String
$cshowsPrec :: forall addr event.
(Show addr, Show event) =>
Int -> WithAddr addr event -> ShowS
showsPrec :: Int -> WithAddr addr event -> ShowS
$cshow :: forall addr event.
(Show addr, Show event) =>
WithAddr addr event -> String
show :: WithAddr addr event -> String
$cshowList :: forall addr event.
(Show addr, Show event) =>
[WithAddr addr event] -> ShowS
showList :: [WithAddr addr event] -> ShowS
Show

data SockType = ListeningSock
              | ConnectionSock
              | UnknownType
  deriving Int -> SockType -> ShowS
[SockType] -> ShowS
SockType -> String
(Int -> SockType -> ShowS)
-> (SockType -> String) -> ([SockType] -> ShowS) -> Show SockType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SockType -> ShowS
showsPrec :: Int -> SockType -> ShowS
$cshow :: SockType -> String
show :: SockType -> String
$cshowList :: [SockType] -> ShowS
showList :: [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
(Int -> TimeoutDetail -> ShowS)
-> (TimeoutDetail -> String)
-> ([TimeoutDetail] -> ShowS)
-> Show TimeoutDetail
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TimeoutDetail -> ShowS
showsPrec :: Int -> TimeoutDetail -> ShowS
$cshow :: TimeoutDetail -> String
show :: TimeoutDetail -> String
$cshowList :: [TimeoutDetail] -> ShowS
showList :: [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
[SnocketTrace m addr] -> ShowS
SnocketTrace m addr -> String
(Int -> SnocketTrace m addr -> ShowS)
-> (SnocketTrace m addr -> String)
-> ([SnocketTrace m addr] -> ShowS)
-> Show (SnocketTrace m addr)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (m :: * -> *) addr.
Show addr =>
Int -> SnocketTrace m addr -> ShowS
forall (m :: * -> *) addr.
Show addr =>
[SnocketTrace m addr] -> ShowS
forall (m :: * -> *) addr.
Show addr =>
SnocketTrace m addr -> String
$cshowsPrec :: forall (m :: * -> *) addr.
Show addr =>
Int -> SnocketTrace m addr -> ShowS
showsPrec :: Int -> SnocketTrace m addr -> ShowS
$cshow :: forall (m :: * -> *) addr.
Show addr =>
SnocketTrace m addr -> String
show :: SnocketTrace m addr -> String
$cshowList :: forall (m :: * -> *) addr.
Show addr =>
[SnocketTrace m addr] -> ShowS
showList :: [SnocketTrace m addr] -> ShowS
Show

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

    -- | Normal open
    | NormalOpen
  deriving Int -> OpenType -> ShowS
[OpenType] -> ShowS
OpenType -> String
(Int -> OpenType -> ShowS)
-> (OpenType -> String) -> ([OpenType] -> ShowS) -> Show OpenType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> OpenType -> ShowS
showsPrec :: Int -> OpenType -> ShowS
$cshow :: OpenType -> String
show :: OpenType -> String
$cshowList :: [OpenType] -> ShowS
showList :: [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 :: forall (m :: * -> *) peerAddr.
FD m peerAddr -> StrictTVar m (FD_ m peerAddr)
fdVar :: StrictTVar m (FD_ m (TestAddress addr))
fdVar } = do
        fd_ <- STM m (FD_ m (TestAddress addr)) -> m (FD_ m (TestAddress addr))
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (StrictTVar m (FD_ m (TestAddress addr))
-> STM m (FD_ m (TestAddress addr))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (FD_ m (TestAddress addr))
fdVar)
        return $ case fd_ of
          FDUninitialised Maybe (TestAddress addr)
Nothing         -> FD_ m (TestAddress addr)
-> Either (FD_ m (TestAddress addr)) (TestAddress addr)
forall a b. a -> Either a b
Left FD_ m (TestAddress addr)
fd_
          FDUninitialised (Just TestAddress addr
peerAddr) -> TestAddress addr
-> Either (FD_ m (TestAddress addr)) (TestAddress addr)
forall a b. b -> Either a b
Right TestAddress addr
peerAddr
          FDListening TestAddress addr
peerAddr StrictTBQueue m (ChannelWithInfo m (TestAddress addr))
_          -> TestAddress addr
-> Either (FD_ m (TestAddress addr)) (TestAddress addr)
forall a b. b -> Either a b
Right TestAddress addr
peerAddr
          FDConnecting ConnectionId { TestAddress addr
localAddress :: forall addr. ConnectionId addr -> addr
localAddress :: TestAddress addr
localAddress } Connection m (TestAddress addr)
_
                                          -> TestAddress addr
-> Either (FD_ m (TestAddress addr)) (TestAddress addr)
forall a b. b -> Either a b
Right TestAddress addr
localAddress
          FDConnected  ConnectionId { TestAddress addr
localAddress :: forall addr. ConnectionId addr -> addr
localAddress :: TestAddress addr
localAddress } Connection m (TestAddress addr)
_
                                          -> TestAddress addr
-> Either (FD_ m (TestAddress addr)) (TestAddress addr)
forall a b. b -> Either a b
Right TestAddress addr
localAddress
          FDClosed {}                     -> FD_ m (TestAddress addr)
-> Either (FD_ m (TestAddress addr)) (TestAddress addr)
forall a b. a -> Either a b
Left FD_ m (TestAddress addr)
fd_

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

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

    --
    -- Snocket api
    --

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

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


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


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


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

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

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

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

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

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

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

                Maybe (Connection m (TestAddress addr))
Nothing -> do
                  conn <- Tracer
  m (WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr)))
-> BearerInfo
-> ConnectionId (TestAddress addr)
-> STM m (Connection m (TestAddress addr))
forall (m :: * -> *) addr.
(MonadDelay m, MonadLabelledSTM m, MonadTimer m, MonadThrow m,
 MonadThrow (STM m), Eq addr) =>
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
                  writeTVar fdVarLocal (FDConnecting connId conn)
                  modifyTVar (nsConnections state)
                             (Map.insert (normaliseId connId) 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
                  return (connId, bearerInfo, NormalOpen)

            traceWith tr (WithAddr (Just (localAddress connId))
                                   (Just remoteAddress)
                                   (STBearerInfo 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
            connDelayTimeoutVar <-
              registerDelay (biConnectionDelay bearerInfo `min` connectTimeout)
            unmask
              (atomically $ runFirstToFinish $
                  FirstToFinish
                    (LazySTM.readTVar connDelayTimeoutVar >>= check)
                  <>
                  FirstToFinish (do
                    b <- not . Map.member (normaliseId connId)
                      <$> readTVar (nsConnections state)
                    check b
                    throwSTM $ connectIOError connId
                             $ "unknown connection: "
                            ++ show (normaliseId connId))
              )
              `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 simOpen of
                  OpenType
NormalOpen ->
                    STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (StrictTVar
  m
  (Map
     (NormalisedId (TestAddress addr))
     (Connection m (TestAddress addr)))
-> (Map
      (NormalisedId (TestAddress addr)) (Connection m (TestAddress addr))
    -> Map
         (NormalisedId (TestAddress addr))
         (Connection m (TestAddress addr)))
-> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar (NetworkState m (TestAddress addr)
-> StrictTVar
     m
     (Map
        (NormalisedId (TestAddress addr))
        (Connection m (TestAddress addr)))
forall (m :: * -> *) addr.
NetworkState m addr
-> StrictTVar m (Map (NormalisedId addr) (Connection m addr))
nsConnections NetworkState m (TestAddress addr)
state)
                                           (NormalisedId (TestAddress addr)
-> Map
     (NormalisedId (TestAddress addr)) (Connection m (TestAddress addr))
-> Map
     (NormalisedId (TestAddress addr)) (Connection m (TestAddress addr))
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete (ConnectionId (TestAddress addr) -> NormalisedId (TestAddress addr)
forall addr. Ord addr => ConnectionId addr -> NormalisedId addr
normaliseId ConnectionId (TestAddress addr)
connId)))
                  OpenType
SimOpen -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                )

            when (biConnectionDelay bearerInfo >= connectTimeout) $ do
              traceWith' fd (STConnectTimeout WaitingToConnect)
              atomically $ modifyTVar (nsConnections state)
                                      (Map.delete (normaliseId connId))
              throwIO (connectIOError connId "connect timeout: when connecting")

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

                (Just (FDListening TestAddress addr
_ 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_' = ConnectionId (TestAddress addr)
-> Connection m (TestAddress addr) -> FD_ m (TestAddress addr)
forall (m :: * -> *) addr.
ConnectionId addr -> Connection m addr -> FD_ m addr
FDConnected ConnectionId (TestAddress addr)
connId
                               (Connection m (TestAddress addr) -> FD_ m (TestAddress addr))
-> Connection m (TestAddress addr) -> FD_ m (TestAddress addr)
forall a b. (a -> b) -> a -> b
$ case OpenType
simOpen of
                                   OpenType
SimOpen    -> Connection m (TestAddress addr) -> Connection m (TestAddress addr)
forall (m :: * -> *) addr. Connection m addr -> Connection m addr
dualConnection Connection m (TestAddress addr)
conn
                                   OpenType
NormalOpen ->                Connection m (TestAddress addr)
conn
                      StrictTVar m (FD_ m (TestAddress addr))
-> FD_ m (TestAddress addr) -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (FD_ m (TestAddress addr))
fdVarLocal FD_ m (TestAddress addr)
fd_'
                      Either IOError (FD_ m (TestAddress addr), OpenType)
-> STM m (Either IOError (FD_ m (TestAddress addr), OpenType))
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((FD_ m (TestAddress addr), OpenType)
-> Either IOError (FD_ m (TestAddress addr), OpenType)
forall a b. b -> Either a b
Right (FD_ m (TestAddress addr)
fd_', OpenType
SimOpen))

                    -- normal open: at this stage the other side did not open
                    -- a connection, we add 'ChannelWithInfo' into accept loop.
                    Just conn :: Connection m (TestAddress addr)
conn@Connection { connState :: forall (m :: * -> *) addr. Connection m addr -> ConnectionState
connState = ConnectionState
SYN_SENT } -> do
                      let fd_' :: FD_ m (TestAddress addr)
fd_' = ConnectionId (TestAddress addr)
-> Connection m (TestAddress addr) -> FD_ m (TestAddress addr)
forall (m :: * -> *) addr.
ConnectionId addr -> Connection m addr -> FD_ m addr
FDConnected ConnectionId (TestAddress addr)
connId Connection m (TestAddress addr)
conn
                      StrictTVar m (FD_ m (TestAddress addr))
-> FD_ m (TestAddress addr) -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (FD_ m (TestAddress addr))
fdVarLocal FD_ m (TestAddress addr)
fd_'
                      Bool -> STM m () -> STM m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ConnectionId (TestAddress addr) -> TestAddress addr
forall addr. ConnectionId addr -> addr
localAddress ConnectionId (TestAddress addr)
connId TestAddress addr -> TestAddress addr -> Bool
forall a. Eq a => a -> a -> Bool
/= TestAddress addr
remoteAddress) (STM m () -> STM m ()) -> STM m () -> STM m ()
forall a b. (a -> b) -> a -> b
$
                        -- We only write to the accept `queue` if we're not
                        -- connecting to ourselves.
                        StrictTBQueue m (ChannelWithInfo m (TestAddress addr))
-> ChannelWithInfo m (TestAddress addr) -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTBQueue m a -> a -> STM m ()
writeTBQueue StrictTBQueue m (ChannelWithInfo m (TestAddress addr))
queue
                                     ChannelWithInfo
                                       { cwiAddress :: TestAddress addr
cwiAddress       = ConnectionId (TestAddress addr) -> TestAddress addr
forall addr. ConnectionId addr -> addr
localAddress ConnectionId (TestAddress addr)
connId
                                       , cwiSDUSize :: SDUSize
cwiSDUSize       = BearerInfo -> SDUSize
biSDUSize BearerInfo
bearerInfo
                                       , cwiChannelLocal :: AttenuatedChannel m
cwiChannelLocal  = Connection m (TestAddress addr) -> AttenuatedChannel m
forall (m :: * -> *) addr. Connection m addr -> AttenuatedChannel m
connChannelRemote Connection m (TestAddress addr)
conn
                                       , cwiChannelRemote :: AttenuatedChannel m
cwiChannelRemote = Connection m (TestAddress addr) -> AttenuatedChannel m
forall (m :: * -> *) addr. Connection m addr -> AttenuatedChannel m
connChannelLocal Connection m (TestAddress addr)
conn
                                       }
                      Either IOError (FD_ m (TestAddress addr), OpenType)
-> STM m (Either IOError (FD_ m (TestAddress addr), OpenType))
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((FD_ m (TestAddress addr), OpenType)
-> Either IOError (FD_ m (TestAddress addr), OpenType)
forall a b. b -> Either a b
Right (FD_ m (TestAddress addr)
fd_', OpenType
NormalOpen))

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

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

            case efd of
              Left IOError
e          -> do
                FD m (TestAddress addr)
-> SnocketTrace m (TestAddress addr) -> m ()
traceWith' FD m (TestAddress addr)
fd (FD_ m (TestAddress addr)
-> TestAddress addr -> IOError -> SnocketTrace m (TestAddress addr)
forall (m :: * -> *) addr.
FD_ m addr -> addr -> IOError -> SnocketTrace m addr
STConnectError FD_ m (TestAddress addr)
fd_ TestAddress addr
remoteAddress IOError
e)
                STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ StrictTVar
  m
  (Map
     (NormalisedId (TestAddress addr))
     (Connection m (TestAddress addr)))
-> (Map
      (NormalisedId (TestAddress addr)) (Connection m (TestAddress addr))
    -> Map
         (NormalisedId (TestAddress addr))
         (Connection m (TestAddress addr)))
-> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar (NetworkState m (TestAddress addr)
-> StrictTVar
     m
     (Map
        (NormalisedId (TestAddress addr))
        (Connection m (TestAddress addr)))
forall (m :: * -> *) addr.
NetworkState m addr
-> StrictTVar m (Map (NormalisedId addr) (Connection m addr))
nsConnections NetworkState m (TestAddress addr)
state)
                                        (NormalisedId (TestAddress addr)
-> Map
     (NormalisedId (TestAddress addr)) (Connection m (TestAddress addr))
-> Map
     (NormalisedId (TestAddress addr)) (Connection m (TestAddress addr))
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete (ConnectionId (TestAddress addr) -> NormalisedId (TestAddress addr)
forall addr. Ord addr => ConnectionId addr -> NormalisedId addr
normaliseId ConnectionId (TestAddress addr)
connId))
                IOError -> m ()
forall e a. Exception e => e -> m a
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.
                timeoutVar <-
                  DiffTime -> m (TVar m Bool)
forall (m :: * -> *). MonadTimer m => DiffTime -> m (TVar m Bool)
registerDelay (DiffTime
connectTimeout DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
- BearerInfo -> DiffTime
biConnectionDelay BearerInfo
bearerInfo)
                r <-
                  handleJust
                    (\SomeException
e -> case SomeException -> Maybe SomeAsyncException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
                             Just SomeAsyncException {} -> SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just SomeException
e
                             Maybe SomeAsyncException
Nothing                    -> Maybe SomeException
forall a. Maybe a
Nothing)
                    (\SomeException
e -> STM m (Maybe ()) -> m (Maybe ())
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Maybe ()) -> m (Maybe ()))
-> STM m (Maybe ()) -> m (Maybe ())
forall a b. (a -> b) -> a -> b
$ StrictTVar
  m
  (Map
     (NormalisedId (TestAddress addr))
     (Connection m (TestAddress addr)))
-> (Map
      (NormalisedId (TestAddress addr)) (Connection m (TestAddress addr))
    -> Map
         (NormalisedId (TestAddress addr))
         (Connection m (TestAddress addr)))
-> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar (NetworkState m (TestAddress addr)
-> StrictTVar
     m
     (Map
        (NormalisedId (TestAddress addr))
        (Connection m (TestAddress addr)))
forall (m :: * -> *) addr.
NetworkState m addr
-> StrictTVar m (Map (NormalisedId addr) (Connection m addr))
nsConnections NetworkState m (TestAddress addr)
state)
                                                   (NormalisedId (TestAddress addr)
-> Map
     (NormalisedId (TestAddress addr)) (Connection m (TestAddress addr))
-> Map
     (NormalisedId (TestAddress addr)) (Connection m (TestAddress addr))
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete (ConnectionId (TestAddress addr) -> NormalisedId (TestAddress addr)
forall addr. Ord addr => ConnectionId addr -> NormalisedId addr
normaliseId ConnectionId (TestAddress addr)
connId))
                        STM m () -> STM m (Maybe ()) -> STM m (Maybe ())
forall a b. STM m a -> STM m b -> STM m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SomeException -> STM m (Maybe ())
forall e a. Exception e => e -> STM m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO SomeException
e)
                    $ unmask . atomically . runFirstToFinish $
                        FirstToFinish (do
                          LazySTM.readTVar timeoutVar >>= check
                          modifyTVar (nsConnections state)
                                     (Map.delete (normaliseId connId))
                          return Nothing
                        )
                        <>
                        FirstToFinish (do
                          mbConn <- Map.lookup (normaliseId connId)
                                <$> readTVar (nsConnections state)
                          case mbConn of
                            -- it could happen that the 'accept' removes the
                            -- connection from the state; we treat this as an io
                            -- exception.
                            Maybe (Connection m (TestAddress addr))
Nothing -> do
                              StrictTVar
  m
  (Map
     (NormalisedId (TestAddress addr))
     (Connection m (TestAddress addr)))
-> (Map
      (NormalisedId (TestAddress addr)) (Connection m (TestAddress addr))
    -> Map
         (NormalisedId (TestAddress addr))
         (Connection m (TestAddress addr)))
-> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar (NetworkState m (TestAddress addr)
-> StrictTVar
     m
     (Map
        (NormalisedId (TestAddress addr))
        (Connection m (TestAddress addr)))
forall (m :: * -> *) addr.
NetworkState m addr
-> StrictTVar m (Map (NormalisedId addr) (Connection m addr))
nsConnections NetworkState m (TestAddress addr)
state)
                                         (NormalisedId (TestAddress addr)
-> Map
     (NormalisedId (TestAddress addr)) (Connection m (TestAddress addr))
-> Map
     (NormalisedId (TestAddress addr)) (Connection m (TestAddress addr))
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete (ConnectionId (TestAddress addr) -> NormalisedId (TestAddress addr)
forall addr. Ord addr => ConnectionId addr -> NormalisedId addr
normaliseId ConnectionId (TestAddress addr)
connId))
                              IOError -> STM m (Maybe ())
forall (m :: * -> *) e a.
(MonadSTM m, MonadThrow (STM m), Exception e) =>
e -> STM m a
throwSTM (IOError -> STM m (Maybe ())) -> IOError -> STM m (Maybe ())
forall a b. (a -> b) -> a -> b
$ ConnectionId (TestAddress addr) -> String -> IOError
connectIOError ConnectionId (TestAddress addr)
connId
                                       (String -> IOError) -> String -> IOError
forall a b. (a -> b) -> a -> b
$ String
"unknown connection: "
                                      String -> ShowS
forall a. [a] -> [a] -> [a]
++ NormalisedId (TestAddress addr) -> String
forall a. Show a => a -> String
show (ConnectionId (TestAddress addr) -> NormalisedId (TestAddress addr)
forall addr. Ord addr => ConnectionId addr -> NormalisedId addr
normaliseId ConnectionId (TestAddress addr)
connId)
                            Just Connection { ConnectionState
connState :: forall (m :: * -> *) addr. Connection m addr -> ConnectionState
connState :: ConnectionState
connState } ->
                              () -> Maybe ()
forall a. a -> Maybe a
Just (() -> Maybe ()) -> STM m () -> STM m (Maybe ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> STM m ()
forall (m :: * -> *). MonadSTM m => Bool -> STM m ()
check (ConnectionState
connState ConnectionState -> ConnectionState -> Bool
forall a. Eq a => a -> a -> Bool
== ConnectionState
ESTABLISHED))

                case r of
                  -- self connect
                  Maybe ()
Nothing | ConnectionId (TestAddress addr) -> TestAddress addr
forall addr. ConnectionId addr -> addr
localAddress ConnectionId (TestAddress addr)
connId TestAddress addr -> TestAddress addr -> Bool
forall a. Eq a => a -> a -> Bool
== TestAddress addr
remoteAddress
                          -> FD m (TestAddress addr)
-> SnocketTrace m (TestAddress addr) -> m ()
traceWith' FD m (TestAddress addr)
fd (FD_ m (TestAddress addr)
-> OpenType -> SnocketTrace m (TestAddress addr)
forall (m :: * -> *) addr.
FD_ m addr -> OpenType -> SnocketTrace m addr
STConnected FD_ m (TestAddress addr)
fd_' OpenType
o)

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

                  Just ()
_  -> FD m (TestAddress addr)
-> SnocketTrace m (TestAddress addr) -> m ()
traceWith' FD m (TestAddress addr)
fd (FD_ m (TestAddress addr)
-> OpenType -> SnocketTrace m (TestAddress addr)
forall (m :: * -> *) addr.
FD_ m addr -> OpenType -> SnocketTrace m addr
STConnected FD_ m (TestAddress addr)
fd_' OpenType
o)

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

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

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

          FDClosed {} ->
            IOError -> m ()
forall e a. Exception e => e -> m a
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      = Maybe Handle
forall a. Maybe a
Nothing
          , ioe_type :: IOErrorType
ioe_type        = IOErrorType
OtherError
          , ioe_location :: String
ioe_location    = String
"Ouroboros.Network.Snocket.Sim.connect"
          , ioe_description :: String
ioe_description = String
"Transport endpoint is not connected"
          , ioe_errno :: Maybe CInt
ioe_errno       = Maybe CInt
forall a. Maybe a
Nothing
          , ioe_filename :: Maybe String
ioe_filename    = Maybe String
forall a. Maybe a
Nothing
          }

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

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

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


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


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

          FDUninitialised (Just TestAddress addr
addr) -> do
            queue <- Natural
-> STM m (StrictTBQueue m (ChannelWithInfo m (TestAddress addr)))
forall (m :: * -> *) a.
MonadSTM m =>
Natural -> STM m (StrictTBQueue m a)
newTBQueue Natural
bound
            labelTBQueue queue ("aq-" ++ show addr)
            writeTVar fdVar (FDListening addr queue)
            modifyTVar (nsListeningFDs state) (Map.insert addr fd)

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

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


    accept :: FD m (TestAddress addr)
           -> m (Accept m (FD m (TestAddress addr))
                                (TestAddress addr))
    accept :: FD m (TestAddress addr)
-> m (Accept m (FD m (TestAddress addr)) (TestAddress addr))
accept FD { StrictTVar m (FD_ m (TestAddress addr))
fdVar :: forall (m :: * -> *) peerAddr.
FD m peerAddr -> StrictTVar m (FD_ m peerAddr)
fdVar :: StrictTVar m (FD_ m (TestAddress addr))
fdVar } = do time <- m Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime
                             let deltaAndIOErr =
                                   BearerInfo -> Maybe (DiffTime, IOError)
biAcceptFailures (NetworkState m (TestAddress addr) -> BearerInfo
forall (m :: * -> *) addr. NetworkState m addr -> BearerInfo
nsDefaultBearerInfo NetworkState m (TestAddress addr)
state)
                             return $ accept_ time 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
          connMap <- StrictTVar
  m
  (Map
     (NormalisedId (TestAddress addr))
     (Connection m (TestAddress addr)))
-> STM
     m
     (Map
        (NormalisedId (TestAddress addr))
        (Connection m (TestAddress addr)))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (NetworkState m (TestAddress addr)
-> StrictTVar
     m
     (Map
        (NormalisedId (TestAddress addr))
        (Connection m (TestAddress addr)))
forall (m :: * -> *) addr.
NetworkState m addr
-> StrictTVar m (Map (NormalisedId addr) (Connection m addr))
nsConnections NetworkState m (TestAddress addr)
state)
          let connId = TestAddress addr
-> TestAddress addr -> ConnectionId (TestAddress addr)
forall addr. addr -> addr -> ConnectionId addr
ConnectionId TestAddress addr
localAddress (ChannelWithInfo m (TestAddress addr) -> TestAddress addr
forall (m :: * -> *) addr. ChannelWithInfo m addr -> addr
cwiAddress ChannelWithInfo m (TestAddress addr)
cwi)

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

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

                  FDListening TestAddress addr
localAddress 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.
                    cwi <- (ChannelWithInfo m (TestAddress addr) -> STM m Bool)
-> StrictTBQueue m (ChannelWithInfo m (TestAddress addr))
-> STM m (ChannelWithInfo m (TestAddress addr))
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
localAddress :: TestAddress addr
localAddress :: TestAddress addr
localAddress,
                                                remoteAddress :: TestAddress addr
remoteAddress = ChannelWithInfo m (TestAddress addr) -> TestAddress addr
forall (m :: * -> *) addr. ChannelWithInfo m addr -> addr
cwiAddress ChannelWithInfo m (TestAddress addr)
cwi }

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

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

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

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

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

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

                    traceWith tr (WithAddr (Just localAddress) Nothing
                                           (STAccepted remoteAddress))

                    return (Accepted fdRemote remoteAddress, accept_ time deltaAndIOErr)


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


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

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

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

        -- update NetworkState
        atomically $ bitraverse_
          (\(ConnectionId (TestAddress addr)
connId, SockType
_, AttenuatedChannel m
_) ->
             StrictTVar
  m
  (Map
     (NormalisedId (TestAddress addr))
     (Connection m (TestAddress addr)))
-> (Map
      (NormalisedId (TestAddress addr)) (Connection m (TestAddress addr))
    -> Map
         (NormalisedId (TestAddress addr))
         (Connection m (TestAddress addr)))
-> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar (NetworkState m (TestAddress addr)
-> StrictTVar
     m
     (Map
        (NormalisedId (TestAddress addr))
        (Connection m (TestAddress addr)))
forall (m :: * -> *) addr.
NetworkState m addr
-> StrictTVar m (Map (NormalisedId addr) (Connection m addr))
nsConnections NetworkState m (TestAddress addr)
state)
                        ((Connection m (TestAddress addr)
 -> Maybe (Connection m (TestAddress addr)))
-> NormalisedId (TestAddress addr)
-> Map
     (NormalisedId (TestAddress addr)) (Connection m (TestAddress addr))
-> Map
     (NormalisedId (TestAddress addr)) (Connection m (TestAddress addr))
forall k a. Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a
Map.update
                          (\conn :: Connection m (TestAddress addr)
conn@Connection { ConnectionState
connState :: forall (m :: * -> *) addr. Connection m addr -> ConnectionState
connState :: ConnectionState
connState } ->
                            case ConnectionState
connState of
                              ConnectionState
FIN ->
                                Maybe (Connection m (TestAddress addr))
forall a. Maybe a
Nothing
                              ConnectionState
_ ->
                                Connection m (TestAddress addr)
-> Maybe (Connection m (TestAddress addr))
forall a. a -> Maybe a
Just Connection m (TestAddress addr)
conn { connState = FIN })
                          (ConnectionId (TestAddress addr) -> NormalisedId (TestAddress addr)
forall addr. Ord addr => ConnectionId addr -> NormalisedId addr
normaliseId ConnectionId (TestAddress addr)
connId)))
          (\(TestAddress addr
addr,   SockType
_, [(TestAddress addr, AttenuatedChannel m)]
_) ->
             StrictTVar m (Map (TestAddress addr) (FD m (TestAddress addr)))
-> (Map (TestAddress addr) (FD m (TestAddress addr))
    -> Map (TestAddress addr) (FD m (TestAddress addr)))
-> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar (NetworkState m (TestAddress addr)
-> StrictTVar m (Map (TestAddress addr) (FD m (TestAddress addr)))
forall (m :: * -> *) addr.
NetworkState m addr -> StrictTVar m (Map addr (FD m addr))
nsListeningFDs NetworkState m (TestAddress addr)
state)
                        (TestAddress addr
-> Map (TestAddress addr) (FD m (TestAddress addr))
-> Map (TestAddress addr) (FD m (TestAddress addr))
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete TestAddress addr
addr))
          wChannel

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

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

          )
          wChannel


--
-- Utils
--

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

drainTBQueue :: MonadSTM m => StrictTBQueue m a -> STM m [a]
drainTBQueue :: forall (m :: * -> *) a.
MonadSTM m =>
StrictTBQueue m a -> STM m [a]
drainTBQueue StrictTBQueue m a
q = do
  ma <- StrictTBQueue m a -> STM m (Maybe a)
forall (m :: * -> *) a.
MonadSTM m =>
StrictTBQueue m a -> STM m (Maybe a)
tryReadTBQueue StrictTBQueue m a
q
  case ma of
    Maybe a
Nothing -> [a] -> STM m [a]
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    Just a
a  -> (a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
:) ([a] -> [a]) -> STM m [a] -> STM m [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTBQueue m a -> STM m [a]
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 <- StrictTBQueue m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => StrictTBQueue m a -> STM m a
readTBQueue StrictTBQueue m a
q
  b <- p a
  if b
     then return a
     else readTBQueueUntil p q