{-# LANGUAGE DeriveGeneric        #-}
{-# LANGUAGE DerivingVia          #-}
{-# LANGUAGE FlexibleContexts     #-}
{-# LANGUAGE GADTs                #-}
{-# LANGUAGE NamedFieldPuns       #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE StandaloneDeriving   #-}
{-# LANGUAGE TypeApplications     #-}
{-# LANGUAGE TypeOperators        #-}
{-# LANGUAGE UndecidableInstances #-}

module Test.Ouroboros.Network.PeerState (tests) where


import Control.Exception (ArithException (..), AsyncException (..),
           NonTermination (..))
import Data.Functor (void)
import Data.Map.Strict qualified as Map
import Data.Monoid (First (..))
import Data.Set qualified as Set
import Text.Printf

import Control.Concurrent.Class.MonadSTM.Strict
import Control.Monad.Class.MonadAsync
import Control.Monad.Class.MonadFork
import Control.Monad.Class.MonadThrow
import Control.Monad.Class.MonadTime.SI
import Control.Tracer

import Data.Semigroup.Action
import Ouroboros.Network.ErrorPolicy
import Ouroboros.Network.Server.ConnectionTable
import Ouroboros.Network.Snocket
import Ouroboros.Network.Subscription.Ip
import Ouroboros.Network.Subscription.PeerState
import Ouroboros.Network.Subscription.Worker

import Test.QuickCheck hiding (Result)
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.QuickCheck (testProperty)

tests :: TestTree
tests :: TestTree
tests = String -> [TestTree] -> TestTree
testGroup String
"Ouroboros.Network.Subscription.PeerState"
  [ String
-> (ArbSuspendDecision Int
    -> ArbSuspendDecision Int -> ArbSuspendDecision Int -> Bool)
-> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"SuspendDecision semigroup" (forall t.
Ord t =>
ArbSuspendDecision t
-> ArbSuspendDecision t -> ArbSuspendDecision t -> Bool
prop_SuspendDecisionSemigroup @Int)
  , String
-> (Blind (Maybe (ArbPeerState IO))
    -> ArbSuspendDecision ArbTime
    -> ArbSuspendDecision ArbTime
    -> Bool)
-> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"Suspend semigroup action on PeerState (up to constructor)"
      (forall (m :: * -> *).
Eq (Async m ()) =>
Blind (Maybe (ArbPeerState m))
-> ArbSuspendDecision ArbTime -> ArbSuspendDecision ArbTime -> Bool
prop_SuspendDecisionAction @IO)
  , String
-> (SnocketType
    -> Int
    -> Int
    -> ArbValidPeerState IO
    -> ArbErrorPolicies
    -> Blind (ArbApp Int)
    -> Property)
-> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"worker error handling" SnocketType
-> Int
-> Int
-> ArbValidPeerState IO
-> ArbErrorPolicies
-> Blind (ArbApp Int)
-> Property
prop_subscriptionWorker
  ]


--
-- Generators of 'SuspendDecision' and 'PeerState'
--

newtype ArbSuspendDecision t = ArbSuspendDecision {
      forall t. ArbSuspendDecision t -> SuspendDecision t
getArbSuspendDecision :: SuspendDecision t
    }
  deriving (ArbSuspendDecision t -> ArbSuspendDecision t -> Bool
(ArbSuspendDecision t -> ArbSuspendDecision t -> Bool)
-> (ArbSuspendDecision t -> ArbSuspendDecision t -> Bool)
-> Eq (ArbSuspendDecision t)
forall t.
Eq t =>
ArbSuspendDecision t -> ArbSuspendDecision t -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall t.
Eq t =>
ArbSuspendDecision t -> ArbSuspendDecision t -> Bool
== :: ArbSuspendDecision t -> ArbSuspendDecision t -> Bool
$c/= :: forall t.
Eq t =>
ArbSuspendDecision t -> ArbSuspendDecision t -> Bool
/= :: ArbSuspendDecision t -> ArbSuspendDecision t -> Bool
Eq, Int -> ArbSuspendDecision t -> String -> String
[ArbSuspendDecision t] -> String -> String
ArbSuspendDecision t -> String
(Int -> ArbSuspendDecision t -> String -> String)
-> (ArbSuspendDecision t -> String)
-> ([ArbSuspendDecision t] -> String -> String)
-> Show (ArbSuspendDecision t)
forall t. Show t => Int -> ArbSuspendDecision t -> String -> String
forall t. Show t => [ArbSuspendDecision t] -> String -> String
forall t. Show t => ArbSuspendDecision t -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: forall t. Show t => Int -> ArbSuspendDecision t -> String -> String
showsPrec :: Int -> ArbSuspendDecision t -> String -> String
$cshow :: forall t. Show t => ArbSuspendDecision t -> String
show :: ArbSuspendDecision t -> String
$cshowList :: forall t. Show t => [ArbSuspendDecision t] -> String -> String
showList :: [ArbSuspendDecision t] -> String -> String
Show)

genSuspendDecision :: Gen t
                   -> Gen (SuspendDecision t)
genSuspendDecision :: forall t. Gen t -> Gen (SuspendDecision t)
genSuspendDecision Gen t
gen = [Gen (SuspendDecision t)] -> Gen (SuspendDecision t)
forall a. [Gen a] -> Gen a
oneof
    [ t -> t -> SuspendDecision t
forall t. t -> t -> SuspendDecision t
SuspendPeer (t -> t -> SuspendDecision t)
-> Gen t -> Gen (t -> SuspendDecision t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen t
gen Gen (t -> SuspendDecision t) -> Gen t -> Gen (SuspendDecision t)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen t
gen
    , t -> SuspendDecision t
forall t. t -> SuspendDecision t
SuspendConsumer (t -> SuspendDecision t) -> Gen t -> Gen (SuspendDecision t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen t
gen
    , SuspendDecision t -> Gen (SuspendDecision t)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SuspendDecision t
forall t. SuspendDecision t
Throw
    ]

genDiffTime :: Gen DiffTime
genDiffTime :: Gen DiffTime
genDiffTime = forall a b. (Integral a, Num b) => a -> b
fromIntegral @Int (Int -> DiffTime) -> Gen Int -> Gen DiffTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Int
forall a. Arbitrary a => Gen a
arbitrary

instance Arbitrary t => Arbitrary (ArbSuspendDecision t) where
    arbitrary :: Gen (ArbSuspendDecision t)
arbitrary = SuspendDecision t -> ArbSuspendDecision t
forall t. SuspendDecision t -> ArbSuspendDecision t
ArbSuspendDecision (SuspendDecision t -> ArbSuspendDecision t)
-> Gen (SuspendDecision t) -> Gen (ArbSuspendDecision t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen t -> Gen (SuspendDecision t)
forall t. Gen t -> Gen (SuspendDecision t)
genSuspendDecision Gen t
forall a. Arbitrary a => Gen a
arbitrary

-- | Subsemigroup formed by 'SuspendPeer' and 'SuspendDecision'.
--
newtype SuspendSubsemigroup t = SuspendSubsemigroup {
      forall t. SuspendSubsemigroup t -> SuspendDecision t
getSuspendSubsemigroup :: SuspendDecision t
    }
  deriving (SuspendSubsemigroup t -> SuspendSubsemigroup t -> Bool
(SuspendSubsemigroup t -> SuspendSubsemigroup t -> Bool)
-> (SuspendSubsemigroup t -> SuspendSubsemigroup t -> Bool)
-> Eq (SuspendSubsemigroup t)
forall t.
Eq t =>
SuspendSubsemigroup t -> SuspendSubsemigroup t -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall t.
Eq t =>
SuspendSubsemigroup t -> SuspendSubsemigroup t -> Bool
== :: SuspendSubsemigroup t -> SuspendSubsemigroup t -> Bool
$c/= :: forall t.
Eq t =>
SuspendSubsemigroup t -> SuspendSubsemigroup t -> Bool
/= :: SuspendSubsemigroup t -> SuspendSubsemigroup t -> Bool
Eq, Int -> SuspendSubsemigroup t -> String -> String
[SuspendSubsemigroup t] -> String -> String
SuspendSubsemigroup t -> String
(Int -> SuspendSubsemigroup t -> String -> String)
-> (SuspendSubsemigroup t -> String)
-> ([SuspendSubsemigroup t] -> String -> String)
-> Show (SuspendSubsemigroup t)
forall t.
Show t =>
Int -> SuspendSubsemigroup t -> String -> String
forall t. Show t => [SuspendSubsemigroup t] -> String -> String
forall t. Show t => SuspendSubsemigroup t -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: forall t.
Show t =>
Int -> SuspendSubsemigroup t -> String -> String
showsPrec :: Int -> SuspendSubsemigroup t -> String -> String
$cshow :: forall t. Show t => SuspendSubsemigroup t -> String
show :: SuspendSubsemigroup t -> String
$cshowList :: forall t. Show t => [SuspendSubsemigroup t] -> String -> String
showList :: [SuspendSubsemigroup t] -> String -> String
Show)

instance Arbitrary t => Arbitrary (SuspendSubsemigroup t) where
    arbitrary :: Gen (SuspendSubsemigroup t)
arbitrary = [Gen (SuspendSubsemigroup t)] -> Gen (SuspendSubsemigroup t)
forall a. [Gen a] -> Gen a
oneof
      [ SuspendDecision t -> SuspendSubsemigroup t
forall t. SuspendDecision t -> SuspendSubsemigroup t
SuspendSubsemigroup (SuspendDecision t -> SuspendSubsemigroup t)
-> Gen (SuspendDecision t) -> Gen (SuspendSubsemigroup t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (t -> t -> SuspendDecision t
forall t. t -> t -> SuspendDecision t
SuspendPeer (t -> t -> SuspendDecision t)
-> Gen t -> Gen (t -> SuspendDecision t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen t
forall a. Arbitrary a => Gen a
arbitrary Gen (t -> SuspendDecision t) -> Gen t -> Gen (SuspendDecision t)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen t
forall a. Arbitrary a => Gen a
arbitrary)
      , SuspendDecision t -> SuspendSubsemigroup t
forall t. SuspendDecision t -> SuspendSubsemigroup t
SuspendSubsemigroup (SuspendDecision t -> SuspendSubsemigroup t)
-> (t -> SuspendDecision t) -> t -> SuspendSubsemigroup t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> SuspendDecision t
forall t. t -> SuspendDecision t
SuspendConsumer (t -> SuspendSubsemigroup t)
-> Gen t -> Gen (SuspendSubsemigroup t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen t
forall a. Arbitrary a => Gen a
arbitrary
      ]

newtype ArbPeerState m = ArbPeerState {
      forall (m :: * -> *). ArbPeerState m -> PeerState m
getArbPeerState :: PeerState m
    }

instance ( Ord (ThreadId m)
         , Show (ThreadId m)
         , MonadAsync m
         ) => Show (ArbPeerState m) where
    show :: ArbPeerState m -> String
show (ArbPeerState PeerState m
p) = String
"ArbPeerState " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PeerState m -> String
forall a. Show a => a -> String
show PeerState m
p

-- TODO: it only generates times, not ThreadId's.
instance Arbitrary (ArbPeerState m) where
    arbitrary :: Gen (ArbPeerState m)
arbitrary = [Gen (ArbPeerState m)] -> Gen (ArbPeerState m)
forall a. [Gen a] -> Gen a
oneof
      [ ArbPeerState m -> Gen (ArbPeerState m)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ArbPeerState m -> Gen (ArbPeerState m))
-> ArbPeerState m -> Gen (ArbPeerState m)
forall a b. (a -> b) -> a -> b
$ PeerState m -> ArbPeerState m
forall (m :: * -> *). PeerState m -> ArbPeerState m
ArbPeerState (Set (Async m ()) -> Set (Async m ()) -> PeerState m
forall (m :: * -> *).
Set (Async m ()) -> Set (Async m ()) -> PeerState m
HotPeer Set (Async m ())
forall a. Set a
Set.empty Set (Async m ())
forall a. Set a
Set.empty)
      , PeerState m -> ArbPeerState m
forall (m :: * -> *). PeerState m -> ArbPeerState m
ArbPeerState (PeerState m -> ArbPeerState m)
-> (ArbTime -> PeerState m) -> ArbTime -> ArbPeerState m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set (Async m ()) -> Time -> PeerState m
forall (m :: * -> *). Set (Async m ()) -> Time -> PeerState m
SuspendedConsumer Set (Async m ())
forall a. Set a
Set.empty (Time -> PeerState m)
-> (ArbTime -> Time) -> ArbTime -> PeerState m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ArbTime -> Time
getArbTime (ArbTime -> ArbPeerState m) -> Gen ArbTime -> Gen (ArbPeerState m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen ArbTime
forall a. Arbitrary a => Gen a
arbitrary
      , PeerState m -> ArbPeerState m
forall (m :: * -> *). PeerState m -> ArbPeerState m
ArbPeerState (PeerState m -> ArbPeerState m)
-> Gen (PeerState m) -> Gen (ArbPeerState m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Time -> Time -> PeerState m
forall (m :: * -> *). Time -> Time -> PeerState m
SuspendedPeer (Time -> Time -> PeerState m)
-> Gen Time -> Gen (Time -> PeerState m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ArbTime -> Time
getArbTime (ArbTime -> Time) -> Gen ArbTime -> Gen Time
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen ArbTime
forall a. Arbitrary a => Gen a
arbitrary)
                                        Gen (Time -> PeerState m) -> Gen Time -> Gen (PeerState m)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ArbTime -> Time
getArbTime (ArbTime -> Time) -> Gen ArbTime -> Gen Time
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen ArbTime
forall a. Arbitrary a => Gen a
arbitrary))
      , ArbPeerState m -> Gen (ArbPeerState m)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PeerState m -> ArbPeerState m
forall (m :: * -> *). PeerState m -> ArbPeerState m
ArbPeerState PeerState m
forall (m :: * -> *). PeerState m
ColdPeer)
      ]

--
-- Algebraic properties of 'SuspendDecision' and 'PeerState'
--

prop_SuspendDecisionSemigroup
    :: Ord t
    => ArbSuspendDecision t
    -> ArbSuspendDecision t
    -> ArbSuspendDecision t
    -> Bool
prop_SuspendDecisionSemigroup :: forall t.
Ord t =>
ArbSuspendDecision t
-> ArbSuspendDecision t -> ArbSuspendDecision t -> Bool
prop_SuspendDecisionSemigroup (ArbSuspendDecision SuspendDecision t
a1)
                             (ArbSuspendDecision SuspendDecision t
a2)
                             (ArbSuspendDecision SuspendDecision t
a3) =
    SuspendDecision t
a1 SuspendDecision t -> SuspendDecision t -> SuspendDecision t
forall a. Semigroup a => a -> a -> a
<> (SuspendDecision t
a2 SuspendDecision t -> SuspendDecision t -> SuspendDecision t
forall a. Semigroup a => a -> a -> a
<> SuspendDecision t
a3) SuspendDecision t -> SuspendDecision t -> Bool
forall a. Eq a => a -> a -> Bool
== (SuspendDecision t
a1 SuspendDecision t -> SuspendDecision t -> SuspendDecision t
forall a. Semigroup a => a -> a -> a
<> SuspendDecision t
a2) SuspendDecision t -> SuspendDecision t -> SuspendDecision t
forall a. Semigroup a => a -> a -> a
<> SuspendDecision t
a3

prop_SuspendDecisionAction
    :: forall m.
       Eq (Async m ())
    => Blind (Maybe (ArbPeerState m))
    -> ArbSuspendDecision ArbTime
    -> ArbSuspendDecision ArbTime
    -> Bool
prop_SuspendDecisionAction :: forall (m :: * -> *).
Eq (Async m ()) =>
Blind (Maybe (ArbPeerState m))
-> ArbSuspendDecision ArbTime -> ArbSuspendDecision ArbTime -> Bool
prop_SuspendDecisionAction
      (Blind Maybe (ArbPeerState m)
mps)
      (ArbSuspendDecision SuspendDecision ArbTime
a1)
      (ArbSuspendDecision SuspendDecision ArbTime
a2) =
    Maybe (PeerState m)
mps' Maybe (PeerState m) -> SuspendDecision Time -> Maybe (PeerState m)
forall s x. SAct s x => x -> s -> x
<| (SuspendDecision Time
sd1 SuspendDecision Time
-> SuspendDecision Time -> SuspendDecision Time
forall a. Semigroup a => a -> a -> a
<> SuspendDecision Time
sd2) Maybe (PeerState m) -> Maybe (PeerState m) -> Bool
forall a. Eq a => a -> a -> Bool
== (Maybe (PeerState m)
mps' Maybe (PeerState m) -> SuspendDecision Time -> Maybe (PeerState m)
forall s x. SAct s x => x -> s -> x
<| SuspendDecision Time
sd1 SuspendDecision Time
-> SuspendDecision Time -> SuspendDecision Time
forall s x. SAct s x => x -> s -> x
<| SuspendDecision Time
sd2)
  where
    sd1 :: SuspendDecision Time
sd1 = ArbTime -> Time
getArbTime (ArbTime -> Time)
-> SuspendDecision ArbTime -> SuspendDecision Time
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SuspendDecision ArbTime
a1
    sd2 :: SuspendDecision Time
sd2 = ArbTime -> Time
getArbTime (ArbTime -> Time)
-> SuspendDecision ArbTime -> SuspendDecision Time
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SuspendDecision ArbTime
a2
    mps' :: Maybe (PeerState m)
    mps' :: Maybe (PeerState m)
mps' = ArbPeerState m -> PeerState m
forall (m :: * -> *). ArbPeerState m -> PeerState m
getArbPeerState (ArbPeerState m -> PeerState m)
-> Maybe (ArbPeerState m) -> Maybe (PeerState m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (ArbPeerState m)
mps

-- | Like 'ArbPeerState' but does not generate  'HotPeer' with empty producer
-- and consumer sets.
--
newtype ArbValidPeerState m = ArbValidPeerState (PeerState m)

-- TODO
instance Show (ArbValidPeerState t) where
    show :: ArbValidPeerState t -> String
show (ArbValidPeerState PeerState t
_) = String
"ArbValidPeerState"

instance Arbitrary (ArbValidPeerState m) where
    arbitrary :: Gen (ArbValidPeerState m)
arbitrary = [Gen (ArbValidPeerState m)] -> Gen (ArbValidPeerState m)
forall a. [Gen a] -> Gen a
oneof
      [ PeerState m -> ArbValidPeerState m
forall (m :: * -> *). PeerState m -> ArbValidPeerState m
ArbValidPeerState (PeerState m -> ArbValidPeerState m)
-> (ArbTime -> PeerState m) -> ArbTime -> ArbValidPeerState m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set (Async m ()) -> Time -> PeerState m
forall (m :: * -> *). Set (Async m ()) -> Time -> PeerState m
SuspendedConsumer Set (Async m ())
forall a. Set a
Set.empty (Time -> PeerState m)
-> (ArbTime -> Time) -> ArbTime -> PeerState m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ArbTime -> Time
getArbTime (ArbTime -> ArbValidPeerState m)
-> Gen ArbTime -> Gen (ArbValidPeerState m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen ArbTime
forall a. Arbitrary a => Gen a
arbitrary
      , PeerState m -> ArbValidPeerState m
forall (m :: * -> *). PeerState m -> ArbValidPeerState m
ArbValidPeerState (PeerState m -> ArbValidPeerState m)
-> Gen (PeerState m) -> Gen (ArbValidPeerState m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Time -> Time -> PeerState m
forall (m :: * -> *). Time -> Time -> PeerState m
SuspendedPeer (Time -> Time -> PeerState m)
-> Gen Time -> Gen (Time -> PeerState m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ArbTime -> Time
getArbTime (ArbTime -> Time) -> Gen ArbTime -> Gen Time
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen ArbTime
forall a. Arbitrary a => Gen a
arbitrary)
                                             Gen (Time -> PeerState m) -> Gen Time -> Gen (PeerState m)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ArbTime -> Time
getArbTime (ArbTime -> Time) -> Gen ArbTime -> Gen Time
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen ArbTime
forall a. Arbitrary a => Gen a
arbitrary))
      , ArbValidPeerState m -> Gen (ArbValidPeerState m)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PeerState m -> ArbValidPeerState m
forall (m :: * -> *). PeerState m -> ArbValidPeerState m
ArbValidPeerState PeerState m
forall (m :: * -> *). PeerState m
ColdPeer)
      ]

data ArbException where
     ArbException
      :: Exception err
      => err
      -> ArbException

instance Show ArbException where
    show :: ArbException -> String
show (ArbException err
err) = String
"ArbException " String -> String -> String
forall a. [a] -> [a] -> [a]
++ err -> String
forall a. Show a => a -> String
show err
err

data TestException1 = TestException1
  deriving Int -> TestException1 -> String -> String
[TestException1] -> String -> String
TestException1 -> String
(Int -> TestException1 -> String -> String)
-> (TestException1 -> String)
-> ([TestException1] -> String -> String)
-> Show TestException1
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> TestException1 -> String -> String
showsPrec :: Int -> TestException1 -> String -> String
$cshow :: TestException1 -> String
show :: TestException1 -> String
$cshowList :: [TestException1] -> String -> String
showList :: [TestException1] -> String -> String
Show

instance Exception TestException1

data TestException2 = TestException2
  deriving Int -> TestException2 -> String -> String
[TestException2] -> String -> String
TestException2 -> String
(Int -> TestException2 -> String -> String)
-> (TestException2 -> String)
-> ([TestException2] -> String -> String)
-> Show TestException2
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> TestException2 -> String -> String
showsPrec :: Int -> TestException2 -> String -> String
$cshow :: TestException2 -> String
show :: TestException2 -> String
$cshowList :: [TestException2] -> String -> String
showList :: [TestException2] -> String -> String
Show

instance Exception TestException2

instance Arbitrary ArbException where
    arbitrary :: Gen ArbException
arbitrary = [Gen ArbException] -> Gen ArbException
forall a. [Gen a] -> Gen a
oneof
      [ ArbException -> Gen ArbException
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TestException1 -> ArbException
forall e. Exception e => e -> ArbException
ArbException TestException1
TestException1)
      , ArbException -> Gen ArbException
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TestException2 -> ArbException
forall e. Exception e => e -> ArbException
ArbException TestException2
TestException2)
      -- AsyncException
      -- , pure (ArbException StackOverflow)
      -- , pure (ArbException HeapOverflow)
      -- NonTermination
      -- , pure (ArbException NonTermination)
      ]

data ArbErrorPolicies = ArbErrorPolicies [ErrorPolicy] -- application error policy
                                         [ErrorPolicy] -- connection error policy
  deriving Int -> ArbErrorPolicies -> String -> String
[ArbErrorPolicies] -> String -> String
ArbErrorPolicies -> String
(Int -> ArbErrorPolicies -> String -> String)
-> (ArbErrorPolicies -> String)
-> ([ArbErrorPolicies] -> String -> String)
-> Show ArbErrorPolicies
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> ArbErrorPolicies -> String -> String
showsPrec :: Int -> ArbErrorPolicies -> String -> String
$cshow :: ArbErrorPolicies -> String
show :: ArbErrorPolicies -> String
$cshowList :: [ArbErrorPolicies] -> String -> String
showList :: [ArbErrorPolicies] -> String -> String
Show


genErrorPolicy :: Gen (SuspendDecision DiffTime)
               -> Gen (ErrorPolicy)
genErrorPolicy :: Gen (SuspendDecision DiffTime) -> Gen ErrorPolicy
genErrorPolicy Gen (SuspendDecision DiffTime)
genCmd = [Gen ErrorPolicy] -> Gen ErrorPolicy
forall a. [Gen a] -> Gen a
oneof
    [ (\SuspendDecision DiffTime
cmd -> (ArithException -> Maybe (SuspendDecision DiffTime)) -> ErrorPolicy
forall e.
Exception e =>
(e -> Maybe (SuspendDecision DiffTime)) -> ErrorPolicy
ErrorPolicy (\(ArithException
_e :: ArithException) -> SuspendDecision DiffTime -> Maybe (SuspendDecision DiffTime)
forall a. a -> Maybe a
Just SuspendDecision DiffTime
cmd)) (SuspendDecision DiffTime -> ErrorPolicy)
-> Gen (SuspendDecision DiffTime) -> Gen ErrorPolicy
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (SuspendDecision DiffTime)
genCmd,
      (\SuspendDecision DiffTime
cmd -> (AsyncException -> Maybe (SuspendDecision DiffTime)) -> ErrorPolicy
forall e.
Exception e =>
(e -> Maybe (SuspendDecision DiffTime)) -> ErrorPolicy
ErrorPolicy (\(AsyncException
_e :: AsyncException) -> SuspendDecision DiffTime -> Maybe (SuspendDecision DiffTime)
forall a. a -> Maybe a
Just SuspendDecision DiffTime
cmd)) (SuspendDecision DiffTime -> ErrorPolicy)
-> Gen (SuspendDecision DiffTime) -> Gen ErrorPolicy
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (SuspendDecision DiffTime)
genCmd,
      (\SuspendDecision DiffTime
cmd -> (NonTermination -> Maybe (SuspendDecision DiffTime)) -> ErrorPolicy
forall e.
Exception e =>
(e -> Maybe (SuspendDecision DiffTime)) -> ErrorPolicy
ErrorPolicy (\(NonTermination
_e :: NonTermination) -> SuspendDecision DiffTime -> Maybe (SuspendDecision DiffTime)
forall a. a -> Maybe a
Just SuspendDecision DiffTime
cmd)) (SuspendDecision DiffTime -> ErrorPolicy)
-> Gen (SuspendDecision DiffTime) -> Gen ErrorPolicy
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (SuspendDecision DiffTime)
genCmd
    ]

instance Arbitrary ArbErrorPolicies where
    arbitrary :: Gen ArbErrorPolicies
arbitrary = [ErrorPolicy] -> [ErrorPolicy] -> ArbErrorPolicies
ArbErrorPolicies ([ErrorPolicy] -> [ErrorPolicy] -> ArbErrorPolicies)
-> Gen [ErrorPolicy] -> Gen ([ErrorPolicy] -> ArbErrorPolicies)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen ErrorPolicy -> Gen [ErrorPolicy]
forall a. Gen a -> Gen [a]
listOf Gen ErrorPolicy
genPolicy Gen ([ErrorPolicy] -> ArbErrorPolicies)
-> Gen [ErrorPolicy] -> Gen ArbErrorPolicies
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen ErrorPolicy -> Gen [ErrorPolicy]
forall a. Gen a -> Gen [a]
listOf Gen ErrorPolicy
genPolicy
      where
        genPolicy :: Gen ErrorPolicy
genPolicy = Gen (SuspendDecision DiffTime) -> Gen ErrorPolicy
genErrorPolicy (Gen DiffTime -> Gen (SuspendDecision DiffTime)
forall t. Gen t -> Gen (SuspendDecision t)
genSuspendDecision Gen DiffTime
genDiffTime)

    shrink :: ArbErrorPolicies -> [ArbErrorPolicies]
shrink (ArbErrorPolicies [ErrorPolicy]
aps [ErrorPolicy]
cps) =
        let aps' :: [[ErrorPolicy]]
aps' = (ErrorPolicy -> [ErrorPolicy]) -> [ErrorPolicy] -> [[ErrorPolicy]]
forall a. (a -> [a]) -> [a] -> [[a]]
shrinkList ([ErrorPolicy] -> ErrorPolicy -> [ErrorPolicy]
forall a b. a -> b -> a
const []) [ErrorPolicy]
aps
            cps' :: [[ErrorPolicy]]
cps' = (ErrorPolicy -> [ErrorPolicy]) -> [ErrorPolicy] -> [[ErrorPolicy]]
forall a. (a -> [a]) -> [a] -> [[a]]
shrinkList ([ErrorPolicy] -> ErrorPolicy -> [ErrorPolicy]
forall a b. a -> b -> a
const []) [ErrorPolicy]
cps in
        (([ErrorPolicy], [ErrorPolicy]) -> ArbErrorPolicies)
-> [([ErrorPolicy], [ErrorPolicy])] -> [ArbErrorPolicies]
forall a b. (a -> b) -> [a] -> [b]
map (\([ErrorPolicy]
a,[ErrorPolicy]
c) -> [ErrorPolicy] -> [ErrorPolicy] -> ArbErrorPolicies
ArbErrorPolicies [ErrorPolicy]
a [ErrorPolicy]
c) ([([ErrorPolicy], [ErrorPolicy])] -> [ArbErrorPolicies])
-> [([ErrorPolicy], [ErrorPolicy])] -> [ArbErrorPolicies]
forall a b. (a -> b) -> a -> b
$ [[ErrorPolicy]]
-> [[ErrorPolicy]] -> [([ErrorPolicy], [ErrorPolicy])]
forall a b. [a] -> [b] -> [(a, b)]
zip [[ErrorPolicy]]
aps' [[ErrorPolicy]]
cps'

data Sock addr = Sock {
    forall addr. Sock addr -> addr
remoteAddr :: addr
  , forall addr. Sock addr -> addr
localAddr  :: addr
  }

data SnocketType where

     -- socket which allocates and connects with out an error, any error can
     -- only come from an application
     WorkingSnocket :: SnocketType

     -- socket which errors when allocating a socket
     AllocateError :: forall e. Exception e
                   => e
                   -> SnocketType

     -- socket which errors when attempting a connection
     ConnectError :: forall e. Exception e
                  => e
                  -> SnocketType

instance Show SnocketType where
    show :: SnocketType -> String
show (AllocateError e
e) = String
"AllocateError " String -> String -> String
forall a. [a] -> [a] -> [a]
++e -> String
forall a. Show a => a -> String
show e
e
    show (ConnectError e
e)  = String
"ConnectError " String -> String -> String
forall a. [a] -> [a] -> [a]
++e -> String
forall a. Show a => a -> String
show e
e
    show SnocketType
WorkingSnocket    = String
"WorkingSnocket"

instance Arbitrary SnocketType where
    arbitrary :: Gen SnocketType
arbitrary = [Gen SnocketType] -> Gen SnocketType
forall a. [Gen a] -> Gen a
oneof
      -- we are not generating 'AllocateErrors', they will not kill the worker,
      -- but only the connection thread.
      [ (\(ArbException err
e) -> err -> SnocketType
forall e. Exception e => e -> SnocketType
ConnectError err
e) (ArbException -> SnocketType)
-> Gen ArbException -> Gen SnocketType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen ArbException
forall a. Arbitrary a => Gen a
arbitrary
      , SnocketType -> Gen SnocketType
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SnocketType
WorkingSnocket
      ]

-- | 'addrFamily', 'accept' is not needed to run the test suite.
--
mkSnocket :: MonadThrow m
          => SnocketType
          -> addr
          -> addr
          -> Snocket m (Sock addr) addr
mkSnocket :: forall (m :: * -> *) addr.
MonadThrow m =>
SnocketType -> addr -> addr -> Snocket m (Sock addr) addr
mkSnocket (AllocateError e
e) addr
_localAddr addr
_remoteAddr = Snocket {
    getLocalAddr :: Sock addr -> m addr
getLocalAddr = \Sock{addr
localAddr :: forall addr. Sock addr -> addr
localAddr :: addr
localAddr} -> addr -> m addr
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure addr
localAddr
  , getRemoteAddr :: Sock addr -> m addr
getRemoteAddr = \Sock{remoteAddr :: forall addr. Sock addr -> addr
remoteAddr = addr
addr} -> addr -> m addr
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure addr
addr
  , addrFamily :: addr -> AddressFamily addr
addrFamily = String -> addr -> AddressFamily addr
forall a. HasCallStack => String -> a
error String
"not supported"
  , open :: AddressFamily addr -> m (Sock addr)
open = \AddressFamily addr
_ -> e -> m (Sock addr)
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO e
e
  , openToConnect :: addr -> m (Sock addr)
openToConnect = \addr
_  -> e -> m (Sock addr)
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO e
e
  , connect :: Sock addr -> addr -> m ()
connect = \Sock addr
_ addr
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  , bind :: Sock addr -> addr -> m ()
bind = \Sock addr
_ addr
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  , listen :: Sock addr -> m ()
listen = \Sock addr
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  , accept :: Sock addr -> m (Accept m (Sock addr) addr)
accept = \Sock addr
_ -> String -> m (Accept m (Sock addr) addr)
forall a. HasCallStack => String -> a
error String
"not supported"
  , close :: Sock addr -> m ()
close = \Sock addr
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  }
mkSnocket (ConnectError e
e) addr
localAddr addr
remoteAddr = Snocket {
    getLocalAddr :: Sock addr -> m addr
getLocalAddr = \Sock{localAddr :: forall addr. Sock addr -> addr
localAddr = addr
addr} -> addr -> m addr
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure addr
addr
  , getRemoteAddr :: Sock addr -> m addr
getRemoteAddr = \Sock{remoteAddr :: forall addr. Sock addr -> addr
remoteAddr = addr
addr} -> addr -> m addr
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure addr
addr
  , addrFamily :: addr -> AddressFamily addr
addrFamily = String -> addr -> AddressFamily addr
forall a. HasCallStack => String -> a
error String
"not supported"
  , open :: AddressFamily addr -> m (Sock addr)
open = \AddressFamily addr
_ -> Sock addr -> m (Sock addr)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Sock {addr
remoteAddr :: addr
remoteAddr :: addr
remoteAddr, addr
localAddr :: addr
localAddr :: addr
localAddr}
  , openToConnect :: addr -> m (Sock addr)
openToConnect = \addr
_ -> Sock addr -> m (Sock addr)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Sock {addr
remoteAddr :: addr
remoteAddr :: addr
remoteAddr, addr
localAddr :: addr
localAddr :: addr
localAddr}
  , connect :: Sock addr -> addr -> m ()
connect = \Sock addr
_ addr
_ -> e -> m ()
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO e
e
  , accept :: Sock addr -> m (Accept m (Sock addr) addr)
accept = \Sock addr
_ -> String -> m (Accept m (Sock addr) addr)
forall a. HasCallStack => String -> a
error String
"not supported"
  , bind :: Sock addr -> addr -> m ()
bind = \Sock addr
_ addr
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  , listen :: Sock addr -> m ()
listen = \Sock addr
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  , close :: Sock addr -> m ()
close = \Sock addr
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  }
mkSnocket SnocketType
WorkingSnocket addr
localAddr addr
remoteAddr = Snocket {
    getLocalAddr :: Sock addr -> m addr
getLocalAddr = \Sock{localAddr :: forall addr. Sock addr -> addr
localAddr = addr
addr} -> addr -> m addr
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure addr
addr
  , getRemoteAddr :: Sock addr -> m addr
getRemoteAddr = \Sock{remoteAddr :: forall addr. Sock addr -> addr
remoteAddr = addr
addr} -> addr -> m addr
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure addr
addr
  , addrFamily :: addr -> AddressFamily addr
addrFamily = String -> addr -> AddressFamily addr
forall a. HasCallStack => String -> a
error String
"not supported"
  , open :: AddressFamily addr -> m (Sock addr)
open = \AddressFamily addr
_ -> Sock addr -> m (Sock addr)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Sock {addr
remoteAddr :: addr
remoteAddr :: addr
remoteAddr, addr
localAddr :: addr
localAddr :: addr
localAddr}
  , openToConnect :: addr -> m (Sock addr)
openToConnect = \addr
_ -> Sock addr -> m (Sock addr)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Sock {addr
remoteAddr :: addr
remoteAddr :: addr
remoteAddr, addr
localAddr :: addr
localAddr :: addr
localAddr}
  , connect :: Sock addr -> addr -> m ()
connect = \Sock addr
_ addr
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  , bind :: Sock addr -> addr -> m ()
bind = \Sock addr
_ addr
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  , listen :: Sock addr -> m ()
listen = \Sock addr
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  , accept :: Sock addr -> m (Accept m (Sock addr) addr)
accept = \Sock addr
_ -> String -> m (Accept m (Sock addr) addr)
forall a. HasCallStack => String -> a
error String
"not supported"
  , close :: Sock addr -> m ()
close = \Sock addr
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  }

data ArbApp addr = ArbApp (Maybe ArbException) (Sock addr -> IO ())

instance Arbitrary (ArbApp addr) where
    arbitrary :: Gen (ArbApp addr)
arbitrary = [Gen (ArbApp addr)] -> Gen (ArbApp addr)
forall a. [Gen a] -> Gen a
oneof
      [ (\a :: ArbException
a@(ArbException err
e) -> Maybe ArbException -> (Sock addr -> IO ()) -> ArbApp addr
forall addr.
Maybe ArbException -> (Sock addr -> IO ()) -> ArbApp addr
ArbApp (ArbException -> Maybe ArbException
forall a. a -> Maybe a
Just ArbException
a) (\Sock addr
_ -> err -> IO ()
forall e a. Exception e => e -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO err
e)) (ArbException -> ArbApp addr)
-> Gen ArbException -> Gen (ArbApp addr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen ArbException
forall a. Arbitrary a => Gen a
arbitrary
      , ArbApp addr -> Gen (ArbApp addr)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ArbApp addr -> Gen (ArbApp addr))
-> ArbApp addr -> Gen (ArbApp addr)
forall a b. (a -> b) -> a -> b
$ Maybe ArbException -> (Sock addr -> IO ()) -> ArbApp addr
forall addr.
Maybe ArbException -> (Sock addr -> IO ()) -> ArbApp addr
ArbApp Maybe ArbException
forall a. Maybe a
Nothing (\Sock addr
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
      ]

newtype ArbDiffTime = ArbDiffTime {
    ArbDiffTime -> DiffTime
getArbDiffTime :: DiffTime
  }
  deriving Int -> ArbDiffTime -> String -> String
[ArbDiffTime] -> String -> String
ArbDiffTime -> String
(Int -> ArbDiffTime -> String -> String)
-> (ArbDiffTime -> String)
-> ([ArbDiffTime] -> String -> String)
-> Show ArbDiffTime
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> ArbDiffTime -> String -> String
showsPrec :: Int -> ArbDiffTime -> String -> String
$cshow :: ArbDiffTime -> String
show :: ArbDiffTime -> String
$cshowList :: [ArbDiffTime] -> String -> String
showList :: [ArbDiffTime] -> String -> String
Show
  deriving ArbDiffTime -> ArbDiffTime -> Bool
(ArbDiffTime -> ArbDiffTime -> Bool)
-> (ArbDiffTime -> ArbDiffTime -> Bool) -> Eq ArbDiffTime
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ArbDiffTime -> ArbDiffTime -> Bool
== :: ArbDiffTime -> ArbDiffTime -> Bool
$c/= :: ArbDiffTime -> ArbDiffTime -> Bool
/= :: ArbDiffTime -> ArbDiffTime -> Bool
Eq
  deriving Eq ArbDiffTime
Eq ArbDiffTime =>
(ArbDiffTime -> ArbDiffTime -> Ordering)
-> (ArbDiffTime -> ArbDiffTime -> Bool)
-> (ArbDiffTime -> ArbDiffTime -> Bool)
-> (ArbDiffTime -> ArbDiffTime -> Bool)
-> (ArbDiffTime -> ArbDiffTime -> Bool)
-> (ArbDiffTime -> ArbDiffTime -> ArbDiffTime)
-> (ArbDiffTime -> ArbDiffTime -> ArbDiffTime)
-> Ord ArbDiffTime
ArbDiffTime -> ArbDiffTime -> Bool
ArbDiffTime -> ArbDiffTime -> Ordering
ArbDiffTime -> ArbDiffTime -> ArbDiffTime
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
$ccompare :: ArbDiffTime -> ArbDiffTime -> Ordering
compare :: ArbDiffTime -> ArbDiffTime -> Ordering
$c< :: ArbDiffTime -> ArbDiffTime -> Bool
< :: ArbDiffTime -> ArbDiffTime -> Bool
$c<= :: ArbDiffTime -> ArbDiffTime -> Bool
<= :: ArbDiffTime -> ArbDiffTime -> Bool
$c> :: ArbDiffTime -> ArbDiffTime -> Bool
> :: ArbDiffTime -> ArbDiffTime -> Bool
$c>= :: ArbDiffTime -> ArbDiffTime -> Bool
>= :: ArbDiffTime -> ArbDiffTime -> Bool
$cmax :: ArbDiffTime -> ArbDiffTime -> ArbDiffTime
max :: ArbDiffTime -> ArbDiffTime -> ArbDiffTime
$cmin :: ArbDiffTime -> ArbDiffTime -> ArbDiffTime
min :: ArbDiffTime -> ArbDiffTime -> ArbDiffTime
Ord
  deriving Integer -> ArbDiffTime
ArbDiffTime -> ArbDiffTime
ArbDiffTime -> ArbDiffTime -> ArbDiffTime
(ArbDiffTime -> ArbDiffTime -> ArbDiffTime)
-> (ArbDiffTime -> ArbDiffTime -> ArbDiffTime)
-> (ArbDiffTime -> ArbDiffTime -> ArbDiffTime)
-> (ArbDiffTime -> ArbDiffTime)
-> (ArbDiffTime -> ArbDiffTime)
-> (ArbDiffTime -> ArbDiffTime)
-> (Integer -> ArbDiffTime)
-> Num ArbDiffTime
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
$c+ :: ArbDiffTime -> ArbDiffTime -> ArbDiffTime
+ :: ArbDiffTime -> ArbDiffTime -> ArbDiffTime
$c- :: ArbDiffTime -> ArbDiffTime -> ArbDiffTime
- :: ArbDiffTime -> ArbDiffTime -> ArbDiffTime
$c* :: ArbDiffTime -> ArbDiffTime -> ArbDiffTime
* :: ArbDiffTime -> ArbDiffTime -> ArbDiffTime
$cnegate :: ArbDiffTime -> ArbDiffTime
negate :: ArbDiffTime -> ArbDiffTime
$cabs :: ArbDiffTime -> ArbDiffTime
abs :: ArbDiffTime -> ArbDiffTime
$csignum :: ArbDiffTime -> ArbDiffTime
signum :: ArbDiffTime -> ArbDiffTime
$cfromInteger :: Integer -> ArbDiffTime
fromInteger :: Integer -> ArbDiffTime
Num        via DiffTime
  deriving Num ArbDiffTime
Num ArbDiffTime =>
(ArbDiffTime -> ArbDiffTime -> ArbDiffTime)
-> (ArbDiffTime -> ArbDiffTime)
-> (Rational -> ArbDiffTime)
-> Fractional ArbDiffTime
Rational -> ArbDiffTime
ArbDiffTime -> ArbDiffTime
ArbDiffTime -> ArbDiffTime -> ArbDiffTime
forall a.
Num a =>
(a -> a -> a) -> (a -> a) -> (Rational -> a) -> Fractional a
$c/ :: ArbDiffTime -> ArbDiffTime -> ArbDiffTime
/ :: ArbDiffTime -> ArbDiffTime -> ArbDiffTime
$crecip :: ArbDiffTime -> ArbDiffTime
recip :: ArbDiffTime -> ArbDiffTime
$cfromRational :: Rational -> ArbDiffTime
fromRational :: Rational -> ArbDiffTime
Fractional via DiffTime
  deriving Num ArbDiffTime
Ord ArbDiffTime
(Num ArbDiffTime, Ord ArbDiffTime) =>
(ArbDiffTime -> Rational) -> Real ArbDiffTime
ArbDiffTime -> Rational
forall a. (Num a, Ord a) => (a -> Rational) -> Real a
$ctoRational :: ArbDiffTime -> Rational
toRational :: ArbDiffTime -> Rational
Real       via DiffTime
  deriving Fractional ArbDiffTime
Real ArbDiffTime
(Real ArbDiffTime, Fractional ArbDiffTime) =>
(forall b. Integral b => ArbDiffTime -> (b, ArbDiffTime))
-> (forall b. Integral b => ArbDiffTime -> b)
-> (forall b. Integral b => ArbDiffTime -> b)
-> (forall b. Integral b => ArbDiffTime -> b)
-> (forall b. Integral b => ArbDiffTime -> b)
-> RealFrac ArbDiffTime
forall b. Integral b => ArbDiffTime -> b
forall b. Integral b => ArbDiffTime -> (b, ArbDiffTime)
forall a.
(Real a, Fractional a) =>
(forall b. Integral b => a -> (b, a))
-> (forall b. Integral b => a -> b)
-> (forall b. Integral b => a -> b)
-> (forall b. Integral b => a -> b)
-> (forall b. Integral b => a -> b)
-> RealFrac a
$cproperFraction :: forall b. Integral b => ArbDiffTime -> (b, ArbDiffTime)
properFraction :: forall b. Integral b => ArbDiffTime -> (b, ArbDiffTime)
$ctruncate :: forall b. Integral b => ArbDiffTime -> b
truncate :: forall b. Integral b => ArbDiffTime -> b
$cround :: forall b. Integral b => ArbDiffTime -> b
round :: forall b. Integral b => ArbDiffTime -> b
$cceiling :: forall b. Integral b => ArbDiffTime -> b
ceiling :: forall b. Integral b => ArbDiffTime -> b
$cfloor :: forall b. Integral b => ArbDiffTime -> b
floor :: forall b. Integral b => ArbDiffTime -> b
RealFrac   via DiffTime

instance Arbitrary ArbDiffTime where
    arbitrary :: Gen ArbDiffTime
arbitrary = DiffTime -> ArbDiffTime
ArbDiffTime (DiffTime -> ArbDiffTime)
-> (Int -> DiffTime) -> Int -> ArbDiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral @Int (Int -> ArbDiffTime) -> Gen Int -> Gen ArbDiffTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Int
forall a. Arbitrary a => Gen a
arbitrary

instance CoArbitrary ArbDiffTime where
    coarbitrary :: forall b. ArbDiffTime -> Gen b -> Gen b
coarbitrary (ArbDiffTime DiffTime
t) = Rational -> Gen b -> Gen b
forall b. Rational -> Gen b -> Gen b
forall a b. CoArbitrary a => a -> Gen b -> Gen b
coarbitrary (DiffTime -> Rational
forall a. Real a => a -> Rational
toRational DiffTime
t)

instance Function ArbDiffTime where
    function :: forall b. (ArbDiffTime -> b) -> ArbDiffTime :-> b
function = (ArbDiffTime -> b) -> ArbDiffTime :-> b
forall a b. RealFrac a => (a -> b) -> a :-> b
functionRealFrac

newtype ArbTime = ArbTime { ArbTime -> Time
getArbTime :: Time }
  deriving Int -> ArbTime -> String -> String
[ArbTime] -> String -> String
ArbTime -> String
(Int -> ArbTime -> String -> String)
-> (ArbTime -> String)
-> ([ArbTime] -> String -> String)
-> Show ArbTime
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> ArbTime -> String -> String
showsPrec :: Int -> ArbTime -> String -> String
$cshow :: ArbTime -> String
show :: ArbTime -> String
$cshowList :: [ArbTime] -> String -> String
showList :: [ArbTime] -> String -> String
Show
  deriving ArbTime -> ArbTime -> Bool
(ArbTime -> ArbTime -> Bool)
-> (ArbTime -> ArbTime -> Bool) -> Eq ArbTime
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ArbTime -> ArbTime -> Bool
== :: ArbTime -> ArbTime -> Bool
$c/= :: ArbTime -> ArbTime -> Bool
/= :: ArbTime -> ArbTime -> Bool
Eq
  deriving Eq ArbTime
Eq ArbTime =>
(ArbTime -> ArbTime -> Ordering)
-> (ArbTime -> ArbTime -> Bool)
-> (ArbTime -> ArbTime -> Bool)
-> (ArbTime -> ArbTime -> Bool)
-> (ArbTime -> ArbTime -> Bool)
-> (ArbTime -> ArbTime -> ArbTime)
-> (ArbTime -> ArbTime -> ArbTime)
-> Ord ArbTime
ArbTime -> ArbTime -> Bool
ArbTime -> ArbTime -> Ordering
ArbTime -> ArbTime -> ArbTime
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
$ccompare :: ArbTime -> ArbTime -> Ordering
compare :: ArbTime -> ArbTime -> Ordering
$c< :: ArbTime -> ArbTime -> Bool
< :: ArbTime -> ArbTime -> Bool
$c<= :: ArbTime -> ArbTime -> Bool
<= :: ArbTime -> ArbTime -> Bool
$c> :: ArbTime -> ArbTime -> Bool
> :: ArbTime -> ArbTime -> Bool
$c>= :: ArbTime -> ArbTime -> Bool
>= :: ArbTime -> ArbTime -> Bool
$cmax :: ArbTime -> ArbTime -> ArbTime
max :: ArbTime -> ArbTime -> ArbTime
$cmin :: ArbTime -> ArbTime -> ArbTime
min :: ArbTime -> ArbTime -> ArbTime
Ord
  deriving Integer -> ArbTime
ArbTime -> ArbTime
ArbTime -> ArbTime -> ArbTime
(ArbTime -> ArbTime -> ArbTime)
-> (ArbTime -> ArbTime -> ArbTime)
-> (ArbTime -> ArbTime -> ArbTime)
-> (ArbTime -> ArbTime)
-> (ArbTime -> ArbTime)
-> (ArbTime -> ArbTime)
-> (Integer -> ArbTime)
-> Num ArbTime
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
$c+ :: ArbTime -> ArbTime -> ArbTime
+ :: ArbTime -> ArbTime -> ArbTime
$c- :: ArbTime -> ArbTime -> ArbTime
- :: ArbTime -> ArbTime -> ArbTime
$c* :: ArbTime -> ArbTime -> ArbTime
* :: ArbTime -> ArbTime -> ArbTime
$cnegate :: ArbTime -> ArbTime
negate :: ArbTime -> ArbTime
$cabs :: ArbTime -> ArbTime
abs :: ArbTime -> ArbTime
$csignum :: ArbTime -> ArbTime
signum :: ArbTime -> ArbTime
$cfromInteger :: Integer -> ArbTime
fromInteger :: Integer -> ArbTime
Num        via DiffTime
  deriving Num ArbTime
Num ArbTime =>
(ArbTime -> ArbTime -> ArbTime)
-> (ArbTime -> ArbTime)
-> (Rational -> ArbTime)
-> Fractional ArbTime
Rational -> ArbTime
ArbTime -> ArbTime
ArbTime -> ArbTime -> ArbTime
forall a.
Num a =>
(a -> a -> a) -> (a -> a) -> (Rational -> a) -> Fractional a
$c/ :: ArbTime -> ArbTime -> ArbTime
/ :: ArbTime -> ArbTime -> ArbTime
$crecip :: ArbTime -> ArbTime
recip :: ArbTime -> ArbTime
$cfromRational :: Rational -> ArbTime
fromRational :: Rational -> ArbTime
Fractional via DiffTime
  deriving Num ArbTime
Ord ArbTime
(Num ArbTime, Ord ArbTime) => (ArbTime -> Rational) -> Real ArbTime
ArbTime -> Rational
forall a. (Num a, Ord a) => (a -> Rational) -> Real a
$ctoRational :: ArbTime -> Rational
toRational :: ArbTime -> Rational
Real       via DiffTime
  deriving Fractional ArbTime
Real ArbTime
(Real ArbTime, Fractional ArbTime) =>
(forall b. Integral b => ArbTime -> (b, ArbTime))
-> (forall b. Integral b => ArbTime -> b)
-> (forall b. Integral b => ArbTime -> b)
-> (forall b. Integral b => ArbTime -> b)
-> (forall b. Integral b => ArbTime -> b)
-> RealFrac ArbTime
forall b. Integral b => ArbTime -> b
forall b. Integral b => ArbTime -> (b, ArbTime)
forall a.
(Real a, Fractional a) =>
(forall b. Integral b => a -> (b, a))
-> (forall b. Integral b => a -> b)
-> (forall b. Integral b => a -> b)
-> (forall b. Integral b => a -> b)
-> (forall b. Integral b => a -> b)
-> RealFrac a
$cproperFraction :: forall b. Integral b => ArbTime -> (b, ArbTime)
properFraction :: forall b. Integral b => ArbTime -> (b, ArbTime)
$ctruncate :: forall b. Integral b => ArbTime -> b
truncate :: forall b. Integral b => ArbTime -> b
$cround :: forall b. Integral b => ArbTime -> b
round :: forall b. Integral b => ArbTime -> b
$cceiling :: forall b. Integral b => ArbTime -> b
ceiling :: forall b. Integral b => ArbTime -> b
$cfloor :: forall b. Integral b => ArbTime -> b
floor :: forall b. Integral b => ArbTime -> b
RealFrac   via DiffTime

instance Arbitrary ArbTime where
    arbitrary :: Gen ArbTime
arbitrary = Time -> ArbTime
ArbTime (Time -> ArbTime)
-> (ArbDiffTime -> Time) -> ArbDiffTime -> ArbTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiffTime -> Time
Time (DiffTime -> Time)
-> (ArbDiffTime -> DiffTime) -> ArbDiffTime -> Time
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ArbDiffTime -> DiffTime
getArbDiffTime (ArbDiffTime -> ArbTime) -> Gen ArbDiffTime -> Gen ArbTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen ArbDiffTime
forall a. Arbitrary a => Gen a
arbitrary

instance CoArbitrary ArbTime where
    coarbitrary :: forall b. ArbTime -> Gen b -> Gen b
coarbitrary (ArbTime (Time DiffTime
t)) = Rational -> Gen b -> Gen b
forall b. Rational -> Gen b -> Gen b
forall a b. CoArbitrary a => a -> Gen b -> Gen b
coarbitrary (DiffTime -> Rational
forall a. Real a => a -> Rational
toRational DiffTime
t)

instance Function ArbTime where
    function :: forall b. (ArbTime -> b) -> ArbTime :-> b
function = (ArbTime -> b) -> ArbTime :-> b
forall a b. RealFrac a => (a -> b) -> a :-> b
functionRealFrac

prop_subscriptionWorker
    :: SnocketType
    -> Int -- local address
    -> Int -- remote address
    -> ArbValidPeerState IO
    -> ArbErrorPolicies
    -> (Blind (ArbApp Int))
    -> Property
prop_subscriptionWorker :: SnocketType
-> Int
-> Int
-> ArbValidPeerState IO
-> ArbErrorPolicies
-> Blind (ArbApp Int)
-> Property
prop_subscriptionWorker
    SnocketType
sockType Int
localAddr Int
remoteAddr (ArbValidPeerState PeerState IO
ps)
    (ArbErrorPolicies [ErrorPolicy]
appErrPolicies [ErrorPolicy]
conErrPolicies)
    (Blind (ArbApp Maybe ArbException
merr Sock Int -> IO ()
app))
  =
    String -> [String] -> Property -> Property
forall prop.
Testable prop =>
String -> [String] -> prop -> Property
tabulate String
"peer states & app errors" [String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"%-20s %s" (PeerState IO -> String
forall {m :: * -> *}. PeerState m -> String
peerStateType PeerState IO
ps) (Maybe ArbException -> String
forall {a}. Maybe a -> String
exceptionType Maybe ArbException
merr)] (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    IO Bool -> Property
forall prop. Testable prop => IO prop -> Property
ioProperty (IO Bool -> Property) -> IO Bool -> Property
forall a b. (a -> b) -> a -> b
$ do
      doneVar :: StrictTMVar IO () <- IO (StrictTMVar IO ())
forall (m :: * -> *) a. MonadSTM m => m (StrictTMVar m a)
newEmptyTMVarIO
      tbl <- newConnectionTable
      peerStatesVar <- newPeerStatesVar
      worker nullTracer
             nullTracer
             tbl
             peerStatesVar
             (mkSnocket sockType localAddr remoteAddr)
             mempty
             WorkerCallbacks {
                 wcSocketStateChangeTx = \SocketState IO Int
ss PeerStates IO Int
s -> do
                   s' <- SocketStateChange IO (PeerStates IO Int) Int
forall addr.
Ord addr =>
SocketStateChange IO (PeerStates IO addr) addr
socketStateChangeTx SocketState IO Int
ss PeerStates IO Int
s
                   case ss of
                     CreatedSocket{} -> PeerStates IO Int -> STM (PeerStates IO Int)
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PeerStates IO Int
s'
                     ClosedSocket{}  -> StrictTMVar IO () -> () -> STM IO Bool
forall (m :: * -> *) a.
MonadSTM m =>
StrictTMVar m a -> a -> STM m Bool
tryPutTMVar StrictTMVar IO ()
doneVar () STM Bool -> STM (PeerStates IO Int) -> STM (PeerStates IO Int)
forall a b. STM a -> STM b -> STM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> PeerStates IO Int -> STM (PeerStates IO Int)
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PeerStates IO Int
s',
                 wcCompleteApplicationTx = completeTx,
                 wcMainTx = main doneVar
               }
             WorkerParams {
                 wpLocalAddresses = LocalAddresses {
                     laIpv4 = Just localAddr,
                     laIpv6 = Just localAddr,
                     laUnix = Nothing
                   },
                 wpSelectAddress = \Int
_ LocalAddresses {Maybe Int
laIpv4 :: forall addr. LocalAddresses addr -> Maybe addr
laIpv4 :: Maybe Int
laIpv4, Maybe Int
laIpv6 :: forall addr. LocalAddresses addr -> Maybe addr
laIpv6 :: Maybe Int
laIpv6} -> First Int -> Maybe Int
forall a. First a -> Maybe a
getFirst (Maybe Int -> First Int
forall a. Maybe a -> First a
First Maybe Int
laIpv4 First Int -> First Int -> First Int
forall a. Semigroup a => a -> a -> a
<> Maybe Int -> First Int
forall a. Maybe a -> First a
First Maybe Int
laIpv6),
                 wpConnectionAttemptDelay = const Nothing,
                 wpSubscriptionTarget =
                   pure $ ipSubscriptionTarget nullTracer peerStatesVar [remoteAddr],
                 wpValency = 1
               }
             (\Sock Int
sock -> Sock Int -> IO ()
app Sock Int
sock
                IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
forall (m :: * -> *) a b. MonadThrow m => m a -> m b -> m a
`finally`
                (IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ STM IO Bool -> IO Bool
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM IO Bool -> IO Bool) -> STM IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ StrictTMVar IO () -> () -> STM IO Bool
forall (m :: * -> *) a.
MonadSTM m =>
StrictTMVar m a -> a -> STM m Bool
tryPutTMVar StrictTMVar IO ()
doneVar ()))
  where
    completeTx :: CompleteApplication IO (PeerStates IO Int) Int ()
completeTx = ErrorPolicies -> CompleteApplication IO (PeerStates IO Int) Int ()
forall (m :: * -> *) addr a.
(MonadAsync m, Ord addr, Ord (Async m ())) =>
ErrorPolicies -> CompleteApplication m (PeerStates m addr) addr a
completeApplicationTx
       ([ErrorPolicy] -> [ErrorPolicy] -> ErrorPolicies
ErrorPolicies
          [ErrorPolicy]
appErrPolicies
          [ErrorPolicy]
conErrPolicies)

    main :: StrictTMVar IO () -> Main IO (PeerStates IO Int) Bool
    main :: StrictTMVar IO () -> Main IO (PeerStates IO Int) Bool
main StrictTMVar IO ()
doneVar PeerStates IO Int
s = do
      done <- Bool -> (() -> Bool) -> Maybe () -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Bool -> () -> Bool
forall a b. a -> b -> a
const Bool
True) (Maybe () -> Bool) -> STM (Maybe ()) -> STM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTMVar IO () -> STM IO (Maybe ())
forall (m :: * -> *) a.
MonadSTM m =>
StrictTMVar m a -> STM m (Maybe a)
tryReadTMVar StrictTMVar IO ()
doneVar
      let r = case SnocketType
sockType of
            SnocketType
WorkingSnocket   -> case Maybe ArbException
merr of
              -- TODO: we don't have access to the time when the transition was
              -- evaluated.
              Maybe ArbException
Nothing -> Bool
True
              Just (ArbException err
e) -> Int
-> PeerState IO
-> Maybe (SuspendDecision DiffTime)
-> PeerStates IO Int
-> Bool
forall addr.
Ord addr =>
addr
-> PeerState IO
-> Maybe (SuspendDecision DiffTime)
-> PeerStates IO addr
-> Bool
transitionSpec Int
remoteAddr PeerState IO
ps
                                                      (err -> [ErrorPolicy] -> Maybe (SuspendDecision DiffTime)
forall e.
Exception e =>
e -> [ErrorPolicy] -> Maybe (SuspendDecision DiffTime)
evalErrorPolicies err
e [ErrorPolicy]
appErrPolicies)
                                                      PeerStates IO Int
s
            AllocateError e
_ -> Bool
True
            ConnectError e
e  -> Int
-> PeerState IO
-> Maybe (SuspendDecision DiffTime)
-> PeerStates IO Int
-> Bool
forall addr.
Ord addr =>
addr
-> PeerState IO
-> Maybe (SuspendDecision DiffTime)
-> PeerStates IO addr
-> Bool
transitionSpec Int
remoteAddr PeerState IO
ps
                                              (e -> [ErrorPolicy] -> Maybe (SuspendDecision DiffTime)
forall e.
Exception e =>
e -> [ErrorPolicy] -> Maybe (SuspendDecision DiffTime)
evalErrorPolicies e
e [ErrorPolicy]
conErrPolicies)
                                              PeerStates IO Int
s
      if done
        then pure r
        else if r then retry else pure r

    --
    -- tabulating QuickCheck's cases
    --

    peerStateType :: PeerState m -> String
peerStateType HotPeer{}           = String
"HotPeer"
    peerStateType SuspendedConsumer{} = String
"SuspendedConsumer"
    peerStateType SuspendedPeer{}     = String
"SuspendedPeer"
    peerStateType ColdPeer{}          = String
"ColdPeer"

    exceptionType :: Maybe a -> String
exceptionType Maybe a
Nothing  = String
"no-exception"
    exceptionType (Just a
_) = String
"with-exception"

-- transition spec from a given state to a target states
transitionSpec :: Ord addr
               => addr
               -> PeerState IO
               -> Maybe (SuspendDecision DiffTime)
               -> PeerStates IO addr
               -> Bool

transitionSpec :: forall addr.
Ord addr =>
addr
-> PeerState IO
-> Maybe (SuspendDecision DiffTime)
-> PeerStates IO addr
-> Bool
transitionSpec addr
_addr PeerState IO
_ps0 Maybe (SuspendDecision DiffTime)
Nothing ThrowException{} = Bool
False

transitionSpec addr
addr PeerState IO
ps0 Maybe (SuspendDecision DiffTime)
Nothing (PeerStates Map addr (PeerState IO)
peerStates) =
    case addr -> Map addr (PeerState IO) -> Maybe (PeerState IO)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup addr
addr Map addr (PeerState IO)
peerStates of
      Maybe (PeerState IO)
Nothing -> Bool
True
      Just PeerState IO
ps1 -> case (PeerState IO
ps0, PeerState IO
ps1) of
        (PeerState IO
ColdPeer, PeerState IO
ColdPeer)
          -> Bool
True
        (PeerState IO
ColdPeer, HotPeer Set (Async IO ())
producers Set (Async IO ())
consumers)
          -> Bool -> Bool
not (Set (Async ()) -> Bool
forall a. Set a -> Bool
Set.null Set (Async ())
Set (Async IO ())
producers) Bool -> Bool -> Bool
|| Bool -> Bool
not (Set (Async ()) -> Bool
forall a. Set a -> Bool
Set.null Set (Async ())
Set (Async IO ())
consumers)
        (PeerState IO
ColdPeer, PeerState IO
_)
          -> Bool
False

        -- this transition can happen only if 'producers' are empty
        (SuspendedConsumer Set (Async IO ())
producers Time
_consT, PeerState IO
ColdPeer)
          | Set (Async ()) -> Bool
forall a. Set a -> Bool
Set.null Set (Async ())
Set (Async IO ())
producers
          -> Bool
True
          | Bool
otherwise
          -> Bool
False
        (SuspendedConsumer Set (Async IO ())
_ Time
consT, SuspendedConsumer Set (Async IO ())
_ Time
consT')
          -> Time
consT Time -> Time -> Bool
forall a. Eq a => a -> a -> Bool
== Time
consT'
        (SuspendedConsumer Set (Async IO ())
_ Time
_consT, HotPeer Set (Async IO ())
_ Set (Async IO ())
consumers)
          -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Set (Async ()) -> Bool
forall a. Set a -> Bool
Set.null Set (Async ())
Set (Async IO ())
consumers
        (SuspendedConsumer Set (Async IO ())
_ Time
consT, SuspendedPeer Time
_ Time
consT')
          -> Time
consT' Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
>= Time
consT

        (SuspendedPeer{}, HotPeer Set (Async IO ())
producers Set (Async IO ())
consumers)
          | Set (Async ()) -> Bool
forall a. Set a -> Bool
Set.null Set (Async ())
Set (Async IO ())
producers Bool -> Bool -> Bool
&& Set (Async ()) -> Bool
forall a. Set a -> Bool
Set.null Set (Async ())
Set (Async IO ())
consumers
          -> Bool
False
          | Bool
otherwise
          -> Bool
True
        (SuspendedPeer{}, PeerState IO
_)
          -> Bool
True

        (HotPeer Set (Async IO ())
producers Set (Async IO ())
consumers, PeerState IO
ColdPeer)
          | Set (Async ()) -> Bool
forall a. Set a -> Bool
Set.null Set (Async ())
Set (Async IO ())
consumers Bool -> Bool -> Bool
&& Set (Async ()) -> Bool
forall a. Set a -> Bool
Set.null Set (Async ())
Set (Async IO ())
producers
          -> Bool
True
          | Bool
otherwise
          -> Bool
False
        (HotPeer{}, HotPeer Set (Async IO ())
producers Set (Async IO ())
consumers)
          | Set (Async ()) -> Bool
forall a. Set a -> Bool
Set.null Set (Async ())
Set (Async IO ())
producers Bool -> Bool -> Bool
&& Set (Async ()) -> Bool
forall a. Set a -> Bool
Set.null Set (Async ())
Set (Async IO ())
consumers
          -> Bool
False
          | Bool
otherwise
          -> Bool
True
        (HotPeer{}, SuspendedConsumer{})
          -> Bool
True
        (HotPeer{}, SuspendedPeer{})
          -> Bool
True

transitionSpec addr
_addr PeerState IO
_ps0 (Just SuspendDecision DiffTime
Throw) ThrowException{} = Bool
True
transitionSpec addr
_addr PeerState IO
_ps0 (Just SuspendDecision DiffTime
_)     ThrowException{} = Bool
False

transitionSpec addr
addr PeerState IO
ps0 (Just SuspendDecision DiffTime
cmd) (PeerStates Map addr (PeerState IO)
peerStates) =
    case addr -> Map addr (PeerState IO) -> Maybe (PeerState IO)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup addr
addr Map addr (PeerState IO)
peerStates of
      Maybe (PeerState IO)
Nothing -> Bool
True
      Just PeerState IO
ps1 -> case (SuspendDecision DiffTime
cmd, PeerState IO
ps1) of
        (SuspendPeer{}, SuspendedPeer{})
          -> Bool
True
        (SuspendPeer{}, PeerState IO
_)
          -> Bool
False
        (SuspendConsumer{}, SuspendedConsumer Set (Async IO ())
producers Time
_)
          -> PeerState IO -> Set (Async IO ())
getProducers PeerState IO
ps0 Set (Async ()) -> Set (Async ()) -> Bool
forall a. Eq a => a -> a -> Bool
== Set (Async ())
Set (Async IO ())
producers
        (SuspendConsumer{}, SuspendedPeer{})
          -> Bool
True
        (SuspendConsumer{}, PeerState IO
_)
          -> Bool
False
        (SuspendDecision DiffTime
Throw, PeerState IO
_)
          -> Bool
True
  where
    getProducers :: PeerState IO -> Set.Set (Async IO ())
    getProducers :: PeerState IO -> Set (Async IO ())
getProducers (HotPeer Set (Async IO ())
producers Set (Async IO ())
_)           = Set (Async IO ())
producers
    getProducers (SuspendedConsumer Set (Async IO ())
producers Time
_) = Set (Async IO ())
producers
    getProducers PeerState IO
_                               = Set (Async ())
Set (Async IO ())
forall a. Set a
Set.empty