{-# LANGUAGE NamedFieldPuns  #-}
{-# LANGUAGE RecordWildCards #-}

module Network.Mux.DeltaQ.TraceTransformer
  ( initDeltaQTracer
  , initDeltaQTracer'
  , initDeltaQTracers
  ) where

import Control.Concurrent.Class.MonadSTM.Strict
import Control.Tracer
import Data.Functor.Contravariant ((>$<))
import Data.Functor.Identity

import Network.Mux.DeltaQ.TraceStats
import Network.Mux.Trace
import Network.Mux.Types


-- | Create a trace transformer that will emit
--   `MuxTraceRecvDeltaQSample` no more frequently than every 10
--   seconds (when in use).
initDeltaQTracer :: MonadSTM m
                 => m (Tracer m BearerTrace -> Tracer m BearerTrace)
initDeltaQTracer :: forall (m :: * -> *).
MonadSTM m =>
m (Tracer m BearerTrace -> Tracer m BearerTrace)
initDeltaQTracer = StatsA -> m (StrictTVar m StatsA)
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
newTVarIO StatsA
initialStatsA m (StrictTVar m StatsA)
-> (StrictTVar m StatsA
    -> m (Tracer m BearerTrace -> Tracer m BearerTrace))
-> m (Tracer m BearerTrace -> Tracer m BearerTrace)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Tracer m BearerTrace -> Tracer m BearerTrace)
-> m (Tracer m BearerTrace -> Tracer m BearerTrace)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Tracer m BearerTrace -> Tracer m BearerTrace)
 -> m (Tracer m BearerTrace -> Tracer m BearerTrace))
-> (StrictTVar m StatsA
    -> Tracer m BearerTrace -> Tracer m BearerTrace)
-> StrictTVar m StatsA
-> m (Tracer m BearerTrace -> Tracer m BearerTrace)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrictTVar m StatsA -> Tracer m BearerTrace -> Tracer m BearerTrace
forall (m :: * -> *).
MonadSTM m =>
StrictTVar m StatsA -> Tracer m BearerTrace -> Tracer m BearerTrace
dqTracer

initDeltaQTracer' :: MonadSTM m
                  => Tracer m BearerTrace
                  -> m (Tracer m BearerTrace)
initDeltaQTracer' :: forall (m :: * -> *).
MonadSTM m =>
Tracer m BearerTrace -> m (Tracer m BearerTrace)
initDeltaQTracer' Tracer m BearerTrace
tr = do
    v <- StatsA -> m (StrictTVar m StatsA)
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
newTVarIO StatsA
initialStatsA
    return $ dqTracer v tr

dqTracer :: MonadSTM m
         => StrictTVar m StatsA
         -> Tracer m BearerTrace
         -> Tracer m BearerTrace
dqTracer :: forall (m :: * -> *).
MonadSTM m =>
StrictTVar m StatsA -> Tracer m BearerTrace -> Tracer m BearerTrace
dqTracer StrictTVar m StatsA
sTvar Tracer m BearerTrace
tr = (BearerTrace -> m ()) -> Tracer m BearerTrace
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer BearerTrace -> m ()
go
  where
    go :: BearerTrace -> m ()
go (TraceRecvDeltaQObservation SDUHeader { RemoteClockModel
mhTimestamp :: RemoteClockModel
mhTimestamp :: SDUHeader -> RemoteClockModel
mhTimestamp, Word16
mhLength :: Word16
mhLength :: SDUHeader -> Word16
mhLength } Time
t)
      = RemoteClockModel -> Time -> Int -> m (Maybe OneWayDeltaQSample)
update RemoteClockModel
mhTimestamp Time
t (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
mhLength)
        m (Maybe OneWayDeltaQSample)
-> (Maybe OneWayDeltaQSample -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m ()
-> (OneWayDeltaQSample -> m ()) -> Maybe OneWayDeltaQSample -> m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (Tracer m BearerTrace -> BearerTrace -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m BearerTrace
tr (BearerTrace -> m ())
-> (OneWayDeltaQSample -> BearerTrace)
-> OneWayDeltaQSample
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OneWayDeltaQSample -> BearerTrace
formatSample)
    go te :: BearerTrace
te@BearerTrace
TraceEmitDeltaQ
      = m ()
emitSample m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Tracer m BearerTrace -> BearerTrace -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m BearerTrace
tr BearerTrace
te
    go BearerTrace
x
      = Tracer m BearerTrace -> BearerTrace -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m BearerTrace
tr BearerTrace
x

    update :: RemoteClockModel -> Time -> Int -> m (Maybe OneWayDeltaQSample)
update RemoteClockModel
rClock Time
lClock Int
n
      = STM m (Maybe OneWayDeltaQSample) -> m (Maybe OneWayDeltaQSample)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (StrictTVar m StatsA
-> (StatsA -> (Maybe OneWayDeltaQSample, StatsA))
-> STM m (Maybe OneWayDeltaQSample)
forall (m :: * -> *) s a.
MonadSTM m =>
StrictTVar m s -> (s -> (a, s)) -> STM m a
stateTVar StrictTVar m StatsA
sTvar (RemoteClockModel
-> Time -> Int -> StatsA -> (Maybe OneWayDeltaQSample, StatsA)
step RemoteClockModel
rClock Time
lClock Int
n))

    emitSample :: m ()
emitSample
      =  STM m OneWayDeltaQSample -> m OneWayDeltaQSample
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (StrictTVar m StatsA
-> (StatsA -> (OneWayDeltaQSample, StatsA))
-> STM m OneWayDeltaQSample
forall (m :: * -> *) s a.
MonadSTM m =>
StrictTVar m s -> (s -> (a, s)) -> STM m a
stateTVar StrictTVar m StatsA
sTvar StatsA -> (OneWayDeltaQSample, StatsA)
processSample)
         m OneWayDeltaQSample -> (OneWayDeltaQSample -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Tracer m BearerTrace -> BearerTrace -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m BearerTrace
tr (BearerTrace -> m ())
-> (OneWayDeltaQSample -> BearerTrace)
-> OneWayDeltaQSample
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OneWayDeltaQSample -> BearerTrace
formatSample

    processSample :: StatsA -> (OneWayDeltaQSample, StatsA)
processSample StatsA
s
      = (StatsA -> OneWayDeltaQSample
constructSample StatsA
s, StatsA
initialStatsA)

    formatSample :: OneWayDeltaQSample -> BearerTrace
formatSample (OneWaySample {Double
Int
String
duration :: Double
sumPackets :: Int
sumTotalSDU :: Int
estDeltaQS :: Double
estDeltaQVMean :: Double
estDeltaQVVar :: Double
estR :: Double
sizeDist :: String
duration :: OneWayDeltaQSample -> Double
estDeltaQS :: OneWayDeltaQSample -> Double
estDeltaQVMean :: OneWayDeltaQSample -> Double
estDeltaQVVar :: OneWayDeltaQSample -> Double
estR :: OneWayDeltaQSample -> Double
sizeDist :: OneWayDeltaQSample -> String
sumPackets :: OneWayDeltaQSample -> Int
sumTotalSDU :: OneWayDeltaQSample -> Int
..})
      = Double
-> Int
-> Int
-> Double
-> Double
-> Double
-> Double
-> String
-> BearerTrace
TraceRecvDeltaQSample Double
duration Int
sumPackets Int
sumTotalSDU
                              Double
estDeltaQS Double
estDeltaQVMean Double
estDeltaQVVar
                              Double
estR String
sizeDist


initDeltaQTracers :: MonadSTM m
                  => Tracers m
                  -> m (Tracers m)
initDeltaQTracers :: forall (m :: * -> *). MonadSTM m => Tracers m -> m (Tracers m)
initDeltaQTracers Tracers m
tracers = do
    bearerTracer' <- Tracer m BearerTrace -> m (Tracer m BearerTrace)
forall (m :: * -> *).
MonadSTM m =>
Tracer m BearerTrace -> m (Tracer m BearerTrace)
initDeltaQTracer' (BearerTrace -> Identity BearerTrace
forall a. a -> Identity a
Identity (BearerTrace -> Identity BearerTrace)
-> Tracer m (Identity BearerTrace) -> Tracer m BearerTrace
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
>$< Tracers m -> Tracer m (Identity BearerTrace)
forall (m :: * -> *) (f :: * -> *).
Tracers' m f -> Tracer m (f BearerTrace)
bearerTracer Tracers m
tracers)
    return $ tracers { bearerTracer = runIdentity >$< bearerTracer' }