-- | Tests of the effect hand-off in front of the network.
--
-- Run under io-sim so the time-based assertions are exact rather than racing a
-- wall clock.
module Hydra.Node.OutboxSpec where

import Hydra.Prelude
import Test.Hydra.Prelude

import Control.Concurrent.Class.MonadSTM (modifyTVar', newTVarIO, readTVarIO, takeTMVar)
import Hydra.Network (StallReason (..))
import Hydra.Node.Outbox (Outbox (..), StallBounds (..), newOutbox)
import Test.Util (shouldRunInSim)

bounds :: StallBounds
bounds :: StallBounds
bounds = StallBounds{$sel:noProgressFor:StallBounds :: DiffTime
noProgressFor = DiffTime
10, $sel:maxPending:StallBounds :: Natural
maxPending = Natural
100}

spec :: Spec
spec :: Spec
spec = do
  String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"never blocks the producer, whatever the bounds and with no consumer" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
    -- The whole point: this is called from the node's only input-processing
    -- thread, so it may not wait on anything.
    Int
submitted <- (forall s. IOSim s Int) -> IO Int
forall a. (forall s. IOSim s a) -> IO a
shouldRunInSim ((forall s. IOSim s Int) -> IO Int)
-> (forall s. IOSim s Int) -> IO Int
forall a b. (a -> b) -> a -> b
$ do
      Outbox{IOSim s () -> IOSim s ()
submit :: IOSim s () -> IOSim s ()
$sel:submit:Outbox :: forall (m :: * -> *). Outbox m -> m () -> m ()
submit} <- StallBounds -> String -> IOSim s (Outbox (IOSim s))
forall (m :: * -> *).
(MonadLabelledSTM m, MonadMonotonicTime m) =>
StallBounds -> String -> m (Outbox m)
newOutbox StallBounds
bounds{maxPending = 3} String
"outbox-spec"
      [Int] -> (Int -> IOSim s ()) -> IOSim s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
1 .. Int
500 :: Int] ((Int -> IOSim s ()) -> IOSim s ())
-> (Int -> IOSim s ()) -> IOSim s ()
forall a b. (a -> b) -> a -> b
$ \Int
_ -> IOSim s () -> IOSim s ()
submit (() -> IOSim s ()
forall a. a -> IOSim s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
      Int -> IOSim s Int
forall a. a -> IOSim s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
500 :: Int)
    Int
submitted Int -> Int -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Int
500

  String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"performs everything submitted, once each, in submission order" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
    [Int]
performed <- (forall s. IOSim s [Int]) -> IO [Int]
forall a. (forall s. IOSim s a) -> IO a
shouldRunInSim ((forall s. IOSim s [Int]) -> IO [Int])
-> (forall s. IOSim s [Int]) -> IO [Int]
forall a b. (a -> b) -> a -> b
$ do
      TVar s [Int]
done <- [Int] -> IOSim s (TVar (IOSim s) [Int])
forall a. a -> IOSim s (TVar (IOSim s) a)
forall (m :: * -> *) a. MonadSTM m => a -> m (TVar m a)
newTVarIO []
      Outbox{IOSim s () -> IOSim s ()
$sel:submit:Outbox :: forall (m :: * -> *). Outbox m -> m () -> m ()
submit :: IOSim s () -> IOSim s ()
submit, IOSim s ()
drainOutbox :: IOSim s ()
$sel:drainOutbox:Outbox :: forall (m :: * -> *). Outbox m -> m ()
drainOutbox} <- StallBounds -> String -> IOSim s (Outbox (IOSim s))
forall (m :: * -> *).
(MonadLabelledSTM m, MonadMonotonicTime m) =>
StallBounds -> String -> m (Outbox m)
newOutbox StallBounds
bounds String
"outbox-spec"
      [Int] -> (Int -> IOSim s ()) -> IOSim s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
1 .. Int
10 :: Int] ((Int -> IOSim s ()) -> IOSim s ())
-> (Int -> IOSim s ()) -> IOSim s ()
forall a b. (a -> b) -> a -> b
$ \Int
i -> IOSim s () -> IOSim s ()
submit (STM (IOSim s) () -> IOSim s ()
forall a. HasCallStack => STM (IOSim s) a -> IOSim s a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM (IOSim s) () -> IOSim s ()) -> STM (IOSim s) () -> IOSim s ()
forall a b. (a -> b) -> a -> b
$ TVar (IOSim s) [Int] -> ([Int] -> [Int]) -> STM (IOSim s) ()
forall a. TVar (IOSim s) a -> (a -> a) -> STM (IOSim s) ()
forall (m :: * -> *) a.
MonadSTM m =>
TVar m a -> (a -> a) -> STM m ()
modifyTVar' TVar (IOSim s) [Int]
TVar s [Int]
done ([Int] -> [Int] -> [Int]
forall a. Semigroup a => a -> a -> a
<> [Int
i]))
      IOSim s ()
drainOutbox
      TVar (IOSim s) [Int] -> IOSim s [Int]
forall a. TVar (IOSim s) a -> IOSim s a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> m a
readTVarIO TVar (IOSim s) [Int]
TVar s [Int]
done
    [Int]
performed [Int] -> [Int] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` [Int
1 .. Int
10 :: Int]

  String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"reports no stall while nothing is pending" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
    Maybe (StallReason, Natural)
stalled <- (forall s. IOSim s (Maybe (StallReason, Natural)))
-> IO (Maybe (StallReason, Natural))
forall a. (forall s. IOSim s a) -> IO a
shouldRunInSim ((forall s. IOSim s (Maybe (StallReason, Natural)))
 -> IO (Maybe (StallReason, Natural)))
-> (forall s. IOSim s (Maybe (StallReason, Natural)))
-> IO (Maybe (StallReason, Natural))
forall a b. (a -> b) -> a -> b
$ do
      Outbox{IOSim s (Maybe (StallReason, Natural))
outboxStalled :: IOSim s (Maybe (StallReason, Natural))
$sel:outboxStalled:Outbox :: forall (m :: * -> *). Outbox m -> m (Maybe (StallReason, Natural))
outboxStalled} <- StallBounds -> String -> IOSim s (Outbox (IOSim s))
forall (m :: * -> *).
(MonadLabelledSTM m, MonadMonotonicTime m) =>
StallBounds -> String -> m (Outbox m)
newOutbox StallBounds
bounds String
"outbox-spec"
      DiffTime -> IOSim s ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
60
      IOSim s (Maybe (StallReason, Natural))
outboxStalled
    Maybe (StallReason, Natural)
stalled Maybe (StallReason, Natural)
-> Maybe (StallReason, Natural) -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Maybe (StallReason, Natural)
forall a. Maybe a
Nothing

  String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"reports a stall once nothing has completed for the stall period" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
    (Maybe (StallReason, Natural)
early, Maybe (StallReason, Natural)
late) <- (forall s.
 IOSim
   s (Maybe (StallReason, Natural), Maybe (StallReason, Natural)))
-> IO (Maybe (StallReason, Natural), Maybe (StallReason, Natural))
forall a. (forall s. IOSim s a) -> IO a
shouldRunInSim ((forall s.
  IOSim
    s (Maybe (StallReason, Natural), Maybe (StallReason, Natural)))
 -> IO (Maybe (StallReason, Natural), Maybe (StallReason, Natural)))
-> (forall s.
    IOSim
      s (Maybe (StallReason, Natural), Maybe (StallReason, Natural)))
-> IO (Maybe (StallReason, Natural), Maybe (StallReason, Natural))
forall a b. (a -> b) -> a -> b
$
      StallBounds
-> (Outbox (IOSim s)
    -> IOSim
         s (Maybe (StallReason, Natural), Maybe (StallReason, Natural)))
-> IOSim
     s (Maybe (StallReason, Natural), Maybe (StallReason, Natural))
forall (m :: * -> *) a.
(MonadAsync m, MonadLabelledSTM m, MonadMonotonicTime m) =>
StallBounds -> (Outbox m -> m a) -> m a
withStuckOutbox StallBounds
bounds ((Outbox (IOSim s)
  -> IOSim
       s (Maybe (StallReason, Natural), Maybe (StallReason, Natural)))
 -> IOSim
      s (Maybe (StallReason, Natural), Maybe (StallReason, Natural)))
-> (Outbox (IOSim s)
    -> IOSim
         s (Maybe (StallReason, Natural), Maybe (StallReason, Natural)))
-> IOSim
     s (Maybe (StallReason, Natural), Maybe (StallReason, Natural))
forall a b. (a -> b) -> a -> b
$ \Outbox{IOSim s (Maybe (StallReason, Natural))
$sel:outboxStalled:Outbox :: forall (m :: * -> *). Outbox m -> m (Maybe (StallReason, Natural))
outboxStalled :: IOSim s (Maybe (StallReason, Natural))
outboxStalled} -> do
        DiffTime -> IOSim s ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
5
        Maybe (StallReason, Natural)
early <- IOSim s (Maybe (StallReason, Natural))
outboxStalled
        DiffTime -> IOSim s ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
10
        Maybe (StallReason, Natural)
late <- IOSim s (Maybe (StallReason, Natural))
outboxStalled
        (Maybe (StallReason, Natural), Maybe (StallReason, Natural))
-> IOSim
     s (Maybe (StallReason, Natural), Maybe (StallReason, Natural))
forall a. a -> IOSim s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (StallReason, Natural)
early, Maybe (StallReason, Natural)
late)
    Maybe (StallReason, Natural)
early Maybe (StallReason, Natural)
-> Maybe (StallReason, Natural) -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Maybe (StallReason, Natural)
forall a. Maybe a
Nothing
    Maybe (StallReason, Natural)
late Maybe (StallReason, Natural)
-> Maybe (StallReason, Natural) -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` (StallReason, Natural) -> Maybe (StallReason, Natural)
forall a. a -> Maybe a
Just (StallReason
NoProgress, Natural
1)

  String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"does not report a stall on the first submission after a long idle period" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
    -- Regression test: measuring "how long has the queue been non-empty"
    -- rather than "how long since it last made progress" reports a stall the
    -- moment an idle node submits anything.
    Maybe (StallReason, Natural)
stalled <- (forall s. IOSim s (Maybe (StallReason, Natural)))
-> IO (Maybe (StallReason, Natural))
forall a. (forall s. IOSim s a) -> IO a
shouldRunInSim ((forall s. IOSim s (Maybe (StallReason, Natural)))
 -> IO (Maybe (StallReason, Natural)))
-> (forall s. IOSim s (Maybe (StallReason, Natural)))
-> IO (Maybe (StallReason, Natural))
forall a b. (a -> b) -> a -> b
$ do
      Outbox{IOSim s () -> IOSim s ()
$sel:submit:Outbox :: forall (m :: * -> *). Outbox m -> m () -> m ()
submit :: IOSim s () -> IOSim s ()
submit, IOSim s (Maybe (StallReason, Natural))
$sel:outboxStalled:Outbox :: forall (m :: * -> *). Outbox m -> m (Maybe (StallReason, Natural))
outboxStalled :: IOSim s (Maybe (StallReason, Natural))
outboxStalled, IOSim s ()
runOutbox :: IOSim s ()
$sel:runOutbox:Outbox :: forall (m :: * -> *). Outbox m -> m ()
runOutbox} <- StallBounds -> String -> IOSim s (Outbox (IOSim s))
forall (m :: * -> *).
(MonadLabelledSTM m, MonadMonotonicTime m) =>
StallBounds -> String -> m (Outbox m)
newOutbox StallBounds
bounds String
"outbox-spec"
      (String, IOSim s ())
-> (Async (IOSim s) () -> IOSim s (Maybe (StallReason, Natural)))
-> IOSim s (Maybe (StallReason, Natural))
forall (m :: * -> *) a b.
MonadAsync m =>
(String, m a) -> (Async m a -> m b) -> m b
withAsyncLabelled (String
"outbox-spec-run", IOSim s ()
runOutbox) ((Async (IOSim s) () -> IOSim s (Maybe (StallReason, Natural)))
 -> IOSim s (Maybe (StallReason, Natural)))
-> (Async (IOSim s) () -> IOSim s (Maybe (StallReason, Natural)))
-> IOSim s (Maybe (StallReason, Natural))
forall a b. (a -> b) -> a -> b
$ \Async (IOSim s) ()
_ -> do
        DiffTime -> IOSim s ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
60
        TMVarDefault (IOSim s) ()
blocked <- String -> IOSim s (TMVar (IOSim s) ())
forall (m :: * -> *) a.
MonadLabelledSTM m =>
String -> m (TMVar m a)
newLabelledEmptyTMVarIO String
"outbox-spec-blocked"
        IOSim s () -> IOSim s ()
submit (STM (IOSim s) () -> IOSim s ()
forall a. HasCallStack => STM (IOSim s) a -> IOSim s a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM (IOSim s) () -> IOSim s ()) -> STM (IOSim s) () -> IOSim s ()
forall a b. (a -> b) -> a -> b
$ TMVar (IOSim s) () -> STM (IOSim s) ()
forall a. TMVar (IOSim s) a -> STM (IOSim s) a
forall (m :: * -> *) a. MonadSTM m => TMVar m a -> STM m a
takeTMVar TMVar (IOSim s) ()
TMVarDefault (IOSim s) ()
blocked)
        IOSim s (Maybe (StallReason, Natural))
outboxStalled
    Maybe (StallReason, Natural)
stalled Maybe (StallReason, Natural)
-> Maybe (StallReason, Natural) -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Maybe (StallReason, Natural)
forall a. Maybe a
Nothing

  String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"does not report a stall while the consumer keeps up" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
    Maybe (StallReason, Natural)
stalled <- (forall s. IOSim s (Maybe (StallReason, Natural)))
-> IO (Maybe (StallReason, Natural))
forall a. (forall s. IOSim s a) -> IO a
shouldRunInSim ((forall s. IOSim s (Maybe (StallReason, Natural)))
 -> IO (Maybe (StallReason, Natural)))
-> (forall s. IOSim s (Maybe (StallReason, Natural)))
-> IO (Maybe (StallReason, Natural))
forall a b. (a -> b) -> a -> b
$ do
      Outbox{IOSim s () -> IOSim s ()
$sel:submit:Outbox :: forall (m :: * -> *). Outbox m -> m () -> m ()
submit :: IOSim s () -> IOSim s ()
submit, IOSim s (Maybe (StallReason, Natural))
$sel:outboxStalled:Outbox :: forall (m :: * -> *). Outbox m -> m (Maybe (StallReason, Natural))
outboxStalled :: IOSim s (Maybe (StallReason, Natural))
outboxStalled, IOSim s ()
$sel:runOutbox:Outbox :: forall (m :: * -> *). Outbox m -> m ()
runOutbox :: IOSim s ()
runOutbox} <- StallBounds -> String -> IOSim s (Outbox (IOSim s))
forall (m :: * -> *).
(MonadLabelledSTM m, MonadMonotonicTime m) =>
StallBounds -> String -> m (Outbox m)
newOutbox StallBounds
bounds String
"outbox-spec"
      (String, IOSim s ())
-> (Async (IOSim s) () -> IOSim s (Maybe (StallReason, Natural)))
-> IOSim s (Maybe (StallReason, Natural))
forall (m :: * -> *) a b.
MonadAsync m =>
(String, m a) -> (Async m a -> m b) -> m b
withAsyncLabelled (String
"outbox-spec-run", IOSim s ()
runOutbox) ((Async (IOSim s) () -> IOSim s (Maybe (StallReason, Natural)))
 -> IOSim s (Maybe (StallReason, Natural)))
-> (Async (IOSim s) () -> IOSim s (Maybe (StallReason, Natural)))
-> IOSim s (Maybe (StallReason, Natural))
forall a b. (a -> b) -> a -> b
$ \Async (IOSim s) ()
_ -> do
        [Int] -> (Int -> IOSim s ()) -> IOSim s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
1 .. Int
5 :: Int] ((Int -> IOSim s ()) -> IOSim s ())
-> (Int -> IOSim s ()) -> IOSim s ()
forall a b. (a -> b) -> a -> b
$ \Int
_ -> do
          IOSim s () -> IOSim s ()
submit (() -> IOSim s ()
forall a. a -> IOSim s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
          DiffTime -> IOSim s ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
8
        IOSim s (Maybe (StallReason, Natural))
outboxStalled
    Maybe (StallReason, Natural)
stalled Maybe (StallReason, Natural)
-> Maybe (StallReason, Natural) -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Maybe (StallReason, Natural)
forall a. Maybe a
Nothing

  String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"reports a stall even while the producer keeps submitting" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
    -- Regression test: resetting the progress clock on every submission rather
    -- than only on submission into an empty queue would let a busy producer
    -- mask a consumer that is not moving at all.
    Maybe (StallReason, Natural)
stalled <- (forall s. IOSim s (Maybe (StallReason, Natural)))
-> IO (Maybe (StallReason, Natural))
forall a. (forall s. IOSim s a) -> IO a
shouldRunInSim ((forall s. IOSim s (Maybe (StallReason, Natural)))
 -> IO (Maybe (StallReason, Natural)))
-> (forall s. IOSim s (Maybe (StallReason, Natural)))
-> IO (Maybe (StallReason, Natural))
forall a b. (a -> b) -> a -> b
$
      StallBounds
-> (Outbox (IOSim s) -> IOSim s (Maybe (StallReason, Natural)))
-> IOSim s (Maybe (StallReason, Natural))
forall (m :: * -> *) a.
(MonadAsync m, MonadLabelledSTM m, MonadMonotonicTime m) =>
StallBounds -> (Outbox m -> m a) -> m a
withStuckOutbox StallBounds
bounds ((Outbox (IOSim s) -> IOSim s (Maybe (StallReason, Natural)))
 -> IOSim s (Maybe (StallReason, Natural)))
-> (Outbox (IOSim s) -> IOSim s (Maybe (StallReason, Natural)))
-> IOSim s (Maybe (StallReason, Natural))
forall a b. (a -> b) -> a -> b
$ \Outbox{IOSim s () -> IOSim s ()
$sel:submit:Outbox :: forall (m :: * -> *). Outbox m -> m () -> m ()
submit :: IOSim s () -> IOSim s ()
submit, IOSim s (Maybe (StallReason, Natural))
$sel:outboxStalled:Outbox :: forall (m :: * -> *). Outbox m -> m (Maybe (StallReason, Natural))
outboxStalled :: IOSim s (Maybe (StallReason, Natural))
outboxStalled} -> do
        [Int] -> (Int -> IOSim s ()) -> IOSim s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
1 .. Int
5 :: Int] ((Int -> IOSim s ()) -> IOSim s ())
-> (Int -> IOSim s ()) -> IOSim s ()
forall a b. (a -> b) -> a -> b
$ \Int
_ -> do
          IOSim s () -> IOSim s ()
submit (() -> IOSim s ()
forall a. a -> IOSim s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
          DiffTime -> IOSim s ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
4
        IOSim s (Maybe (StallReason, Natural))
outboxStalled
    Maybe (StallReason, Natural)
stalled Maybe (StallReason, Natural)
-> Maybe (StallReason, Natural) -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` (StallReason, Natural) -> Maybe (StallReason, Natural)
forall a. a -> Maybe a
Just (StallReason
NoProgress, Natural
6)

  String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"reports a stall at maxPending, before the stall period has elapsed" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
    (Maybe (StallReason, Natural)
atLimit, Maybe (StallReason, Natural)
belowLimit) <- (forall s.
 IOSim
   s (Maybe (StallReason, Natural), Maybe (StallReason, Natural)))
-> IO (Maybe (StallReason, Natural), Maybe (StallReason, Natural))
forall a. (forall s. IOSim s a) -> IO a
shouldRunInSim ((forall s.
  IOSim
    s (Maybe (StallReason, Natural), Maybe (StallReason, Natural)))
 -> IO (Maybe (StallReason, Natural), Maybe (StallReason, Natural)))
-> (forall s.
    IOSim
      s (Maybe (StallReason, Natural), Maybe (StallReason, Natural)))
-> IO (Maybe (StallReason, Natural), Maybe (StallReason, Natural))
forall a b. (a -> b) -> a -> b
$ do
      Outbox{IOSim s () -> IOSim s ()
$sel:submit:Outbox :: forall (m :: * -> *). Outbox m -> m () -> m ()
submit :: IOSim s () -> IOSim s ()
submit, IOSim s (Maybe (StallReason, Natural))
$sel:outboxStalled:Outbox :: forall (m :: * -> *). Outbox m -> m (Maybe (StallReason, Natural))
outboxStalled :: IOSim s (Maybe (StallReason, Natural))
outboxStalled} <- StallBounds -> String -> IOSim s (Outbox (IOSim s))
forall (m :: * -> *).
(MonadLabelledSTM m, MonadMonotonicTime m) =>
StallBounds -> String -> m (Outbox m)
newOutbox StallBounds
bounds{maxPending = 3} String
"outbox-spec"
      [Int] -> (Int -> IOSim s ()) -> IOSim s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
1 .. Int
2 :: Int] ((Int -> IOSim s ()) -> IOSim s ())
-> (Int -> IOSim s ()) -> IOSim s ()
forall a b. (a -> b) -> a -> b
$ \Int
_ -> IOSim s () -> IOSim s ()
submit (() -> IOSim s ()
forall a. a -> IOSim s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
      Maybe (StallReason, Natural)
belowLimit <- IOSim s (Maybe (StallReason, Natural))
outboxStalled
      IOSim s () -> IOSim s ()
submit (() -> IOSim s ()
forall a. a -> IOSim s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
      Maybe (StallReason, Natural)
atLimit <- IOSim s (Maybe (StallReason, Natural))
outboxStalled
      (Maybe (StallReason, Natural), Maybe (StallReason, Natural))
-> IOSim
     s (Maybe (StallReason, Natural), Maybe (StallReason, Natural))
forall a. a -> IOSim s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (StallReason, Natural)
atLimit, Maybe (StallReason, Natural)
belowLimit)
    -- The bound is inclusive, and nothing has been given time to stall.
    Maybe (StallReason, Natural)
belowLimit Maybe (StallReason, Natural)
-> Maybe (StallReason, Natural) -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Maybe (StallReason, Natural)
forall a. Maybe a
Nothing
    Maybe (StallReason, Natural)
atLimit Maybe (StallReason, Natural)
-> Maybe (StallReason, Natural) -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` (StallReason, Natural) -> Maybe (StallReason, Natural)
forall a. a -> Maybe a
Just (StallReason
BacklogFull, Natural
3)

  String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"does not report a deep backlog that drains within the stall period" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
    -- 75 pending at a tenth of a second each is 7.5s of backlog.
    Maybe (StallReason, Natural)
stalled <- (forall s. IOSim s (Maybe (StallReason, Natural)))
-> IO (Maybe (StallReason, Natural))
forall a. (forall s. IOSim s a) -> IO a
shouldRunInSim ((forall s. IOSim s (Maybe (StallReason, Natural)))
 -> IO (Maybe (StallReason, Natural)))
-> (forall s. IOSim s (Maybe (StallReason, Natural)))
-> IO (Maybe (StallReason, Natural))
forall a b. (a -> b) -> a -> b
$ do
      Outbox{IOSim s () -> IOSim s ()
$sel:submit:Outbox :: forall (m :: * -> *). Outbox m -> m () -> m ()
submit :: IOSim s () -> IOSim s ()
submit, IOSim s (Maybe (StallReason, Natural))
$sel:outboxStalled:Outbox :: forall (m :: * -> *). Outbox m -> m (Maybe (StallReason, Natural))
outboxStalled :: IOSim s (Maybe (StallReason, Natural))
outboxStalled, IOSim s ()
$sel:runOutbox:Outbox :: forall (m :: * -> *). Outbox m -> m ()
runOutbox :: IOSim s ()
runOutbox} <- StallBounds -> String -> IOSim s (Outbox (IOSim s))
forall (m :: * -> *).
(MonadLabelledSTM m, MonadMonotonicTime m) =>
StallBounds -> String -> m (Outbox m)
newOutbox StallBounds
bounds String
"outbox-spec"
      (String, IOSim s ())
-> (Async (IOSim s) () -> IOSim s (Maybe (StallReason, Natural)))
-> IOSim s (Maybe (StallReason, Natural))
forall (m :: * -> *) a b.
MonadAsync m =>
(String, m a) -> (Async m a -> m b) -> m b
withAsyncLabelled (String
"outbox-spec-run", IOSim s ()
runOutbox) ((Async (IOSim s) () -> IOSim s (Maybe (StallReason, Natural)))
 -> IOSim s (Maybe (StallReason, Natural)))
-> (Async (IOSim s) () -> IOSim s (Maybe (StallReason, Natural)))
-> IOSim s (Maybe (StallReason, Natural))
forall a b. (a -> b) -> a -> b
$ \Async (IOSim s) ()
_ -> do
        [Int] -> (Int -> IOSim s ()) -> IOSim s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
1 .. Int
90 :: Int] ((Int -> IOSim s ()) -> IOSim s ())
-> (Int -> IOSim s ()) -> IOSim s ()
forall a b. (a -> b) -> a -> b
$ \Int
_ -> IOSim s () -> IOSim s ()
submit (DiffTime -> IOSim s ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
0.1)
        DiffTime -> IOSim s ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
1.55
        IOSim s (Maybe (StallReason, Natural))
outboxStalled
    Maybe (StallReason, Natural)
stalled Maybe (StallReason, Natural)
-> Maybe (StallReason, Natural) -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Maybe (StallReason, Natural)
forall a. Maybe a
Nothing

  String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"does not report a deep backlog after a single slow completion" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
    -- Regression test: a moving average of the service time jumped by an
    -- eighth of one pause, and 150 pending made that more than the stall
    -- period, refusing clients of a network that was keeping up.
    Maybe (StallReason, Natural)
stalled <- (forall s. IOSim s (Maybe (StallReason, Natural)))
-> IO (Maybe (StallReason, Natural))
forall a. (forall s. IOSim s a) -> IO a
shouldRunInSim ((forall s. IOSim s (Maybe (StallReason, Natural)))
 -> IO (Maybe (StallReason, Natural)))
-> (forall s. IOSim s (Maybe (StallReason, Natural)))
-> IO (Maybe (StallReason, Natural))
forall a b. (a -> b) -> a -> b
$ do
      Outbox{IOSim s () -> IOSim s ()
$sel:submit:Outbox :: forall (m :: * -> *). Outbox m -> m () -> m ()
submit :: IOSim s () -> IOSim s ()
submit, IOSim s (Maybe (StallReason, Natural))
$sel:outboxStalled:Outbox :: forall (m :: * -> *). Outbox m -> m (Maybe (StallReason, Natural))
outboxStalled :: IOSim s (Maybe (StallReason, Natural))
outboxStalled, IOSim s ()
$sel:runOutbox:Outbox :: forall (m :: * -> *). Outbox m -> m ()
runOutbox :: IOSim s ()
runOutbox} <- StallBounds -> String -> IOSim s (Outbox (IOSim s))
forall (m :: * -> *).
(MonadLabelledSTM m, MonadMonotonicTime m) =>
StallBounds -> String -> m (Outbox m)
newOutbox StallBounds
bounds{maxPending = 1000} String
"outbox-spec"
      (String, IOSim s ())
-> (Async (IOSim s) () -> IOSim s (Maybe (StallReason, Natural)))
-> IOSim s (Maybe (StallReason, Natural))
forall (m :: * -> *) a b.
MonadAsync m =>
(String, m a) -> (Async m a -> m b) -> m b
withAsyncLabelled (String
"outbox-spec-run", IOSim s ()
runOutbox) ((Async (IOSim s) () -> IOSim s (Maybe (StallReason, Natural)))
 -> IOSim s (Maybe (StallReason, Natural)))
-> (Async (IOSim s) () -> IOSim s (Maybe (StallReason, Natural)))
-> IOSim s (Maybe (StallReason, Natural))
forall a b. (a -> b) -> a -> b
$ \Async (IOSim s) ()
_ -> do
        [Int] -> (Int -> IOSim s ()) -> IOSim s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
1 .. Int
300 :: Int] ((Int -> IOSim s ()) -> IOSim s ())
-> (Int -> IOSim s ()) -> IOSim s ()
forall a b. (a -> b) -> a -> b
$ \Int
i -> IOSim s () -> IOSim s ()
submit (DiffTime -> IOSim s ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay (DiffTime -> IOSim s ()) -> DiffTime -> IOSim s ()
forall a b. (a -> b) -> a -> b
$ if Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
150 then DiffTime
0.9 else DiffTime
0.01)
        -- Just after the slow one completes, with 150 still pending.
        DiffTime -> IOSim s ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
2.395
        IOSim s (Maybe (StallReason, Natural))
outboxStalled
    Maybe (StallReason, Natural)
stalled Maybe (StallReason, Natural)
-> Maybe (StallReason, Natural) -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Maybe (StallReason, Natural)
forall a. Maybe a
Nothing

  String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"does not report a deep backlog once completions pick up after a long pause" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
    -- Regression test: taking the rate from the last full window alone let a
    -- pause filling a window by itself stand for seconds per action, however
    -- fast the completions right after it.
    Maybe (StallReason, Natural)
stalled <- (forall s. IOSim s (Maybe (StallReason, Natural)))
-> IO (Maybe (StallReason, Natural))
forall a. (forall s. IOSim s a) -> IO a
shouldRunInSim ((forall s. IOSim s (Maybe (StallReason, Natural)))
 -> IO (Maybe (StallReason, Natural)))
-> (forall s. IOSim s (Maybe (StallReason, Natural)))
-> IO (Maybe (StallReason, Natural))
forall a b. (a -> b) -> a -> b
$ do
      Outbox{IOSim s () -> IOSim s ()
$sel:submit:Outbox :: forall (m :: * -> *). Outbox m -> m () -> m ()
submit :: IOSim s () -> IOSim s ()
submit, IOSim s (Maybe (StallReason, Natural))
$sel:outboxStalled:Outbox :: forall (m :: * -> *). Outbox m -> m (Maybe (StallReason, Natural))
outboxStalled :: IOSim s (Maybe (StallReason, Natural))
outboxStalled, IOSim s ()
$sel:runOutbox:Outbox :: forall (m :: * -> *). Outbox m -> m ()
runOutbox :: IOSim s ()
runOutbox} <- StallBounds -> String -> IOSim s (Outbox (IOSim s))
forall (m :: * -> *).
(MonadLabelledSTM m, MonadMonotonicTime m) =>
StallBounds -> String -> m (Outbox m)
newOutbox StallBounds
bounds{maxPending = 1000} String
"outbox-spec"
      (String, IOSim s ())
-> (Async (IOSim s) () -> IOSim s (Maybe (StallReason, Natural)))
-> IOSim s (Maybe (StallReason, Natural))
forall (m :: * -> *) a b.
MonadAsync m =>
(String, m a) -> (Async m a -> m b) -> m b
withAsyncLabelled (String
"outbox-spec-run", IOSim s ()
runOutbox) ((Async (IOSim s) () -> IOSim s (Maybe (StallReason, Natural)))
 -> IOSim s (Maybe (StallReason, Natural)))
-> (Async (IOSim s) () -> IOSim s (Maybe (StallReason, Natural)))
-> IOSim s (Maybe (StallReason, Natural))
forall a b. (a -> b) -> a -> b
$ \Async (IOSim s) ()
_ -> do
        [Int] -> (Int -> IOSim s ()) -> IOSim s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
1 .. Int
501 :: Int] ((Int -> IOSim s ()) -> IOSim s ())
-> (Int -> IOSim s ()) -> IOSim s ()
forall a b. (a -> b) -> a -> b
$ \Int
i -> IOSim s () -> IOSim s ()
submit (DiffTime -> IOSim s ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay (DiffTime -> IOSim s ()) -> DiffTime -> IOSim s ()
forall a b. (a -> b) -> a -> b
$ if Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 then DiffTime
2 else DiffTime
0.001)
        -- A hundred fast completions after the pause, with 400 still pending.
        DiffTime -> IOSim s ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
2.1005
        IOSim s (Maybe (StallReason, Natural))
outboxStalled
    Maybe (StallReason, Natural)
stalled Maybe (StallReason, Natural)
-> Maybe (StallReason, Natural) -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Maybe (StallReason, Natural)
forall a. Maybe a
Nothing

  String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"weighs a very long pause as no more than a window" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
    -- Regression test: counted in full, a minute-long pause stood for 0.2s
    -- per action after 300 fast completions, so 700 pending read as 140s.
    Maybe (StallReason, Natural)
stalled <- (forall s. IOSim s (Maybe (StallReason, Natural)))
-> IO (Maybe (StallReason, Natural))
forall a. (forall s. IOSim s a) -> IO a
shouldRunInSim ((forall s. IOSim s (Maybe (StallReason, Natural)))
 -> IO (Maybe (StallReason, Natural)))
-> (forall s. IOSim s (Maybe (StallReason, Natural)))
-> IO (Maybe (StallReason, Natural))
forall a b. (a -> b) -> a -> b
$ do
      Outbox{IOSim s () -> IOSim s ()
$sel:submit:Outbox :: forall (m :: * -> *). Outbox m -> m () -> m ()
submit :: IOSim s () -> IOSim s ()
submit, IOSim s (Maybe (StallReason, Natural))
$sel:outboxStalled:Outbox :: forall (m :: * -> *). Outbox m -> m (Maybe (StallReason, Natural))
outboxStalled :: IOSim s (Maybe (StallReason, Natural))
outboxStalled, IOSim s ()
$sel:runOutbox:Outbox :: forall (m :: * -> *). Outbox m -> m ()
runOutbox :: IOSim s ()
runOutbox} <- StallBounds -> String -> IOSim s (Outbox (IOSim s))
forall (m :: * -> *).
(MonadLabelledSTM m, MonadMonotonicTime m) =>
StallBounds -> String -> m (Outbox m)
newOutbox StallBounds
bounds{maxPending = 2000} String
"outbox-spec"
      (String, IOSim s ())
-> (Async (IOSim s) () -> IOSim s (Maybe (StallReason, Natural)))
-> IOSim s (Maybe (StallReason, Natural))
forall (m :: * -> *) a b.
MonadAsync m =>
(String, m a) -> (Async m a -> m b) -> m b
withAsyncLabelled (String
"outbox-spec-run", IOSim s ()
runOutbox) ((Async (IOSim s) () -> IOSim s (Maybe (StallReason, Natural)))
 -> IOSim s (Maybe (StallReason, Natural)))
-> (Async (IOSim s) () -> IOSim s (Maybe (StallReason, Natural)))
-> IOSim s (Maybe (StallReason, Natural))
forall a b. (a -> b) -> a -> b
$ \Async (IOSim s) ()
_ -> do
        [Int] -> (Int -> IOSim s ()) -> IOSim s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
1 .. Int
1001 :: Int] ((Int -> IOSim s ()) -> IOSim s ())
-> (Int -> IOSim s ()) -> IOSim s ()
forall a b. (a -> b) -> a -> b
$ \Int
i -> IOSim s () -> IOSim s ()
submit (DiffTime -> IOSim s ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay (DiffTime -> IOSim s ()) -> DiffTime -> IOSim s ()
forall a b. (a -> b) -> a -> b
$ if Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 then DiffTime
60 else DiffTime
0.001)
        DiffTime -> IOSim s ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
60.3005
        IOSim s (Maybe (StallReason, Natural))
outboxStalled
    Maybe (StallReason, Natural)
stalled Maybe (StallReason, Natural)
-> Maybe (StallReason, Natural) -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Maybe (StallReason, Natural)
forall a. Maybe a
Nothing

  String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"does not carry a slow period over an idle period" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
    -- Regression test: windows only rolled over on busy time, so the rate of
    -- a slow period survived the outbox emptying, and an hour later a burst
    -- of 11 read as 11s of backlog.
    Maybe (StallReason, Natural)
stalled <- (forall s. IOSim s (Maybe (StallReason, Natural)))
-> IO (Maybe (StallReason, Natural))
forall a. (forall s. IOSim s a) -> IO a
shouldRunInSim ((forall s. IOSim s (Maybe (StallReason, Natural)))
 -> IO (Maybe (StallReason, Natural)))
-> (forall s. IOSim s (Maybe (StallReason, Natural)))
-> IO (Maybe (StallReason, Natural))
forall a b. (a -> b) -> a -> b
$ do
      Outbox{IOSim s () -> IOSim s ()
$sel:submit:Outbox :: forall (m :: * -> *). Outbox m -> m () -> m ()
submit :: IOSim s () -> IOSim s ()
submit, IOSim s (Maybe (StallReason, Natural))
$sel:outboxStalled:Outbox :: forall (m :: * -> *). Outbox m -> m (Maybe (StallReason, Natural))
outboxStalled :: IOSim s (Maybe (StallReason, Natural))
outboxStalled, IOSim s ()
$sel:runOutbox:Outbox :: forall (m :: * -> *). Outbox m -> m ()
runOutbox :: IOSim s ()
runOutbox} <- StallBounds -> String -> IOSim s (Outbox (IOSim s))
forall (m :: * -> *).
(MonadLabelledSTM m, MonadMonotonicTime m) =>
StallBounds -> String -> m (Outbox m)
newOutbox StallBounds
bounds String
"outbox-spec"
      (String, IOSim s ())
-> (Async (IOSim s) () -> IOSim s (Maybe (StallReason, Natural)))
-> IOSim s (Maybe (StallReason, Natural))
forall (m :: * -> *) a b.
MonadAsync m =>
(String, m a) -> (Async m a -> m b) -> m b
withAsyncLabelled (String
"outbox-spec-run", IOSim s ()
runOutbox) ((Async (IOSim s) () -> IOSim s (Maybe (StallReason, Natural)))
 -> IOSim s (Maybe (StallReason, Natural)))
-> (Async (IOSim s) () -> IOSim s (Maybe (StallReason, Natural)))
-> IOSim s (Maybe (StallReason, Natural))
forall a b. (a -> b) -> a -> b
$ \Async (IOSim s) ()
_ -> do
        [Int] -> (Int -> IOSim s ()) -> IOSim s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
1 .. Int
3 :: Int] ((Int -> IOSim s ()) -> IOSim s ())
-> (Int -> IOSim s ()) -> IOSim s ()
forall a b. (a -> b) -> a -> b
$ \Int
_ -> IOSim s () -> IOSim s ()
submit (DiffTime -> IOSim s ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
2)
        DiffTime -> IOSim s ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
3600
        TMVarDefault (IOSim s) ()
blocked <- String -> IOSim s (TMVar (IOSim s) ())
forall (m :: * -> *) a.
MonadLabelledSTM m =>
String -> m (TMVar m a)
newLabelledEmptyTMVarIO String
"outbox-spec-blocked"
        [Int] -> (Int -> IOSim s ()) -> IOSim s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
1 .. Int
11 :: Int] ((Int -> IOSim s ()) -> IOSim s ())
-> (Int -> IOSim s ()) -> IOSim s ()
forall a b. (a -> b) -> a -> b
$ \Int
_ -> IOSim s () -> IOSim s ()
submit (STM (IOSim s) () -> IOSim s ()
forall a. HasCallStack => STM (IOSim s) a -> IOSim s a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM (IOSim s) () -> IOSim s ()) -> STM (IOSim s) () -> IOSim s ()
forall a b. (a -> b) -> a -> b
$ TMVar (IOSim s) () -> STM (IOSim s) ()
forall a. TMVar (IOSim s) a -> STM (IOSim s) a
forall (m :: * -> *) a. MonadSTM m => TMVar m a -> STM m a
takeTMVar TMVar (IOSim s) ()
TMVarDefault (IOSim s) ()
blocked)
        IOSim s (Maybe (StallReason, Natural))
outboxStalled
    Maybe (StallReason, Natural)
stalled Maybe (StallReason, Natural)
-> Maybe (StallReason, Natural) -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Maybe (StallReason, Natural)
forall a. Maybe a
Nothing

  String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"reports a backlog that would take longer than the stall period to drain" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
    Maybe (StallReason, Natural)
stalled <- (forall s. IOSim s (Maybe (StallReason, Natural)))
-> IO (Maybe (StallReason, Natural))
forall a. (forall s. IOSim s a) -> IO a
shouldRunInSim ((forall s. IOSim s (Maybe (StallReason, Natural)))
 -> IO (Maybe (StallReason, Natural)))
-> (forall s. IOSim s (Maybe (StallReason, Natural)))
-> IO (Maybe (StallReason, Natural))
forall a b. (a -> b) -> a -> b
$ do
      Outbox{IOSim s () -> IOSim s ()
$sel:submit:Outbox :: forall (m :: * -> *). Outbox m -> m () -> m ()
submit :: IOSim s () -> IOSim s ()
submit, IOSim s (Maybe (StallReason, Natural))
$sel:outboxStalled:Outbox :: forall (m :: * -> *). Outbox m -> m (Maybe (StallReason, Natural))
outboxStalled :: IOSim s (Maybe (StallReason, Natural))
outboxStalled, IOSim s ()
$sel:runOutbox:Outbox :: forall (m :: * -> *). Outbox m -> m ()
runOutbox :: IOSim s ()
runOutbox} <- StallBounds -> String -> IOSim s (Outbox (IOSim s))
forall (m :: * -> *).
(MonadLabelledSTM m, MonadMonotonicTime m) =>
StallBounds -> String -> m (Outbox m)
newOutbox StallBounds
bounds String
"outbox-spec"
      (String, IOSim s ())
-> (Async (IOSim s) () -> IOSim s (Maybe (StallReason, Natural)))
-> IOSim s (Maybe (StallReason, Natural))
forall (m :: * -> *) a b.
MonadAsync m =>
(String, m a) -> (Async m a -> m b) -> m b
withAsyncLabelled (String
"outbox-spec-run", IOSim s ()
runOutbox) ((Async (IOSim s) () -> IOSim s (Maybe (StallReason, Natural)))
 -> IOSim s (Maybe (StallReason, Natural)))
-> (Async (IOSim s) () -> IOSim s (Maybe (StallReason, Natural)))
-> IOSim s (Maybe (StallReason, Natural))
forall a b. (a -> b) -> a -> b
$ \Async (IOSim s) ()
_ -> do
        [Int] -> (Int -> IOSim s ()) -> IOSim s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
1 .. Int
20 :: Int] ((Int -> IOSim s ()) -> IOSim s ())
-> (Int -> IOSim s ()) -> IOSim s ()
forall a b. (a -> b) -> a -> b
$ \Int
_ -> IOSim s () -> IOSim s ()
submit (DiffTime -> IOSim s ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
1)
        DiffTime -> IOSim s ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
1.5
        IOSim s (Maybe (StallReason, Natural))
outboxStalled
    -- Something completed half a second ago, and the count is far below
    -- 'maxPending', but 19 more at a second each is more than 'noProgressFor'.
    Maybe (StallReason, Natural)
stalled Maybe (StallReason, Natural)
-> Maybe (StallReason, Natural) -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` (StallReason, Natural) -> Maybe (StallReason, Natural)
forall a. a -> Maybe a
Just (StallReason
BacklogFull, Natural
19)

  String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"tells a full backlog apart from no progress" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
    -- The two 'StallBounds' limbs are different conditions (see
    -- 'StallReason'): a fast burst that fills 'maxPending' immediately is not
    -- the same as a consumer that has stopped moving entirely.
    (Maybe (StallReason, Natural)
backlogFull, Maybe (StallReason, Natural)
noProgress) <- (forall s.
 IOSim
   s (Maybe (StallReason, Natural), Maybe (StallReason, Natural)))
-> IO (Maybe (StallReason, Natural), Maybe (StallReason, Natural))
forall a. (forall s. IOSim s a) -> IO a
shouldRunInSim ((forall s.
  IOSim
    s (Maybe (StallReason, Natural), Maybe (StallReason, Natural)))
 -> IO (Maybe (StallReason, Natural), Maybe (StallReason, Natural)))
-> (forall s.
    IOSim
      s (Maybe (StallReason, Natural), Maybe (StallReason, Natural)))
-> IO (Maybe (StallReason, Natural), Maybe (StallReason, Natural))
forall a b. (a -> b) -> a -> b
$ do
      Maybe (StallReason, Natural)
full <- do
        Outbox{IOSim s () -> IOSim s ()
$sel:submit:Outbox :: forall (m :: * -> *). Outbox m -> m () -> m ()
submit :: IOSim s () -> IOSim s ()
submit, IOSim s (Maybe (StallReason, Natural))
$sel:outboxStalled:Outbox :: forall (m :: * -> *). Outbox m -> m (Maybe (StallReason, Natural))
outboxStalled :: IOSim s (Maybe (StallReason, Natural))
outboxStalled} <- StallBounds -> String -> IOSim s (Outbox (IOSim s))
forall (m :: * -> *).
(MonadLabelledSTM m, MonadMonotonicTime m) =>
StallBounds -> String -> m (Outbox m)
newOutbox StallBounds
bounds{maxPending = 3} String
"outbox-spec-full"
        [Int] -> (Int -> IOSim s ()) -> IOSim s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
1 .. Int
3 :: Int] ((Int -> IOSim s ()) -> IOSim s ())
-> (Int -> IOSim s ()) -> IOSim s ()
forall a b. (a -> b) -> a -> b
$ \Int
_ -> IOSim s () -> IOSim s ()
submit (() -> IOSim s ()
forall a. a -> IOSim s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
        IOSim s (Maybe (StallReason, Natural))
outboxStalled
      Maybe (StallReason, Natural)
stuck <- StallBounds
-> (Outbox (IOSim s) -> IOSim s (Maybe (StallReason, Natural)))
-> IOSim s (Maybe (StallReason, Natural))
forall (m :: * -> *) a.
(MonadAsync m, MonadLabelledSTM m, MonadMonotonicTime m) =>
StallBounds -> (Outbox m -> m a) -> m a
withStuckOutbox StallBounds
bounds ((Outbox (IOSim s) -> IOSim s (Maybe (StallReason, Natural)))
 -> IOSim s (Maybe (StallReason, Natural)))
-> (Outbox (IOSim s) -> IOSim s (Maybe (StallReason, Natural)))
-> IOSim s (Maybe (StallReason, Natural))
forall a b. (a -> b) -> a -> b
$ \Outbox{IOSim s (Maybe (StallReason, Natural))
$sel:outboxStalled:Outbox :: forall (m :: * -> *). Outbox m -> m (Maybe (StallReason, Natural))
outboxStalled :: IOSim s (Maybe (StallReason, Natural))
outboxStalled} -> do
        DiffTime -> IOSim s ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
11
        IOSim s (Maybe (StallReason, Natural))
outboxStalled
      (Maybe (StallReason, Natural), Maybe (StallReason, Natural))
-> IOSim
     s (Maybe (StallReason, Natural), Maybe (StallReason, Natural))
forall a. a -> IOSim s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (StallReason, Natural)
full, Maybe (StallReason, Natural)
stuck)
    Maybe (StallReason, Natural)
backlogFull Maybe (StallReason, Natural)
-> Maybe (StallReason, Natural) -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` (StallReason, Natural) -> Maybe (StallReason, Natural)
forall a. a -> Maybe a
Just (StallReason
BacklogFull, Natural
3)
    Maybe (StallReason, Natural)
noProgress Maybe (StallReason, Natural)
-> Maybe (StallReason, Natural) -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` (StallReason, Natural) -> Maybe (StallReason, Natural)
forall a. a -> Maybe a
Just (StallReason
NoProgress, Natural
1)

-- | Run an outbox whose single submitted action never completes, which is what
-- a network that cannot deliver looks like from here.
withStuckOutbox ::
  (MonadAsync m, MonadLabelledSTM m, MonadMonotonicTime m) =>
  StallBounds ->
  (Outbox m -> m a) ->
  m a
withStuckOutbox :: forall (m :: * -> *) a.
(MonadAsync m, MonadLabelledSTM m, MonadMonotonicTime m) =>
StallBounds -> (Outbox m -> m a) -> m a
withStuckOutbox StallBounds
stallBounds Outbox m -> m a
action = do
  outbox :: Outbox m
outbox@Outbox{m () -> m ()
$sel:submit:Outbox :: forall (m :: * -> *). Outbox m -> m () -> m ()
submit :: m () -> m ()
submit, m ()
$sel:runOutbox:Outbox :: forall (m :: * -> *). Outbox m -> m ()
runOutbox :: m ()
runOutbox} <- StallBounds -> String -> m (Outbox m)
forall (m :: * -> *).
(MonadLabelledSTM m, MonadMonotonicTime m) =>
StallBounds -> String -> m (Outbox m)
newOutbox StallBounds
stallBounds String
"outbox-spec"
  (String, m ()) -> (Async m () -> m a) -> m a
forall (m :: * -> *) a b.
MonadAsync m =>
(String, m a) -> (Async m a -> m b) -> m b
withAsyncLabelled (String
"outbox-spec-run", m ()
runOutbox) ((Async m () -> m a) -> m a) -> (Async m () -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \Async m ()
_ -> do
    TMVar m ()
blocked <- String -> m (TMVar m ())
forall (m :: * -> *) a.
MonadLabelledSTM m =>
String -> m (TMVar m a)
newLabelledEmptyTMVarIO String
"outbox-spec-blocked"
    m () -> m ()
submit (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
$ TMVar m () -> STM m ()
forall a. TMVar m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TMVar m a -> STM m a
takeTMVar TMVar m ()
blocked)
    Outbox m -> m a
action Outbox m
outbox