{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
module Simulation.Network.Snocket
(
withSnocket
, ObservableNetworkState (..)
, ResourceException (..)
, SDUSize
, Script (..)
, Size
, SnocketTrace (..)
, SockType (..)
, OpenType (..)
, normaliseId
, BearerInfo (..)
, IOErrType (..)
, SuccessOrFailure (..)
, TimeoutDetail (..)
, noAttenuation
, FD
, makeFDBearer
, GlobalAddressScheme (..)
, AddressType (..)
, WithAddr (..)
) where
import Prelude hiding (read)
import Control.Applicative (Alternative)
import Control.Concurrent.Class.MonadSTM qualified as LazySTM
import Control.Concurrent.Class.MonadSTM.Strict
import Control.Monad (when)
import Control.Monad.Class.MonadThrow
import Control.Monad.Class.MonadTime.SI
import Control.Monad.Class.MonadTimer.SI
import Control.Tracer (Tracer, contramap, contramapM, traceWith)
import GHC.IO.Exception
import Data.Bifoldable (bitraverse_)
import Data.Foldable (traverse_)
import Data.Functor (($>))
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Typeable (Typeable)
import Foreign.C.Error
import Numeric.Natural (Natural)
import Text.Printf (printf)
import Data.Monoid.Synchronisation (FirstToFinish (..))
import Data.Wedge
import Network.Mux (SDUSize (..))
import Network.Mux.Bearer.AttenuatedChannel
import Ouroboros.Network.ConnectionId
import Ouroboros.Network.ConnectionManager.Types (AddressType (..))
import Ouroboros.Network.Snocket
import Ouroboros.Network.Testing.Data.Script (Script (..), stepScriptSTM)
data Connection m addr = Connection
{
forall (m :: * -> *) addr. Connection m addr -> AttenuatedChannel m
connChannelLocal :: !(AttenuatedChannel m)
, forall (m :: * -> *) addr. Connection m addr -> AttenuatedChannel m
connChannelRemote :: !(AttenuatedChannel m)
, forall (m :: * -> *) addr. Connection m addr -> SDUSize
connSDUSize :: !SDUSize
, forall (m :: * -> *) addr. Connection m addr -> ConnectionState
connState :: !ConnectionState
, forall (m :: * -> *) addr. Connection m addr -> addr
connProvider :: !addr
}
data ConnectionState
= SYN_SENT
| ESTABLISHED
| 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)
)
=> Tracer m (WithAddr (TestAddress addr)
(SnocketTrace m (TestAddress addr)))
-> BearerInfo
-> ConnectionId (TestAddress addr)
-> STM m (Connection m (TestAddress addr))
mkConnection :: forall (m :: * -> *) addr.
(MonadDelay m, MonadLabelledSTM m, MonadTimer m, MonadThrow m,
MonadThrow (STM m)) =>
Tracer
m (WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr)))
-> BearerInfo
-> ConnectionId (TestAddress addr)
-> STM m (Connection m (TestAddress addr))
mkConnection Tracer
m (WithAddr (TestAddress addr) (SnocketTrace m (TestAddress addr)))
tr BearerInfo
bearerInfo connId :: ConnectionId (TestAddress addr)
connId@ConnectionId { TestAddress addr
localAddress :: TestAddress addr
localAddress :: forall addr. ConnectionId addr -> addr
localAddress, TestAddress addr
remoteAddress :: TestAddress addr
remoteAddress :: forall addr. ConnectionId addr -> 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
}
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)
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
data NetworkState m addr = NetworkState {
forall (m :: * -> *) addr.
NetworkState m addr -> StrictTVar m (Map addr (FD m addr))
nsListeningFDs :: StrictTVar m (Map addr (FD m addr)),
forall (m :: * -> *) addr.
NetworkState m addr
-> StrictTVar m (Map (NormalisedId addr) (Connection m addr))
nsConnections :: StrictTVar
m
(Map (NormalisedId addr) (Connection m addr)),
forall (m :: * -> *) addr.
NetworkState m addr -> AddressType -> STM m addr
nsNextEphemeralAddr :: AddressType -> STM m addr,
forall (m :: * -> *) addr. NetworkState m addr -> BearerInfo
nsDefaultBearerInfo :: BearerInfo,
forall (m :: * -> *) addr.
NetworkState m addr
-> Map (NormalisedId addr) (TVar m (Script BearerInfo))
nsAttenuationMap :: Map (NormalisedId addr)
(LazySTM.TVar m (Script BearerInfo))
}
newtype ObservableNetworkState addr = ObservableNetworkState {
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
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)
data BearerInfo = BearerInfo
{
BearerInfo -> DiffTime
biConnectionDelay :: !DiffTime
, BearerInfo -> Time -> Size -> (DiffTime, SuccessOrFailure)
biInboundAttenuation :: Time -> Size -> ( DiffTime,
SuccessOrFailure )
, BearerInfo -> Time -> Size -> (DiffTime, SuccessOrFailure)
biOutboundAttenuation :: Time -> Size -> ( DiffTime,
SuccessOrFailure )
, BearerInfo -> Maybe Int
biInboundWriteFailure :: !(Maybe Int)
, BearerInfo -> Maybe Int
biOutboundWriteFailure :: !(Maybe Int)
, BearerInfo -> Maybe (DiffTime, IOErrType)
biAcceptFailures :: !(Maybe (DiffTime, IOErrType))
, 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, 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
") "
, SDUSize -> String
forall a. Show a => a -> String
show SDUSize
biSDUSize
]
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, IOErrType)
biAcceptFailures = Maybe (DiffTime, IOErrType)
forall a. Maybe a
Nothing
, biSDUSize :: SDUSize
biSDUSize = Word16 -> SDUSize
SDUSize Word16
12228
}
newNetworkState
:: forall m peerAddr.
( MonadLabelledSTM m
, GlobalAddressScheme peerAddr
)
=> BearerInfo
-> Map (NormalisedId (TestAddress peerAddr))
(Script BearerInfo)
-> 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
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
<$> newTVar Map.empty
<*> newTVar Map.empty
<*> pure nextEphemeralAddr
<*> pure defaultBearerInfo
<*> 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
class GlobalAddressScheme addr where
getAddressType :: TestAddress addr -> AddressType
ephemeralAddress :: AddressType -> Natural -> TestAddress addr
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
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
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)
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)
}
data FD_ m addr
= FDUninitialised
!(Maybe addr)
| FDListening
!addr
!(StrictTBQueue m (ChannelWithInfo m addr))
| FDConnecting !(ConnectionId addr)
!(Connection m addr)
| FDConnected
!(ConnectionId addr)
!(Connection m addr)
| 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
newtype FD m peerAddr = FD { forall (m :: * -> *) peerAddr.
FD m peerAddr -> StrictTVar m (FD_ m peerAddr)
fdVar :: (StrictTVar m (FD_ m peerAddr)) }
makeFDBearer :: forall addr m.
( MonadMonotonicTime m
, MonadSTM m
, MonadThrow m
, Show addr
)
=> MakeBearer m (FD m (TestAddress addr))
makeFDBearer :: forall addr (m :: * -> *).
(MonadMonotonicTime m, MonadSTM m, MonadThrow m, Show addr) =>
MakeBearer m (FD m (TestAddress addr))
makeFDBearer = (DiffTime
-> Tracer m MuxTrace -> FD m (TestAddress addr) -> m (MuxBearer m))
-> MakeBearer m (FD m (TestAddress addr))
forall (m :: * -> *) fd.
(DiffTime -> Tracer m MuxTrace -> fd -> m (MuxBearer m))
-> MakeBearer m fd
MakeBearer ((DiffTime
-> Tracer m MuxTrace -> FD m (TestAddress addr) -> m (MuxBearer m))
-> MakeBearer m (FD m (TestAddress addr)))
-> (DiffTime
-> Tracer m MuxTrace -> FD m (TestAddress addr) -> m (MuxBearer m))
-> MakeBearer m (FD m (TestAddress addr))
forall a b. (a -> b) -> a -> b
$ \DiffTime
sduTimeout Tracer m MuxTrace
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 (MuxBearer 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 (MuxBearer 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 (MuxBearer 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
MuxBearer m -> m (MuxBearer m)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (MuxBearer m -> m (MuxBearer m)) -> MuxBearer m -> m (MuxBearer m)
forall a b. (a -> b) -> a -> b
$ SDUSize
-> DiffTime
-> Tracer m MuxTrace
-> AttenuatedChannel m
-> MuxBearer m
forall (m :: * -> *).
(MonadThrow m, MonadMonotonicTime m) =>
SDUSize
-> DiffTime
-> Tracer m MuxTrace
-> AttenuatedChannel m
-> MuxBearer m
attenuationChannelAsMuxBearer (Connection m (TestAddress addr) -> SDUSize
forall (m :: * -> *) addr. Connection m addr -> SDUSize
connSDUSize Connection m (TestAddress addr)
conn)
DiffTime
sduTimeout Tracer m MuxTrace
muxTracer
(Connection m (TestAddress addr) -> AttenuatedChannel m
forall (m :: * -> *) addr. Connection m addr -> AttenuatedChannel m
connChannelLocal Connection m (TestAddress addr)
conn)
FDClosed {} ->
IOError -> m (MuxBearer m)
forall 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
}
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))
| 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
data OpenType =
SimOpen
| 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
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'
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
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
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_)
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)) =>
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)
return (connId, bearerInfo, NormalOpen)
traceWith tr (WithAddr (Just (localAddress connId))
(Just remoteAddress)
(STBearerInfo bearerInfo))
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`
(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
(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
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))
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_'
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
Right (FD_ m (TestAddress addr)
fd_', OpenType
o) -> do
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
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
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 ->
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
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, IOErrType)
biAcceptFailures (NetworkState m (TestAddress addr) -> BearerInfo
forall (m :: * -> *) addr. NetworkState m addr -> BearerInfo
nsDefaultBearerInfo NetworkState m (TestAddress addr)
state)
return $ accept_ time deltaAndIOErr
where
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, IOErrType)
-> Accept m (FD m (TestAddress addr))
(TestAddress addr)
accept_ :: Time
-> Maybe (DiffTime, IOErrType)
-> Accept m (FD m (TestAddress addr)) (TestAddress addr)
accept_ Time
time Maybe (DiffTime, IOErrType)
deltaAndIOErrType = m (Accepted (FD m (TestAddress addr)) (TestAddress addr),
Accept m (FD m (TestAddress addr)) (TestAddress addr))
-> Accept m (FD m (TestAddress addr)) (TestAddress addr)
forall (m :: * -> *) fd addr.
m (Accepted fd addr, Accept m fd addr) -> Accept m fd addr
Accept (m (Accepted (FD m (TestAddress addr)) (TestAddress addr),
Accept m (FD m (TestAddress addr)) (TestAddress addr))
-> Accept m (FD m (TestAddress addr)) (TestAddress addr))
-> m (Accepted (FD m (TestAddress addr)) (TestAddress addr),
Accept m (FD m (TestAddress addr)) (TestAddress addr))
-> Accept m (FD m (TestAddress addr)) (TestAddress addr)
forall a b. (a -> b) -> a -> b
$ do
ctime <- m Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime
bracketOnError
(atomically $ do
fd <- readTVar fdVar
case fd of
FDUninitialised Maybe (TestAddress addr)
mbAddr ->
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
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 deltaAndIOErrType of
Just (DiffTime
delta, IOErrType
ioErrType) | DiffTime
delta DiffTime -> Time -> Time
`addTime` Time
time Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
>= Time
ctime ->
case IOErrType
ioErrType of
IOErrType
IOErrConnectionAborted ->
Either
(SomeException, Maybe (TestAddress addr),
Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
SockType)
(ChannelWithInfo m (TestAddress addr),
ConnectionId (TestAddress addr))
-> STM
m
(Either
(SomeException, Maybe (TestAddress addr),
Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
SockType)
(ChannelWithInfo m (TestAddress addr),
ConnectionId (TestAddress addr)))
forall 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
connectionAbortedError
, TestAddress addr -> Maybe (TestAddress addr)
forall a. a -> Maybe a
Just TestAddress addr
localAddress
, (ConnectionId (TestAddress addr), AttenuatedChannel m)
-> Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m)
forall a. a -> Maybe a
Just (ConnectionId (TestAddress addr)
connId, ChannelWithInfo m (TestAddress addr) -> AttenuatedChannel m
forall (m :: * -> *) addr.
ChannelWithInfo m addr -> AttenuatedChannel m
cwiChannelLocal ChannelWithInfo m (TestAddress addr)
cwi)
, FD_ m (TestAddress addr) -> SockType
forall (m :: * -> *) addr. FD_ m addr -> SockType
mkSockType FD_ m (TestAddress addr)
fd
)
IOErrType
IOErrResourceExhausted ->
Either
(SomeException, Maybe (TestAddress addr),
Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
SockType)
(ChannelWithInfo m (TestAddress addr),
ConnectionId (TestAddress addr))
-> STM
m
(Either
(SomeException, Maybe (TestAddress addr),
Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
SockType)
(ChannelWithInfo m (TestAddress addr),
ConnectionId (TestAddress addr)))
forall 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
resourceExhaustedError FD_ m (TestAddress addr)
fd
, TestAddress addr -> Maybe (TestAddress addr)
forall a. a -> Maybe a
Just TestAddress addr
localAddress
, (ConnectionId (TestAddress addr), AttenuatedChannel m)
-> Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m)
forall a. a -> Maybe a
Just (ConnectionId (TestAddress addr)
connId, ChannelWithInfo m (TestAddress addr) -> AttenuatedChannel m
forall (m :: * -> *) addr.
ChannelWithInfo m addr -> AttenuatedChannel m
cwiChannelLocal ChannelWithInfo m (TestAddress addr)
cwi)
, FD_ m (TestAddress addr) -> SockType
forall (m :: * -> *) addr. FD_ m addr -> SockType
mkSockType FD_ m (TestAddress addr)
fd
)
Maybe (DiffTime, IOErrType)
_ -> Either
(SomeException, Maybe (TestAddress addr),
Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
SockType)
(ChannelWithInfo m (TestAddress addr),
ConnectionId (TestAddress addr))
-> STM
m
(Either
(SomeException, Maybe (TestAddress addr),
Maybe (ConnectionId (TestAddress addr), AttenuatedChannel m),
SockType)
(ChannelWithInfo m (TestAddress addr),
ConnectionId (TestAddress addr)))
forall 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, IOErrType)
-> Accept m (FD m (TestAddress addr)) (TestAddress addr)
accept_ Time
time Maybe (DiffTime, IOErrType)
deltaAndIOErrType)
Right (ChannelWithInfo m (TestAddress addr)
chann, connId :: ConnectionId (TestAddress addr)
connId@ConnectionId { TestAddress addr
localAddress :: 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 deltaAndIOErrType)
invalidError :: FD_ m (TestAddress addr) -> IOError
invalidError :: FD_ m (TestAddress addr) -> IOError
invalidError FD_ m (TestAddress addr)
fd = IOError
{ ioe_handle :: Maybe Handle
ioe_handle = Maybe Handle
forall a. Maybe a
Nothing
, ioe_type :: IOErrorType
ioe_type = IOErrorType
InvalidArgument
, ioe_location :: String
ioe_location = String
"Ouroboros.Network.Snocket.Sim.accept"
, ioe_description :: String
ioe_description = String -> ShowS
forall r. PrintfType r => String -> r
printf String
"Invalid argument (%s)" (FD_ m (TestAddress addr) -> String
forall a. Show a => a -> String
show FD_ m (TestAddress addr)
fd)
, ioe_errno :: Maybe CInt
ioe_errno = Maybe CInt
forall a. Maybe a
Nothing
, ioe_filename :: Maybe String
ioe_filename = Maybe String
forall a. Maybe a
Nothing
}
connectionAbortedError :: IOError
connectionAbortedError :: IOError
connectionAbortedError = IOError
{ ioe_handle :: Maybe Handle
ioe_handle = Maybe Handle
forall a. Maybe a
Nothing
, ioe_type :: IOErrorType
ioe_type = IOErrorType
OtherError
, ioe_location :: String
ioe_location = String
"Ouroboros.Network.Snocket.Sim.accept"
, ioe_description :: String
ioe_description = String
"Software caused connection abort (WSAECONNABORTED)"
, ioe_errno :: Maybe CInt
ioe_errno = CInt -> Maybe CInt
forall a. a -> Maybe a
Just (case Errno
eCONNABORTED of Errno CInt
errno -> CInt
errno)
, ioe_filename :: Maybe String
ioe_filename = Maybe String
forall a. Maybe a
Nothing
}
resourceExhaustedError :: FD_ m (TestAddress addr) -> IOError
resourceExhaustedError :: FD_ m (TestAddress addr) -> IOError
resourceExhaustedError FD_ m (TestAddress addr)
fd = IOError
{ ioe_handle :: Maybe Handle
ioe_handle = Maybe Handle
forall a. Maybe a
Nothing
, ioe_type :: IOErrorType
ioe_type = IOErrorType
ResourceExhausted
, ioe_location :: String
ioe_location = String
"Ouroboros.Network.Snocket.Sim.accept"
, ioe_description :: String
ioe_description = String -> ShowS
forall r. PrintfType r => String -> r
printf String
"Resource exhausted (%s)" (FD_ m (TestAddress addr) -> String
forall a. Show a => a -> String
show FD_ m (TestAddress addr)
fd)
, ioe_errno :: Maybe CInt
ioe_errno = Maybe CInt
forall a. Maybe a
Nothing
, ioe_filename :: Maybe String
ioe_filename = Maybe String
forall a. Maybe a
Nothing
}
close :: FD m (TestAddress addr)
-> m ()
close :: FD m (TestAddress addr) -> m ()
close FD { StrictTVar m (FD_ m (TestAddress addr))
fdVar :: 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
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
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
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
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
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
readTBQueueUntil :: MonadSTM m
=> (a -> STM m Bool)
-> StrictTBQueue m a
-> 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