{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
module Network.Mux.Egress
( muxer
, EgressQueue
, TranslocationServiceRequest (..)
, Wanton (..)
) where
import Control.Monad
import Data.ByteString.Lazy qualified as BL
import Control.Concurrent.Class.MonadSTM.Strict
import Control.Monad.Class.MonadAsync
import Control.Monad.Class.MonadThrow
import Control.Monad.Class.MonadTimer.SI hiding (timeout)
import Network.Mux.Timeout
import Network.Mux.Types
type EgressQueue m = StrictTBQueue m (TranslocationServiceRequest m)
data TranslocationServiceRequest m =
TLSRDemand !MiniProtocolNum !MiniProtocolDir !(Wanton m)
newtype Wanton m = Wanton { forall (m :: * -> *). Wanton m -> StrictTVar m ByteString
want :: StrictTVar m BL.ByteString }
muxer
:: ( MonadAsync m
, MonadFork m
, MonadMask m
, MonadThrow (STM m)
, MonadTimer m
)
=> EgressQueue m
-> MuxBearer m
-> m void
muxer :: forall (m :: * -> *) void.
(MonadAsync m, MonadFork m, MonadMask m, MonadThrow (STM m),
MonadTimer m) =>
EgressQueue m -> MuxBearer m -> m void
muxer EgressQueue m
egressQueue MuxBearer m
bearer =
(TimeoutFn m -> m void) -> m void
forall (m :: * -> *) b.
(MonadAsync m, MonadFork m, MonadMonotonicTime m, MonadTimer m,
MonadMask m, MonadThrow (STM m)) =>
(TimeoutFn m -> m b) -> m b
withTimeoutSerial ((TimeoutFn m -> m void) -> m void)
-> (TimeoutFn m -> m void) -> m void
forall a b. (a -> b) -> a -> b
$ \TimeoutFn m
timeout ->
m () -> m void
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (m () -> m void) -> m () -> m void
forall a b. (a -> b) -> a -> b
$ do
TLSRDemand mpc md d <- STM m (TranslocationServiceRequest m)
-> m (TranslocationServiceRequest m)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (TranslocationServiceRequest m)
-> m (TranslocationServiceRequest m))
-> STM m (TranslocationServiceRequest m)
-> m (TranslocationServiceRequest m)
forall a b. (a -> b) -> a -> b
$ EgressQueue m -> STM m (TranslocationServiceRequest m)
forall (m :: * -> *) a. MonadSTM m => StrictTBQueue m a -> STM m a
readTBQueue EgressQueue m
egressQueue
processSingleWanton egressQueue bearer timeout mpc md d
processSingleWanton :: MonadSTM m
=> EgressQueue m
-> MuxBearer m
-> TimeoutFn m
-> MiniProtocolNum
-> MiniProtocolDir
-> Wanton m
-> m ()
processSingleWanton :: forall (m :: * -> *).
MonadSTM m =>
EgressQueue m
-> MuxBearer m
-> TimeoutFn m
-> MiniProtocolNum
-> MiniProtocolDir
-> Wanton m
-> m ()
processSingleWanton EgressQueue m
egressQueue MuxBearer { TimeoutFn m -> MuxSDU -> m Time
write :: TimeoutFn m -> MuxSDU -> m Time
write :: forall (m :: * -> *).
MuxBearer m -> TimeoutFn m -> MuxSDU -> m Time
write, SDUSize
sduSize :: SDUSize
sduSize :: forall (m :: * -> *). MuxBearer m -> SDUSize
sduSize }
TimeoutFn m
timeout MiniProtocolNum
mpc MiniProtocolDir
md Wanton m
wanton = do
blob <- STM m ByteString -> m ByteString
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m ByteString -> m ByteString)
-> STM m ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ do
d <- StrictTVar m ByteString -> STM m ByteString
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (Wanton m -> StrictTVar m ByteString
forall (m :: * -> *). Wanton m -> StrictTVar m ByteString
want Wanton m
wanton)
let (frag, rest) = BL.splitAt (fromIntegral (getSDUSize sduSize)) d
if BL.null rest
then writeTVar (want wanton) BL.empty
else do
writeTVar (want wanton) rest
writeTBQueue egressQueue (TLSRDemand mpc md wanton)
pure frag
let sdu = MuxSDU {
msHeader :: MuxSDUHeader
msHeader = MuxSDUHeader {
mhTimestamp :: RemoteClockModel
mhTimestamp = (Word32 -> RemoteClockModel
RemoteClockModel Word32
0),
mhNum :: MiniProtocolNum
mhNum = MiniProtocolNum
mpc,
mhDir :: MiniProtocolDir
mhDir = MiniProtocolDir
md,
mhLength :: Word16
mhLength = Int64 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Word16) -> Int64 -> Word16
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
BL.length ByteString
blob
},
msBlob :: ByteString
msBlob = ByteString
blob
}
void $ write timeout sdu