{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE DerivingVia         #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications    #-}

module Test.Ouroboros.Network.LedgerPeers where

import Codec.CBOR.FlatTerm
import Control.Concurrent.Class.MonadSTM.Strict
import Control.Exception (SomeException (..))
import Control.Monad.Class.MonadAsync
import Control.Monad.Class.MonadFork
import Control.Monad.Class.MonadSay
import Control.Monad.Class.MonadThrow
import Control.Monad.Class.MonadTime.SI
import Control.Monad.Class.MonadTimer.SI
import Control.Monad.IOSim hiding (SimResult)
import Control.Tracer (Tracer (..), nullTracer, traceWith)
import Data.Aeson
import Data.Aeson.Types as Aeson
import Data.ByteString.Char8 qualified as BS
import Data.IP qualified as IP
import Data.List as List (foldl', intercalate, isPrefixOf, nub, sortOn)
import Data.List.NonEmpty qualified as NonEmpty
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Monoid (Sum (..))
import Data.Ord (Down (..))
import Data.Ratio
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Word
import System.Random

import Network.DNS (Domain)

import Cardano.Binary
import Cardano.Slotting.Slot (SlotNo (..), WithOrigin (..))
import Ouroboros.Network.PeerSelection.LedgerPeers
import Ouroboros.Network.PeerSelection.LedgerPeers.Utils
           (recomputeRelativeStake)
import Ouroboros.Network.PeerSelection.RelayAccessPoint
import Ouroboros.Network.PeerSelection.RootPeersDNS
import Ouroboros.Network.Testing.Data.Script
import Test.Ouroboros.Network.PeerSelection.RootPeersDNS
import Test.QuickCheck
import Test.Tasty
import Test.Tasty.QuickCheck
import Text.Printf


tests :: TestTree
tests :: TestTree
tests = String -> [TestTree] -> TestTree
testGroup String
"Ouroboros.Network.LedgerPeers"
  [ String
-> (Word16
    -> NonNegative Int
    -> ArbLedgerPeersKind
    -> MockRoots
    -> DelayAndTimeoutScripts
    -> ArbitrarySlotNo
    -> ArbitraryLedgerStateJudgement
    -> Property)
-> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"Pick 100%" Word16
-> NonNegative Int
-> ArbLedgerPeersKind
-> MockRoots
-> DelayAndTimeoutScripts
-> ArbitrarySlotNo
-> ArbitraryLedgerStateJudgement
-> Property
prop_pick100
  , String
-> (LedgerPools
    -> ArbLedgerPeersKind
    -> Word16
    -> Word16
    -> MockRoots
    -> Script DNSLookupDelay
    -> ArbitrarySlotNo
    -> ArbitraryLedgerStateJudgement
    -> Property)
-> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"Pick" LedgerPools
-> ArbLedgerPeersKind
-> Word16
-> Word16
-> MockRoots
-> Script DNSLookupDelay
-> ArbitrarySlotNo
-> ArbitraryLedgerStateJudgement
-> Property
prop_pick
  , String -> (LedgerPools -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"accumulateBigLedgerStake" LedgerPools -> Property
prop_accumulateBigLedgerStake
  , String -> (LedgerPools -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"recomputeRelativeStake" LedgerPools -> Property
prop_recomputeRelativeStake
  , String
-> (ArbitrarySlotNo
    -> ArbitraryLedgerStateJudgement
    -> LedgerPools
    -> ArbitrarySlotNo
    -> Property)
-> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"getLedgerPeers invariants" ArbitrarySlotNo
-> ArbitraryLedgerStateJudgement
-> LedgerPools
-> ArbitrarySlotNo
-> Property
prop_getLedgerPeers
  , String -> (ArbitrarySlotNo -> LedgerPools -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"LedgerPeerSnapshot CBOR version 1" ArbitrarySlotNo -> LedgerPools -> Property
prop_ledgerPeerSnapshotCBORV1
  , String -> (ArbitrarySlotNo -> LedgerPools -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"LedgerPeerSnapshot JSON version 1" ArbitrarySlotNo -> LedgerPools -> Property
prop_ledgerPeerSnapshotJSONV1
  ]

newtype ArbitraryPortNumber = ArbitraryPortNumber { ArbitraryPortNumber -> PortNumber
getArbitraryPortNumber :: PortNumber }

instance Arbitrary ArbitraryPortNumber where
    arbitrary :: Gen ArbitraryPortNumber
arbitrary = [ArbitraryPortNumber] -> Gen ArbitraryPortNumber
forall a. [a] -> Gen a
elements
              ([ArbitraryPortNumber] -> Gen ArbitraryPortNumber)
-> [ArbitraryPortNumber] -> Gen ArbitraryPortNumber
forall a b. (a -> b) -> a -> b
$ (Int -> ArbitraryPortNumber) -> [Int] -> [ArbitraryPortNumber]
forall a b. (a -> b) -> [a] -> [b]
map (PortNumber -> ArbitraryPortNumber
ArbitraryPortNumber (PortNumber -> ArbitraryPortNumber)
-> (Int -> PortNumber) -> Int -> ArbitraryPortNumber
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> PortNumber
forall a. Read a => String -> a
read (String -> PortNumber) -> (Int -> String) -> Int -> PortNumber
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show)
              ([Int] -> [ArbitraryPortNumber]) -> [Int] -> [ArbitraryPortNumber]
forall a b. (a -> b) -> a -> b
$ ([Int
1000..Int
1100] :: [Int])

newtype ArbitraryRelayAccessPoint =
  ArbitraryRelayAccessPoint { ArbitraryRelayAccessPoint -> RelayAccessPoint
getArbitraryRelayAccessPoint :: RelayAccessPoint }
  deriving (ArbitraryRelayAccessPoint -> ArbitraryRelayAccessPoint -> Bool
(ArbitraryRelayAccessPoint -> ArbitraryRelayAccessPoint -> Bool)
-> (ArbitraryRelayAccessPoint -> ArbitraryRelayAccessPoint -> Bool)
-> Eq ArbitraryRelayAccessPoint
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ArbitraryRelayAccessPoint -> ArbitraryRelayAccessPoint -> Bool
== :: ArbitraryRelayAccessPoint -> ArbitraryRelayAccessPoint -> Bool
$c/= :: ArbitraryRelayAccessPoint -> ArbitraryRelayAccessPoint -> Bool
/= :: ArbitraryRelayAccessPoint -> ArbitraryRelayAccessPoint -> Bool
Eq, Eq ArbitraryRelayAccessPoint
Eq ArbitraryRelayAccessPoint =>
(ArbitraryRelayAccessPoint
 -> ArbitraryRelayAccessPoint -> Ordering)
-> (ArbitraryRelayAccessPoint -> ArbitraryRelayAccessPoint -> Bool)
-> (ArbitraryRelayAccessPoint -> ArbitraryRelayAccessPoint -> Bool)
-> (ArbitraryRelayAccessPoint -> ArbitraryRelayAccessPoint -> Bool)
-> (ArbitraryRelayAccessPoint -> ArbitraryRelayAccessPoint -> Bool)
-> (ArbitraryRelayAccessPoint
    -> ArbitraryRelayAccessPoint -> ArbitraryRelayAccessPoint)
-> (ArbitraryRelayAccessPoint
    -> ArbitraryRelayAccessPoint -> ArbitraryRelayAccessPoint)
-> Ord ArbitraryRelayAccessPoint
ArbitraryRelayAccessPoint -> ArbitraryRelayAccessPoint -> Bool
ArbitraryRelayAccessPoint -> ArbitraryRelayAccessPoint -> Ordering
ArbitraryRelayAccessPoint
-> ArbitraryRelayAccessPoint -> ArbitraryRelayAccessPoint
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 :: ArbitraryRelayAccessPoint -> ArbitraryRelayAccessPoint -> Ordering
compare :: ArbitraryRelayAccessPoint -> ArbitraryRelayAccessPoint -> Ordering
$c< :: ArbitraryRelayAccessPoint -> ArbitraryRelayAccessPoint -> Bool
< :: ArbitraryRelayAccessPoint -> ArbitraryRelayAccessPoint -> Bool
$c<= :: ArbitraryRelayAccessPoint -> ArbitraryRelayAccessPoint -> Bool
<= :: ArbitraryRelayAccessPoint -> ArbitraryRelayAccessPoint -> Bool
$c> :: ArbitraryRelayAccessPoint -> ArbitraryRelayAccessPoint -> Bool
> :: ArbitraryRelayAccessPoint -> ArbitraryRelayAccessPoint -> Bool
$c>= :: ArbitraryRelayAccessPoint -> ArbitraryRelayAccessPoint -> Bool
>= :: ArbitraryRelayAccessPoint -> ArbitraryRelayAccessPoint -> Bool
$cmax :: ArbitraryRelayAccessPoint
-> ArbitraryRelayAccessPoint -> ArbitraryRelayAccessPoint
max :: ArbitraryRelayAccessPoint
-> ArbitraryRelayAccessPoint -> ArbitraryRelayAccessPoint
$cmin :: ArbitraryRelayAccessPoint
-> ArbitraryRelayAccessPoint -> ArbitraryRelayAccessPoint
min :: ArbitraryRelayAccessPoint
-> ArbitraryRelayAccessPoint -> ArbitraryRelayAccessPoint
Ord) via RelayAccessPoint

instance Arbitrary ArbitraryRelayAccessPoint where
    arbitrary :: Gen ArbitraryRelayAccessPoint
arbitrary =
      RelayAccessPoint -> ArbitraryRelayAccessPoint
ArbitraryRelayAccessPoint (RelayAccessPoint -> ArbitraryRelayAccessPoint)
-> Gen RelayAccessPoint -> Gen ArbitraryRelayAccessPoint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        [Gen RelayAccessPoint] -> Gen RelayAccessPoint
forall a. [Gen a] -> Gen a
oneof [ IP -> PortNumber -> RelayAccessPoint
RelayAccessAddress (String -> IP
forall a. Read a => String -> a
read String
"1.1.1.1")     (PortNumber -> RelayAccessPoint)
-> (ArbitraryPortNumber -> PortNumber)
-> ArbitraryPortNumber
-> RelayAccessPoint
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ArbitraryPortNumber -> PortNumber
getArbitraryPortNumber (ArbitraryPortNumber -> RelayAccessPoint)
-> Gen ArbitraryPortNumber -> Gen RelayAccessPoint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen ArbitraryPortNumber
forall a. Arbitrary a => Gen a
arbitrary
              , Domain -> PortNumber -> RelayAccessPoint
RelayAccessDomain  Domain
"relay.iohk.example" (PortNumber -> RelayAccessPoint)
-> (ArbitraryPortNumber -> PortNumber)
-> ArbitraryPortNumber
-> RelayAccessPoint
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ArbitraryPortNumber -> PortNumber
getArbitraryPortNumber (ArbitraryPortNumber -> RelayAccessPoint)
-> Gen ArbitraryPortNumber -> Gen RelayAccessPoint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen ArbitraryPortNumber
forall a. Arbitrary a => Gen a
arbitrary
              ]

newtype ArbitraryLedgerStateJudgement =
  ArbitraryLedgerStateJudgement {
    ArbitraryLedgerStateJudgement -> LedgerStateJudgement
getArbitraryLedgerStateJudgement :: LedgerStateJudgement
  } deriving Int -> ArbitraryLedgerStateJudgement -> ShowS
[ArbitraryLedgerStateJudgement] -> ShowS
ArbitraryLedgerStateJudgement -> String
(Int -> ArbitraryLedgerStateJudgement -> ShowS)
-> (ArbitraryLedgerStateJudgement -> String)
-> ([ArbitraryLedgerStateJudgement] -> ShowS)
-> Show ArbitraryLedgerStateJudgement
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ArbitraryLedgerStateJudgement -> ShowS
showsPrec :: Int -> ArbitraryLedgerStateJudgement -> ShowS
$cshow :: ArbitraryLedgerStateJudgement -> String
show :: ArbitraryLedgerStateJudgement -> String
$cshowList :: [ArbitraryLedgerStateJudgement] -> ShowS
showList :: [ArbitraryLedgerStateJudgement] -> ShowS
Show

instance Arbitrary ArbitraryLedgerStateJudgement where
    arbitrary :: Gen ArbitraryLedgerStateJudgement
arbitrary =
      LedgerStateJudgement -> ArbitraryLedgerStateJudgement
ArbitraryLedgerStateJudgement (LedgerStateJudgement -> ArbitraryLedgerStateJudgement)
-> Gen LedgerStateJudgement -> Gen ArbitraryLedgerStateJudgement
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        [Gen LedgerStateJudgement] -> Gen LedgerStateJudgement
forall a. [Gen a] -> Gen a
oneof [ LedgerStateJudgement -> Gen LedgerStateJudgement
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LedgerStateJudgement
YoungEnough
              , LedgerStateJudgement -> Gen LedgerStateJudgement
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LedgerStateJudgement
TooOld
              ]
    shrink :: ArbitraryLedgerStateJudgement -> [ArbitraryLedgerStateJudgement]
shrink (ArbitraryLedgerStateJudgement LedgerStateJudgement
YoungEnough) =
      [LedgerStateJudgement -> ArbitraryLedgerStateJudgement
ArbitraryLedgerStateJudgement LedgerStateJudgement
TooOld]
    shrink (ArbitraryLedgerStateJudgement LedgerStateJudgement
TooOld)      =
      []

-- TODO: import the `SlotNo` instance from
-- `Test.Ouroboros.Network.PeerSelection.Instances`
newtype ArbitrarySlotNo =
  ArbitrarySlotNo {
    ArbitrarySlotNo -> SlotNo
getArbitrarySlotNo :: SlotNo
  } deriving Int -> ArbitrarySlotNo -> ShowS
[ArbitrarySlotNo] -> ShowS
ArbitrarySlotNo -> String
(Int -> ArbitrarySlotNo -> ShowS)
-> (ArbitrarySlotNo -> String)
-> ([ArbitrarySlotNo] -> ShowS)
-> Show ArbitrarySlotNo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ArbitrarySlotNo -> ShowS
showsPrec :: Int -> ArbitrarySlotNo -> ShowS
$cshow :: ArbitrarySlotNo -> String
show :: ArbitrarySlotNo -> String
$cshowList :: [ArbitrarySlotNo] -> ShowS
showList :: [ArbitrarySlotNo] -> ShowS
Show

-- We generate integers including negative ones, which is fine for the purpose
-- of the tests we run.
instance Arbitrary ArbitrarySlotNo where
    arbitrary :: Gen ArbitrarySlotNo
arbitrary =
      SlotNo -> ArbitrarySlotNo
ArbitrarySlotNo (SlotNo -> ArbitrarySlotNo)
-> (Word64 -> SlotNo) -> Word64 -> ArbitrarySlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> SlotNo
SlotNo (Word64 -> ArbitrarySlotNo) -> Gen Word64 -> Gen ArbitrarySlotNo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Word64
forall a. Arbitrary a => Gen a
arbitrary

data StakePool = StakePool {
      StakePool -> Word64
spStake :: !Word64
    , StakePool -> NonEmpty RelayAccessPoint
spRelay :: NonEmpty RelayAccessPoint
    } deriving Int -> StakePool -> ShowS
[StakePool] -> ShowS
StakePool -> String
(Int -> StakePool -> ShowS)
-> (StakePool -> String)
-> ([StakePool] -> ShowS)
-> Show StakePool
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StakePool -> ShowS
showsPrec :: Int -> StakePool -> ShowS
$cshow :: StakePool -> String
show :: StakePool -> String
$cshowList :: [StakePool] -> ShowS
showList :: [StakePool] -> ShowS
Show



instance Arbitrary StakePool where
    arbitrary :: Gen StakePool
arbitrary = do
        stake <- (Word64, Word64) -> Gen Word64
forall a. Random a => (a, a) -> Gen a
choose (Word64
0, Word64
1000000)
        (ArbitraryRelayAccessPoint firstRelay) <- arbitrary
        moreRelays <- filter (/= firstRelay) . nub . map unAddr <$> arbitrary
        return $ StakePool stake (firstRelay :| moreRelays)
      where
        unAddr :: ArbitraryRelayAccessPoint -> RelayAccessPoint
unAddr (ArbitraryRelayAccessPoint RelayAccessPoint
a) = RelayAccessPoint
a

    shrink :: StakePool -> [StakePool]
shrink sp :: StakePool
sp@StakePool { Word64
spStake :: StakePool -> Word64
spStake :: Word64
spStake, NonEmpty RelayAccessPoint
spRelay :: StakePool -> NonEmpty RelayAccessPoint
spRelay :: NonEmpty RelayAccessPoint
spRelay } =
      [ StakePool
sp { spStake = spStake' }
      | Word64
spStake' <- Word64 -> [Word64]
forall a. Arbitrary a => a -> [a]
shrink Word64
spStake
      ]
      [StakePool] -> [StakePool] -> [StakePool]
forall a. [a] -> [a] -> [a]
++
      [ StakePool
sp { spRelay = NonEmpty.fromList spRelay' }
      | spRelay' :: [RelayAccessPoint]
spRelay'@(RelayAccessPoint
_ : [RelayAccessPoint]
_) <- (RelayAccessPoint -> [RelayAccessPoint])
-> [RelayAccessPoint] -> [[RelayAccessPoint]]
forall a. (a -> [a]) -> [a] -> [[a]]
shrinkList ([RelayAccessPoint] -> RelayAccessPoint -> [RelayAccessPoint]
forall a b. a -> b -> a
const [])
                                       (NonEmpty RelayAccessPoint -> [RelayAccessPoint]
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty RelayAccessPoint
spRelay)
      ]

newtype LedgerPools =
  LedgerPools { LedgerPools -> [(PoolStake, NonEmpty RelayAccessPoint)]
getLedgerPools :: [(PoolStake, NonEmpty RelayAccessPoint)] }
  deriving Int -> LedgerPools -> ShowS
[LedgerPools] -> ShowS
LedgerPools -> String
(Int -> LedgerPools -> ShowS)
-> (LedgerPools -> String)
-> ([LedgerPools] -> ShowS)
-> Show LedgerPools
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LedgerPools -> ShowS
showsPrec :: Int -> LedgerPools -> ShowS
$cshow :: LedgerPools -> String
show :: LedgerPools -> String
$cshowList :: [LedgerPools] -> ShowS
showList :: [LedgerPools] -> ShowS
Show

instance Arbitrary LedgerPools where
    arbitrary :: Gen LedgerPools
arbitrary = [(PoolStake, NonEmpty RelayAccessPoint)] -> LedgerPools
LedgerPools ([(PoolStake, NonEmpty RelayAccessPoint)] -> LedgerPools)
-> ([StakePool] -> [(PoolStake, NonEmpty RelayAccessPoint)])
-> [StakePool]
-> LedgerPools
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [StakePool] -> [(PoolStake, NonEmpty RelayAccessPoint)]
calculateRelativeStake ([StakePool] -> LedgerPools) -> Gen [StakePool] -> Gen LedgerPools
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen [StakePool]
forall a. Arbitrary a => Gen a
arbitrary

calculateRelativeStake :: [StakePool]
                       -> [(PoolStake, NonEmpty RelayAccessPoint)]
calculateRelativeStake :: [StakePool] -> [(PoolStake, NonEmpty RelayAccessPoint)]
calculateRelativeStake [StakePool]
sps =
    let totalStake :: Word64
totalStake = (Word64 -> StakePool -> Word64) -> Word64 -> [StakePool] -> Word64
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' (\Word64
s StakePool
p -> Word64
s Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ StakePool -> Word64
spStake StakePool
p) Word64
0 [StakePool]
sps in
    (StakePool -> (PoolStake, NonEmpty RelayAccessPoint))
-> [StakePool] -> [(PoolStake, NonEmpty RelayAccessPoint)]
forall a b. (a -> b) -> [a] -> [b]
map (\StakePool
p -> ( Rational -> PoolStake
PoolStake (Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (StakePool -> Word64
spStake StakePool
p) Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
totalStake)
               , StakePool -> NonEmpty RelayAccessPoint
spRelay StakePool
p)) [StakePool]
sps

genLedgerPoolsFrom :: [RelayAccessPoint] -> Gen LedgerPools
genLedgerPoolsFrom :: [RelayAccessPoint] -> Gen LedgerPools
genLedgerPoolsFrom [RelayAccessPoint]
relays = do
  stake <- (Word64, Word64) -> Gen Word64
forall a. Random a => (a, a) -> Gen a
choose (Word64
0, Word64
1000000)
  (ArbitraryRelayAccessPoint firstRelay) <- arbitrary
  let moreRelays = (RelayAccessPoint -> Bool)
-> [RelayAccessPoint] -> [RelayAccessPoint]
forall a. (a -> Bool) -> [a] -> [a]
filter (RelayAccessPoint -> RelayAccessPoint -> Bool
forall a. Eq a => a -> a -> Bool
/= RelayAccessPoint
firstRelay) ([RelayAccessPoint] -> [RelayAccessPoint])
-> ([RelayAccessPoint] -> [RelayAccessPoint])
-> [RelayAccessPoint]
-> [RelayAccessPoint]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [RelayAccessPoint] -> [RelayAccessPoint]
forall a. Eq a => [a] -> [a]
nub ([RelayAccessPoint] -> [RelayAccessPoint])
-> [RelayAccessPoint] -> [RelayAccessPoint]
forall a b. (a -> b) -> a -> b
$ [RelayAccessPoint]
relays
      stakePool = Word64 -> NonEmpty RelayAccessPoint -> StakePool
StakePool Word64
stake (RelayAccessPoint
firstRelay RelayAccessPoint -> [RelayAccessPoint] -> NonEmpty RelayAccessPoint
forall a. a -> [a] -> NonEmpty a
:| [RelayAccessPoint]
moreRelays)
  return (LedgerPools $ calculateRelativeStake [stakePool])

newtype ArbLedgerPeersKind = ArbLedgerPeersKind LedgerPeersKind
  deriving Int -> ArbLedgerPeersKind -> ShowS
[ArbLedgerPeersKind] -> ShowS
ArbLedgerPeersKind -> String
(Int -> ArbLedgerPeersKind -> ShowS)
-> (ArbLedgerPeersKind -> String)
-> ([ArbLedgerPeersKind] -> ShowS)
-> Show ArbLedgerPeersKind
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ArbLedgerPeersKind -> ShowS
showsPrec :: Int -> ArbLedgerPeersKind -> ShowS
$cshow :: ArbLedgerPeersKind -> String
show :: ArbLedgerPeersKind -> String
$cshowList :: [ArbLedgerPeersKind] -> ShowS
showList :: [ArbLedgerPeersKind] -> ShowS
Show

instance Arbitrary ArbLedgerPeersKind where
    arbitrary :: Gen ArbLedgerPeersKind
arbitrary = LedgerPeersKind -> ArbLedgerPeersKind
ArbLedgerPeersKind (LedgerPeersKind -> ArbLedgerPeersKind)
-> Gen LedgerPeersKind -> Gen ArbLedgerPeersKind
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LedgerPeersKind] -> Gen LedgerPeersKind
forall a. [a] -> Gen a
elements [LedgerPeersKind
AllLedgerPeers, LedgerPeersKind
BigLedgerPeers]
    shrink :: ArbLedgerPeersKind -> [ArbLedgerPeersKind]
shrink (ArbLedgerPeersKind LedgerPeersKind
AllLedgerPeers) = [LedgerPeersKind -> ArbLedgerPeersKind
ArbLedgerPeersKind LedgerPeersKind
BigLedgerPeers]
    shrink (ArbLedgerPeersKind LedgerPeersKind
BigLedgerPeers) = []

newtype ArbStakeMapOverSource = ArbStakeMapOverSource { ArbStakeMapOverSource -> StakeMapOverSource
getArbStakeMapOverSource :: StakeMapOverSource }
  deriving Int -> ArbStakeMapOverSource -> ShowS
[ArbStakeMapOverSource] -> ShowS
ArbStakeMapOverSource -> String
(Int -> ArbStakeMapOverSource -> ShowS)
-> (ArbStakeMapOverSource -> String)
-> ([ArbStakeMapOverSource] -> ShowS)
-> Show ArbStakeMapOverSource
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ArbStakeMapOverSource -> ShowS
showsPrec :: Int -> ArbStakeMapOverSource -> ShowS
$cshow :: ArbStakeMapOverSource -> String
show :: ArbStakeMapOverSource -> String
$cshowList :: [ArbStakeMapOverSource] -> ShowS
showList :: [ArbStakeMapOverSource] -> ShowS
Show

instance Arbitrary ArbStakeMapOverSource where
  arbitrary :: Gen ArbStakeMapOverSource
arbitrary = do
    peerSnapshot <-
      [Gen (Maybe LedgerPeerSnapshot)] -> Gen (Maybe LedgerPeerSnapshot)
forall a. [Gen a] -> Gen a
oneof [ Maybe LedgerPeerSnapshot -> Gen (Maybe LedgerPeerSnapshot)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe LedgerPeerSnapshot
forall a. Maybe a
Nothing, LedgerPeerSnapshot -> Maybe LedgerPeerSnapshot
forall a. a -> Maybe a
Just (LedgerPeerSnapshot -> Maybe LedgerPeerSnapshot)
-> Gen LedgerPeerSnapshot -> Gen (Maybe LedgerPeerSnapshot)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen LedgerPeerSnapshot
genPeerSnapshot ]
    ledgerWithOrigin <- genWithOrigin
    ula <- arbitrary
    ledgerPeers <-
      case (ula, ledgerWithOrigin) of
        (AfterSlot
Always, WithOrigin SlotNo
_) -> LedgerStateJudgement
-> [(PoolStake, NonEmpty RelayAccessPoint)] -> LedgerPeers
LedgerPeers LedgerStateJudgement
TooOld ([(PoolStake, NonEmpty RelayAccessPoint)] -> LedgerPeers)
-> (LedgerPools -> [(PoolStake, NonEmpty RelayAccessPoint)])
-> LedgerPools
-> LedgerPeers
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerPools -> [(PoolStake, NonEmpty RelayAccessPoint)]
getLedgerPools (LedgerPools -> LedgerPeers) -> Gen LedgerPools -> Gen LedgerPeers
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen LedgerPools
forall a. Arbitrary a => Gen a
arbitrary
        (After SlotNo
slotNo, WithOrigin SlotNo
Origin) | SlotNo
slotNo SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
> SlotNo
0 -> LedgerPeers -> Gen LedgerPeers
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return LedgerPeers
BeforeSlot
        (After SlotNo
afterSlotNo, At SlotNo
atSlotNo)
          | SlotNo
afterSlotNo SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
<= SlotNo
atSlotNo -> LedgerStateJudgement
-> [(PoolStake, NonEmpty RelayAccessPoint)] -> LedgerPeers
LedgerPeers LedgerStateJudgement
TooOld ([(PoolStake, NonEmpty RelayAccessPoint)] -> LedgerPeers)
-> (LedgerPools -> [(PoolStake, NonEmpty RelayAccessPoint)])
-> LedgerPools
-> LedgerPeers
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerPools -> [(PoolStake, NonEmpty RelayAccessPoint)]
getLedgerPools (LedgerPools -> LedgerPeers) -> Gen LedgerPools -> Gen LedgerPeers
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen LedgerPools
forall a. Arbitrary a => Gen a
arbitrary
        (AfterSlot, WithOrigin SlotNo)
_otherwise -> LedgerPeers -> Gen LedgerPeers
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return LedgerPeers
BeforeSlot
    (peerMap, bigPeerMap, cachedSlot) <-
      return $ case peerSnapshot of
                 Maybe LedgerPeerSnapshot
Nothing -> (Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
forall k a. Map k a
Map.empty, Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
forall k a. Map k a
Map.empty, Maybe SlotNo
forall a. Maybe a
Nothing)
                 Just (LedgerPeerSnapshotV1 (At SlotNo
slot, [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
accPools))
                   -> ([(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
-> Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
accPools, [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
-> Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
accPools, SlotNo -> Maybe SlotNo
forall a. a -> Maybe a
Just SlotNo
slot)
                 Maybe LedgerPeerSnapshot
_otherwise -> String
-> (Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint),
    Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint),
    Maybe SlotNo)
forall a. HasCallStack => String -> a
error String
"impossible!"
    return $ ArbStakeMapOverSource StakeMapOverSource {
      ledgerWithOrigin,
      ledgerPeers,
      peerSnapshot,
      peerMap,
      bigPeerMap,
      ula,
      cachedSlot }
    where
      genWithOrigin :: Gen (WithOrigin SlotNo)
genWithOrigin = do
        ArbitrarySlotNo slotNo <- Gen ArbitrarySlotNo
forall a. Arbitrary a => Gen a
arbitrary
        return $ if slotNo == 0 then Origin else At slotNo
      genPeerSnapshot :: Gen LedgerPeerSnapshot
genPeerSnapshot = do
        slotNo <- SlotNo -> WithOrigin SlotNo
forall t. t -> WithOrigin t
At (SlotNo -> WithOrigin SlotNo)
-> (Positive SlotNo -> SlotNo)
-> Positive SlotNo
-> WithOrigin SlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Positive SlotNo -> SlotNo
forall a. Positive a -> a
getPositive (Positive SlotNo -> WithOrigin SlotNo)
-> Gen (Positive SlotNo) -> Gen (WithOrigin SlotNo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Positive SlotNo)
forall a. Arbitrary a => Gen a
arbitrary
        pools <- accumulateBigLedgerStake . getLedgerPools <$> arbitrary
        return $ LedgerPeerSnapshotV1 (slotNo, pools)

-- | This test checks whether requesting ledger peers works as intended
-- when snapshot data is available. For each request, peers must be returned from the right
-- source - either the ledger or snapshot, depending on whether which source is fresher.
--
prop_ledgerPeerSnapshot_requests :: ArbStakeMapOverSource
                                 -> Property
prop_ledgerPeerSnapshot_requests :: ArbStakeMapOverSource -> Property
prop_ledgerPeerSnapshot_requests ArbStakeMapOverSource {
      getArbStakeMapOverSource :: ArbStakeMapOverSource -> StakeMapOverSource
getArbStakeMapOverSource = params :: StakeMapOverSource
params@StakeMapOverSource {
          WithOrigin SlotNo
ledgerWithOrigin :: StakeMapOverSource -> WithOrigin SlotNo
ledgerWithOrigin :: WithOrigin SlotNo
ledgerWithOrigin,
          LedgerPeers
ledgerPeers :: StakeMapOverSource -> LedgerPeers
ledgerPeers :: LedgerPeers
ledgerPeers,
          Maybe LedgerPeerSnapshot
peerSnapshot :: StakeMapOverSource -> Maybe LedgerPeerSnapshot
peerSnapshot :: Maybe LedgerPeerSnapshot
peerSnapshot,
          AfterSlot
ula :: StakeMapOverSource -> AfterSlot
ula :: AfterSlot
ula } } =
  String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample ([String] -> String
unlines
                   [String
"Counterexample:", String
"Ledger slot " String -> ShowS
forall a. [a] -> [a] -> [a]
++ WithOrigin SlotNo -> String
forall a. Show a => a -> String
show WithOrigin SlotNo
ledgerWithOrigin,
                    String
"Ledger pools: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ LedgerPeers -> String
forall a. Show a => a -> String
show LedgerPeers
ledgerPeers,
                    String
"Snapshot? :" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Maybe LedgerPeerSnapshot -> String
forall a. Show a => a -> String
show Maybe LedgerPeerSnapshot
peerSnapshot,
                    String
"UseLedgerAfter: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ AfterSlot -> String
forall a. Show a => a -> String
show AfterSlot
ula]) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    let (Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
poolMap, Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
bigPoolMap, Maybe SlotNo
_slot) = StakeMapOverSource
-> (Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint),
    Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint),
    Maybe SlotNo)
stakeMapWithSlotOverSource StakeMapOverSource
params
        bigPoolRelays :: [NonEmpty RelayAccessPoint]
bigPoolRelays = ((AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))
 -> NonEmpty RelayAccessPoint)
-> [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
-> [NonEmpty RelayAccessPoint]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((PoolStake, NonEmpty RelayAccessPoint) -> NonEmpty RelayAccessPoint
forall a b. (a, b) -> b
snd ((PoolStake, NonEmpty RelayAccessPoint)
 -> NonEmpty RelayAccessPoint)
-> ((AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))
    -> (PoolStake, NonEmpty RelayAccessPoint))
-> (AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))
-> NonEmpty RelayAccessPoint
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))
-> (PoolStake, NonEmpty RelayAccessPoint)
forall a b. (a, b) -> b
snd) ([(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
 -> [NonEmpty RelayAccessPoint])
-> (Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
    -> [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))])
-> Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
-> [NonEmpty RelayAccessPoint]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
-> [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
forall k a. Map k a -> [(k, a)]
Map.toList (Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
 -> [NonEmpty RelayAccessPoint])
-> Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
-> [NonEmpty RelayAccessPoint]
forall a b. (a -> b) -> a -> b
$ Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
bigPoolMap
        poolRelays :: [NonEmpty RelayAccessPoint]
poolRelays    = ((AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))
 -> NonEmpty RelayAccessPoint)
-> [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
-> [NonEmpty RelayAccessPoint]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((PoolStake, NonEmpty RelayAccessPoint) -> NonEmpty RelayAccessPoint
forall a b. (a, b) -> b
snd ((PoolStake, NonEmpty RelayAccessPoint)
 -> NonEmpty RelayAccessPoint)
-> ((AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))
    -> (PoolStake, NonEmpty RelayAccessPoint))
-> (AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))
-> NonEmpty RelayAccessPoint
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))
-> (PoolStake, NonEmpty RelayAccessPoint)
forall a b. (a, b) -> b
snd) ([(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
 -> [NonEmpty RelayAccessPoint])
-> (Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
    -> [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))])
-> Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
-> [NonEmpty RelayAccessPoint]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
-> [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
forall k a. Map k a -> [(k, a)]
Map.toList (Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
 -> [NonEmpty RelayAccessPoint])
-> Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
-> [NonEmpty RelayAccessPoint]
forall a b. (a -> b) -> a -> b
$ Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
poolMap
    in case (WithOrigin SlotNo
ledgerWithOrigin, LedgerPeers
ledgerPeers, Maybe LedgerPeerSnapshot
peerSnapshot) of
        (At SlotNo
t, LedgerPeers LedgerStateJudgement
_ [(PoolStake, NonEmpty RelayAccessPoint)]
ledgerPools, Just (LedgerPeerSnapshot (At SlotNo
t', [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
snapshotAccStake)))
          | SlotNo
t' SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
>= SlotNo
t ->
            [NonEmpty RelayAccessPoint]
snapshotRelays [NonEmpty RelayAccessPoint]
-> [NonEmpty RelayAccessPoint] -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== [NonEmpty RelayAccessPoint]
bigPoolRelays Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. [NonEmpty RelayAccessPoint]
bigPoolRelays [NonEmpty RelayAccessPoint]
-> [NonEmpty RelayAccessPoint] -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== [NonEmpty RelayAccessPoint]
poolRelays
          | Bool
otherwise ->
                 [NonEmpty RelayAccessPoint]
bigPoolRelays [NonEmpty RelayAccessPoint]
-> [NonEmpty RelayAccessPoint] -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== [NonEmpty RelayAccessPoint]
ledgerBigPoolRelays
            Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&.    [NonEmpty RelayAccessPoint]
poolRelays [NonEmpty RelayAccessPoint]
-> [NonEmpty RelayAccessPoint] -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== [NonEmpty RelayAccessPoint]
ledgerRelays
          where
            snapshotRelays :: [NonEmpty RelayAccessPoint]
snapshotRelays = ((AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))
 -> NonEmpty RelayAccessPoint)
-> [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
-> [NonEmpty RelayAccessPoint]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((PoolStake, NonEmpty RelayAccessPoint) -> NonEmpty RelayAccessPoint
forall a b. (a, b) -> b
snd ((PoolStake, NonEmpty RelayAccessPoint)
 -> NonEmpty RelayAccessPoint)
-> ((AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))
    -> (PoolStake, NonEmpty RelayAccessPoint))
-> (AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))
-> NonEmpty RelayAccessPoint
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))
-> (PoolStake, NonEmpty RelayAccessPoint)
forall a b. (a, b) -> b
snd) [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
snapshotAccStake
            ledgerBigPoolRelays :: [NonEmpty RelayAccessPoint]
ledgerBigPoolRelays   = ((AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))
 -> NonEmpty RelayAccessPoint)
-> [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
-> [NonEmpty RelayAccessPoint]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((PoolStake, NonEmpty RelayAccessPoint) -> NonEmpty RelayAccessPoint
forall a b. (a, b) -> b
snd ((PoolStake, NonEmpty RelayAccessPoint)
 -> NonEmpty RelayAccessPoint)
-> ((AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))
    -> (PoolStake, NonEmpty RelayAccessPoint))
-> (AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))
-> NonEmpty RelayAccessPoint
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))
-> (PoolStake, NonEmpty RelayAccessPoint)
forall a b. (a, b) -> b
snd) ([(PoolStake, NonEmpty RelayAccessPoint)]
-> [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
accumulateBigLedgerStake [(PoolStake, NonEmpty RelayAccessPoint)]
ledgerPools)
            ledgerRelays :: [NonEmpty RelayAccessPoint]
ledgerRelays = ((AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))
 -> NonEmpty RelayAccessPoint)
-> [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
-> [NonEmpty RelayAccessPoint]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((PoolStake, NonEmpty RelayAccessPoint) -> NonEmpty RelayAccessPoint
forall a b. (a, b) -> b
snd ((PoolStake, NonEmpty RelayAccessPoint)
 -> NonEmpty RelayAccessPoint)
-> ((AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))
    -> (PoolStake, NonEmpty RelayAccessPoint))
-> (AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))
-> NonEmpty RelayAccessPoint
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))
-> (PoolStake, NonEmpty RelayAccessPoint)
forall a b. (a, b) -> b
snd) ([(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
 -> [NonEmpty RelayAccessPoint])
-> (Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
    -> [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))])
-> Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
-> [NonEmpty RelayAccessPoint]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
-> [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
forall k a. Map k a -> [(k, a)]
Map.toList (Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
 -> [NonEmpty RelayAccessPoint])
-> Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
-> [NonEmpty RelayAccessPoint]
forall a b. (a -> b) -> a -> b
$ [(PoolStake, NonEmpty RelayAccessPoint)]
-> Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
accPoolStake [(PoolStake, NonEmpty RelayAccessPoint)]
ledgerPools

        (WithOrigin SlotNo
_, LedgerPeers LedgerStateJudgement
_ [(PoolStake, NonEmpty RelayAccessPoint)]
ledgerPools, Maybe LedgerPeerSnapshot
Nothing) ->
               [NonEmpty RelayAccessPoint]
bigPoolRelays [NonEmpty RelayAccessPoint]
-> [NonEmpty RelayAccessPoint] -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== [NonEmpty RelayAccessPoint]
ledgerBigPoolRelays
          Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&.    [NonEmpty RelayAccessPoint]
poolRelays [NonEmpty RelayAccessPoint]
-> [NonEmpty RelayAccessPoint] -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== [NonEmpty RelayAccessPoint]
ledgerRelays
          where
            ledgerBigPoolRelays :: [NonEmpty RelayAccessPoint]
ledgerBigPoolRelays = ((AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))
 -> NonEmpty RelayAccessPoint)
-> [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
-> [NonEmpty RelayAccessPoint]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((PoolStake, NonEmpty RelayAccessPoint) -> NonEmpty RelayAccessPoint
forall a b. (a, b) -> b
snd ((PoolStake, NonEmpty RelayAccessPoint)
 -> NonEmpty RelayAccessPoint)
-> ((AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))
    -> (PoolStake, NonEmpty RelayAccessPoint))
-> (AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))
-> NonEmpty RelayAccessPoint
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))
-> (PoolStake, NonEmpty RelayAccessPoint)
forall a b. (a, b) -> b
snd) ([(PoolStake, NonEmpty RelayAccessPoint)]
-> [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
accumulateBigLedgerStake [(PoolStake, NonEmpty RelayAccessPoint)]
ledgerPools)
            ledgerRelays :: [NonEmpty RelayAccessPoint]
ledgerRelays = ((AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))
 -> NonEmpty RelayAccessPoint)
-> [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
-> [NonEmpty RelayAccessPoint]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((PoolStake, NonEmpty RelayAccessPoint) -> NonEmpty RelayAccessPoint
forall a b. (a, b) -> b
snd ((PoolStake, NonEmpty RelayAccessPoint)
 -> NonEmpty RelayAccessPoint)
-> ((AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))
    -> (PoolStake, NonEmpty RelayAccessPoint))
-> (AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))
-> NonEmpty RelayAccessPoint
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))
-> (PoolStake, NonEmpty RelayAccessPoint)
forall a b. (a, b) -> b
snd) ([(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
 -> [NonEmpty RelayAccessPoint])
-> (Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
    -> [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))])
-> Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
-> [NonEmpty RelayAccessPoint]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
-> [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
forall k a. Map k a -> [(k, a)]
Map.toList (Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
 -> [NonEmpty RelayAccessPoint])
-> Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
-> [NonEmpty RelayAccessPoint]
forall a b. (a -> b) -> a -> b
$ [(PoolStake, NonEmpty RelayAccessPoint)]
-> Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
accPoolStake [(PoolStake, NonEmpty RelayAccessPoint)]
ledgerPools

        (WithOrigin SlotNo
_, LedgerPeers
_, Just (LedgerPeerSnapshot (At SlotNo
t', [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
snapshotAccStake)))
          | After SlotNo
slot <- AfterSlot
ula, SlotNo
t' SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
>= SlotNo
slot ->
            [NonEmpty RelayAccessPoint]
snapshotRelays [NonEmpty RelayAccessPoint]
-> [NonEmpty RelayAccessPoint] -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== [NonEmpty RelayAccessPoint]
bigPoolRelays Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. [NonEmpty RelayAccessPoint]
bigPoolRelays [NonEmpty RelayAccessPoint]
-> [NonEmpty RelayAccessPoint] -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== [NonEmpty RelayAccessPoint]
poolRelays
          where
            snapshotRelays :: [NonEmpty RelayAccessPoint]
snapshotRelays = ((AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))
 -> NonEmpty RelayAccessPoint)
-> [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
-> [NonEmpty RelayAccessPoint]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((PoolStake, NonEmpty RelayAccessPoint) -> NonEmpty RelayAccessPoint
forall a b. (a, b) -> b
snd ((PoolStake, NonEmpty RelayAccessPoint)
 -> NonEmpty RelayAccessPoint)
-> ((AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))
    -> (PoolStake, NonEmpty RelayAccessPoint))
-> (AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))
-> NonEmpty RelayAccessPoint
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))
-> (PoolStake, NonEmpty RelayAccessPoint)
forall a b. (a, b) -> b
snd) [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
snapshotAccStake

        (WithOrigin SlotNo, LedgerPeers, Maybe LedgerPeerSnapshot)
_otherwise -> [NonEmpty RelayAccessPoint]
bigPoolRelays [NonEmpty RelayAccessPoint]
-> [NonEmpty RelayAccessPoint] -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== [] Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. [NonEmpty RelayAccessPoint]
poolRelays [NonEmpty RelayAccessPoint]
-> [NonEmpty RelayAccessPoint] -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== []


-- | A pool with 100% stake should always be picked.
prop_pick100 :: Word16
             -> NonNegative Int -- ^ number of pools with 0 stake
             -> ArbLedgerPeersKind
             -> MockRoots
             -> DelayAndTimeoutScripts
             -> ArbitrarySlotNo
             -> ArbitraryLedgerStateJudgement
             -> Property
prop_pick100 :: Word16
-> NonNegative Int
-> ArbLedgerPeersKind
-> MockRoots
-> DelayAndTimeoutScripts
-> ArbitrarySlotNo
-> ArbitraryLedgerStateJudgement
-> Property
prop_pick100 Word16
seed (NonNegative Int
n) (ArbLedgerPeersKind LedgerPeersKind
ledgerPeersKind) (MockRoots [(HotValency, WarmValency, Map RelayAccessPoint LocalRootConfig)]
_ Script (Map Domain [(IP, TTL)])
dnsMapScript Map RelayAccessPoint PeerAdvertise
_ Script (Map Domain [(IP, TTL)])
_)
             (DelayAndTimeoutScripts Script DNSLookupDelay
dnsLookupDelayScript Script DNSTimeout
dnsTimeoutScript)
             (ArbitrarySlotNo SlotNo
slot) (ArbitraryLedgerStateJudgement LedgerStateJudgement
lsj) =
    let rng :: StdGen
rng = Int -> StdGen
mkStdGen (Int -> StdGen) -> Int -> StdGen
forall a b. (a -> b) -> a -> b
$ Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
seed
        sps :: [(PoolStake, NonEmpty RelayAccessPoint)]
sps = [ (PoolStake
0, IP -> PortNumber -> RelayAccessPoint
RelayAccessAddress (String -> IP
forall a. Read a => String -> a
read (String -> IP) -> String -> IP
forall a b. (a -> b) -> a -> b
$ String
"0.0.0." String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
a) PortNumber
1 RelayAccessPoint -> [RelayAccessPoint] -> NonEmpty RelayAccessPoint
forall a. a -> [a] -> NonEmpty a
:| [])
              | Int
a <- [Int
0..Int
n]
              ]
           [(PoolStake, NonEmpty RelayAccessPoint)]
-> [(PoolStake, NonEmpty RelayAccessPoint)]
-> [(PoolStake, NonEmpty RelayAccessPoint)]
forall a. [a] -> [a] -> [a]
++ [ (PoolStake
1, IP -> PortNumber -> RelayAccessPoint
RelayAccessAddress (String -> IP
forall a. Read a => String -> a
read String
"1.1.1.1") PortNumber
1  RelayAccessPoint -> [RelayAccessPoint] -> NonEmpty RelayAccessPoint
forall a. a -> [a] -> NonEmpty a
:| []) ]

        accumulatedStakeMap :: Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
accumulatedStakeMap = case LedgerPeersKind
ledgerPeersKind of
          LedgerPeersKind
AllLedgerPeers -> [(PoolStake, NonEmpty RelayAccessPoint)]
-> Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
accPoolStake [(PoolStake, NonEmpty RelayAccessPoint)]
sps
          LedgerPeersKind
BigLedgerPeers -> [(PoolStake, NonEmpty RelayAccessPoint)]
-> Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
accBigPoolStakeMap [(PoolStake, NonEmpty RelayAccessPoint)]
sps

        sim :: IOSim s [RelayAccessPoint]
        sim :: forall s. IOSim s [RelayAccessPoint]
sim = do
          let dnsMap :: Map Domain [(IP, TTL)]
dnsMap = Script (Map Domain [(IP, TTL)]) -> Map Domain [(IP, TTL)]
forall a. Script a -> a
scriptHead Script (Map Domain [(IP, TTL)])
dnsMapScript
          dnsMapVar <- Map Domain [(IP, TTL)]
-> IOSim s (StrictTVar (IOSim s) (Map Domain [(IP, TTL)]))
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
newTVarIO Map Domain [(IP, TTL)]
dnsMap

          dnsTimeoutScriptVar <- initScript' dnsTimeoutScript
          dnsLookupDelayScriptVar <- initScript' dnsLookupDelayScript

          dnsSemaphore <- newLedgerAndPublicRootDNSSemaphore

          withLedgerPeers
                PeerActionsDNS { paToPeerAddr = curry IP.toSockAddr,
                                 paDnsActions = (mockDNSActions @SomeException dnsMapVar dnsTimeoutScriptVar dnsLookupDelayScriptVar),
                                 paDnsSemaphore = dnsSemaphore }
                WithLedgerPeersArgs { wlpRng = rng,
                                      wlpConsensusInterface = interface,
                                      wlpTracer = verboseTracer,
                                      wlpGetUseLedgerPeers = pure $ UseLedgerPeers Always,
                                      wlpGetLedgerPeerSnapshot = pure Nothing }
                (\NumberOfPeers
-> LedgerPeersKind -> IOSim s (Maybe (Set SockAddr, DiffTime))
request Async (IOSim s) Void
_ -> do
                  DiffTime -> IOSim s ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
1900 -- we need to invalidate ledger peer's cache
                  resp <- NumberOfPeers
-> LedgerPeersKind -> IOSim s (Maybe (Set SockAddr, DiffTime))
request (Word16 -> NumberOfPeers
NumberOfPeers Word16
1) LedgerPeersKind
ledgerPeersKind
                  pure $ case resp of
                    Maybe (Set SockAddr, DiffTime)
Nothing          -> []
                    Just (Set SockAddr
peers, DiffTime
_)  -> [ IP -> PortNumber -> RelayAccessPoint
RelayAccessAddress IP
ip PortNumber
port
                                        | Just (IP
ip, PortNumber
port) <- SockAddr -> Maybe (IP, PortNumber)
IP.fromSockAddr
                                                         (SockAddr -> Maybe (IP, PortNumber))
-> [SockAddr] -> [Maybe (IP, PortNumber)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set SockAddr -> [SockAddr]
forall a. Set a -> [a]
Set.toList Set SockAddr
peers
                                        ]
                )
          where
            interface :: LedgerPeersConsensusInterface (IOSim s)
interface =
              STM (IOSim s) (WithOrigin SlotNo)
-> STM (IOSim s) LedgerStateJudgement
-> STM (IOSim s) [(PoolStake, NonEmpty RelayAccessPoint)]
-> LedgerPeersConsensusInterface (IOSim s)
forall (m :: * -> *).
STM m (WithOrigin SlotNo)
-> STM m LedgerStateJudgement
-> STM m [(PoolStake, NonEmpty RelayAccessPoint)]
-> LedgerPeersConsensusInterface m
LedgerPeersConsensusInterface
                (WithOrigin SlotNo -> STM (IOSim s) (WithOrigin SlotNo)
forall a. a -> STM (IOSim s) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WithOrigin SlotNo -> STM (IOSim s) (WithOrigin SlotNo))
-> WithOrigin SlotNo -> STM (IOSim s) (WithOrigin SlotNo)
forall a b. (a -> b) -> a -> b
$ SlotNo -> WithOrigin SlotNo
forall t. t -> WithOrigin t
At SlotNo
slot)
                (LedgerStateJudgement -> STM (IOSim s) LedgerStateJudgement
forall a. a -> STM (IOSim s) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LedgerStateJudgement
lsj)
                ([(PoolStake, NonEmpty RelayAccessPoint)]
-> STM (IOSim s) [(PoolStake, NonEmpty RelayAccessPoint)]
forall a. a -> STM (IOSim s) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
-> [(PoolStake, NonEmpty RelayAccessPoint)]
forall k a. Map k a -> [a]
Map.elems Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
accumulatedStakeMap))

    in String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint) -> String
forall a. Show a => a -> String
show Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
accumulatedStakeMap) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ IO Property -> Property
forall prop. Testable prop => IO prop -> Property
ioProperty (IO Property -> Property) -> IO Property -> Property
forall a b. (a -> b) -> a -> b
$ do
        tr' <- SimTrace [RelayAccessPoint] -> IO (SimResult [RelayAccessPoint])
forall a. SimTrace a -> IO (SimResult a)
evaluateTrace ((forall s. IOSim s [RelayAccessPoint])
-> SimTrace [RelayAccessPoint]
forall a. (forall s. IOSim s a) -> SimTrace a
runSimTrace IOSim s [RelayAccessPoint]
forall s. IOSim s [RelayAccessPoint]
sim)
        case tr' of
             SimException SomeException
e [String]
trace -> do
                 Property -> IO Property
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Property -> IO Property) -> Property -> IO Property
forall a b. (a -> b) -> a -> b
$ String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall a. Show a => a -> String
show SomeException
e String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
trace) Bool
False
             SimDeadLock [String]
trace -> do
                 Property -> IO Property
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Property -> IO Property) -> Property -> IO Property
forall a b. (a -> b) -> a -> b
$ String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String
"Deadlock" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
trace) Bool
False
             SimReturn [RelayAccessPoint]
peers [String]
_trace -> do
                 -- printf "Log: %s\n" (intercalate "\n" _trace)
                 Property -> IO Property
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Property -> IO Property) -> Property -> IO Property
forall a b. (a -> b) -> a -> b
$ [RelayAccessPoint]
peers [RelayAccessPoint] -> [RelayAccessPoint] -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== [ IP -> PortNumber -> RelayAccessPoint
RelayAccessAddress (String -> IP
forall a. Read a => String -> a
read String
"1.1.1.1") PortNumber
1 ]

-- | Verify that given at least one peer we manage to pick `count` peers.
prop_pick :: LedgerPools
          -> ArbLedgerPeersKind
          -> Word16
          -> Word16
          -> MockRoots
          -> Script DNSLookupDelay
          -> ArbitrarySlotNo
          -> ArbitraryLedgerStateJudgement
          -> Property
prop_pick :: LedgerPools
-> ArbLedgerPeersKind
-> Word16
-> Word16
-> MockRoots
-> Script DNSLookupDelay
-> ArbitrarySlotNo
-> ArbitraryLedgerStateJudgement
-> Property
prop_pick (LedgerPools [(PoolStake, NonEmpty RelayAccessPoint)]
lps) (ArbLedgerPeersKind LedgerPeersKind
ledgerPeersKind) Word16
count Word16
seed (MockRoots [(HotValency, WarmValency, Map RelayAccessPoint LocalRootConfig)]
_ Script (Map Domain [(IP, TTL)])
dnsMapScript Map RelayAccessPoint PeerAdvertise
_ Script (Map Domain [(IP, TTL)])
_)
          Script DNSLookupDelay
dnsLookupDelayScript (ArbitrarySlotNo SlotNo
slot) (ArbitraryLedgerStateJudgement LedgerStateJudgement
lsj) =
    let rng :: StdGen
rng = Int -> StdGen
mkStdGen (Int -> StdGen) -> Int -> StdGen
forall a b. (a -> b) -> a -> b
$ Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
seed

        sim :: IOSim s [RelayAccessPoint]
        sim :: forall s. IOSim s [RelayAccessPoint]
sim = do
          dnsMapScriptVar <- Script (Map Domain [(IP, TTL)])
-> IOSim s (StrictTVar (IOSim s) (Script (Map Domain [(IP, TTL)])))
forall (m :: * -> *) a.
MonadSTM m =>
Script a -> m (StrictTVar m (Script a))
initScript' Script (Map Domain [(IP, TTL)])
dnsMapScript
          dnsMap <- stepScript' dnsMapScriptVar
          dnsMapVar <- newTVarIO dnsMap

          dnsTimeoutScriptVar <- initScript' (Script (DNSTimeout 0 :| []))
          dnsLookupDelayScriptVar <- initScript' dnsLookupDelayScript
          dnsSemaphore <- newLedgerAndPublicRootDNSSemaphore

          withLedgerPeers
                PeerActionsDNS { paToPeerAddr = curry IP.toSockAddr,
                                 paDnsActions = mockDNSActions @SomeException dnsMapVar dnsTimeoutScriptVar dnsLookupDelayScriptVar,
                                 paDnsSemaphore = dnsSemaphore }
                WithLedgerPeersArgs { wlpRng = rng,
                                      wlpConsensusInterface = interface,
                                      wlpTracer = verboseTracer,
                                      wlpGetUseLedgerPeers = pure $ UseLedgerPeers (After 0),
                                      wlpGetLedgerPeerSnapshot = pure Nothing }
                (\NumberOfPeers
-> LedgerPeersKind -> IOSim s (Maybe (Set SockAddr, DiffTime))
request Async (IOSim s) Void
_ -> do
                  DiffTime -> IOSim s ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
1900 -- we need to invalidate ledger peer's cache
                  resp <- NumberOfPeers
-> LedgerPeersKind -> IOSim s (Maybe (Set SockAddr, DiffTime))
request (Word16 -> NumberOfPeers
NumberOfPeers Word16
count) LedgerPeersKind
ledgerPeersKind
                  pure $ case resp of
                    Maybe (Set SockAddr, DiffTime)
Nothing          -> []
                    Just (Set SockAddr
peers, DiffTime
_)  -> [ RelayAccessPoint -> RelayAccessPoint
reverseLookup (IP -> PortNumber -> RelayAccessPoint
RelayAccessAddress IP
ip PortNumber
port)
                                        | Just (IP
ip, PortNumber
port) <- SockAddr -> Maybe (IP, PortNumber)
IP.fromSockAddr
                                                      (SockAddr -> Maybe (IP, PortNumber))
-> [SockAddr] -> [Maybe (IP, PortNumber)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Set SockAddr -> [SockAddr]
forall a. Set a -> [a]
Set.toList Set SockAddr
peers
                                        ]
                )
          where
            interface :: LedgerPeersConsensusInterface (IOSim s)
            interface :: forall s. LedgerPeersConsensusInterface (IOSim s)
interface = STM (IOSim s) (WithOrigin SlotNo)
-> STM (IOSim s) LedgerStateJudgement
-> STM (IOSim s) [(PoolStake, NonEmpty RelayAccessPoint)]
-> LedgerPeersConsensusInterface (IOSim s)
forall (m :: * -> *).
STM m (WithOrigin SlotNo)
-> STM m LedgerStateJudgement
-> STM m [(PoolStake, NonEmpty RelayAccessPoint)]
-> LedgerPeersConsensusInterface m
LedgerPeersConsensusInterface
                          (WithOrigin SlotNo -> STM (IOSim s) (WithOrigin SlotNo)
forall a. a -> STM (IOSim s) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WithOrigin SlotNo -> STM (IOSim s) (WithOrigin SlotNo))
-> WithOrigin SlotNo -> STM (IOSim s) (WithOrigin SlotNo)
forall a b. (a -> b) -> a -> b
$ SlotNo -> WithOrigin SlotNo
forall t. t -> WithOrigin t
At SlotNo
slot)
                          (LedgerStateJudgement -> STM s LedgerStateJudgement
forall a. a -> STM s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LedgerStateJudgement
lsj)
                          ([(PoolStake, NonEmpty RelayAccessPoint)]
-> STM s [(PoolStake, NonEmpty RelayAccessPoint)]
forall a. a -> STM s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(PoolStake, NonEmpty RelayAccessPoint)]
lps)

            domainMap :: Map Domain (Set IP)
            domainMap :: Map Domain (Set IP)
domainMap = [(Domain, Set IP)] -> Map Domain (Set IP)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Domain
"relay.iohk.example", IP -> Set IP
forall a. a -> Set a
Set.singleton (String -> IP
forall a. Read a => String -> a
read String
"2.2.2.2"))]

            reverseLookup :: RelayAccessPoint -> RelayAccessPoint
            reverseLookup :: RelayAccessPoint -> RelayAccessPoint
reverseLookup ap :: RelayAccessPoint
ap@(RelayAccessAddress IP
ip PortNumber
port)
              = case [ Domain
domain
                     | (Domain
domain, Set IP
addrs) <- Map Domain (Set IP) -> [(Domain, Set IP)]
forall k a. Map k a -> [(k, a)]
Map.assocs Map Domain (Set IP)
domainMap
                     , IP
ip IP -> Set IP -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set IP
addrs
                     ] of
                  (Domain
domain : [Domain]
_) -> Domain -> PortNumber -> RelayAccessPoint
RelayAccessDomain Domain
domain PortNumber
port
                  [Domain]
_            -> RelayAccessPoint
ap
            reverseLookup RelayAccessPoint
ap = RelayAccessPoint
ap



    in IO Property -> Property
forall prop. Testable prop => IO prop -> Property
ioProperty (IO Property -> Property) -> IO Property -> Property
forall a b. (a -> b) -> a -> b
$ do
        tr' <- SimTrace [RelayAccessPoint] -> IO (SimResult [RelayAccessPoint])
forall a. SimTrace a -> IO (SimResult a)
evaluateTrace ((forall s. IOSim s [RelayAccessPoint])
-> SimTrace [RelayAccessPoint]
forall a. (forall s. IOSim s a) -> SimTrace a
runSimTrace IOSim s [RelayAccessPoint]
forall s. IOSim s [RelayAccessPoint]
sim)
        case tr' of
             SimException SomeException
e [String]
trace -> do
                 Property -> IO Property
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Property -> IO Property) -> Property -> IO Property
forall a b. (a -> b) -> a -> b
$ String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall a. Show a => a -> String
show SomeException
e String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
trace) Bool
False
             SimDeadLock [String]
trace -> do
                 Property -> IO Property
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Property -> IO Property) -> Property -> IO Property
forall a b. (a -> b) -> a -> b
$ String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String
"Deadlock" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
trace) Bool
False
             SimReturn [RelayAccessPoint]
peers [String]
trace -> do
                 let numOfPeers :: Int
numOfPeers = [RelayAccessPoint] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [RelayAccessPoint]
peers
                 if [(PoolStake, NonEmpty RelayAccessPoint)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(PoolStake, NonEmpty RelayAccessPoint)]
lps
                    then Property -> IO Property
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Property -> IO Property) -> Property -> IO Property
forall a b. (a -> b) -> a -> b
$ Bool -> Property
forall prop. Testable prop => prop -> Property
property (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$ [RelayAccessPoint] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RelayAccessPoint]
peers
                    else Property -> IO Property
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Property -> IO Property) -> Property -> IO Property
forall a b. (a -> b) -> a -> b
$ String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
                                                    ( String
"Lenght missmatch "
                                                      String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([RelayAccessPoint] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [RelayAccessPoint]
peers)
                                                    )
                                                    String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
trace)
                                      (Int
numOfPeers
                                        Int -> Int -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
count Int -> Int -> Int
forall a. Ord a => a -> a -> a
`min` Int
numOfPeers)


prop_accumulateBigLedgerStake :: LedgerPools -> Property
prop_accumulateBigLedgerStake :: LedgerPools -> Property
prop_accumulateBigLedgerStake  (LedgerPools [])        = Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
prop_accumulateBigLedgerStake  (LedgerPools lps :: [(PoolStake, NonEmpty RelayAccessPoint)]
lps@((PoolStake, NonEmpty RelayAccessPoint)
_:[(PoolStake, NonEmpty RelayAccessPoint)]
_)) =
         -- the accumulated map is non empty, whenever ledger peers set is non
         -- empty
         Bool -> Bool
not (Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint) -> Bool
forall k a. Map k a -> Bool
Map.null Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
accumulatedStakeMap)

         -- the relative stake of all large pools is greater than
         -- bigLedgerPeerQuota
    Bool -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample
           (String
"not enough stake: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint),
 [(PoolStake, NonEmpty RelayAccessPoint)])
-> String
forall a. Show a => a -> String
show (Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
accumulatedStakeMap, [(PoolStake, NonEmpty RelayAccessPoint)]
lps))
           (PoolStake -> Rational
unPoolStake (Sum PoolStake -> PoolStake
forall a. Sum a -> a
getSum (((PoolStake, NonEmpty RelayAccessPoint) -> Sum PoolStake)
-> Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
-> Sum PoolStake
forall m a. Monoid m => (a -> m) -> Map AccPoolStake a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (PoolStake -> Sum PoolStake
forall a. a -> Sum a
Sum (PoolStake -> Sum PoolStake)
-> ((PoolStake, NonEmpty RelayAccessPoint) -> PoolStake)
-> (PoolStake, NonEmpty RelayAccessPoint)
-> Sum PoolStake
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PoolStake, NonEmpty RelayAccessPoint) -> PoolStake
forall a b. (a, b) -> a
fst) Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
accumulatedStakeMap)
                PoolStake -> PoolStake -> PoolStake
forall a. Fractional a => a -> a -> a
/ [PoolStake] -> PoolStake
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((PoolStake, NonEmpty RelayAccessPoint) -> PoolStake
forall a b. (a, b) -> a
fst ((PoolStake, NonEmpty RelayAccessPoint) -> PoolStake)
-> [(PoolStake, NonEmpty RelayAccessPoint)] -> [PoolStake]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(PoolStake, NonEmpty RelayAccessPoint)]
lps))
             Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
>= AccPoolStake -> Rational
unAccPoolStake AccPoolStake
bigLedgerPeerQuota)

         -- This property checks that elements of
         -- `accBigPoolStakeMap` form an initial sub-list of the ordered ledger
         -- peers by stake (from large to small).
         --
         -- We relay on the fact that `Map.elems` returns a list of elements
         -- ordered by keys (as they are in the `Map`).
    Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. let lps' :: [(PoolStake, NonEmpty RelayAccessPoint)]
lps'  = ((PoolStake, NonEmpty RelayAccessPoint) -> Down PoolStake)
-> [(PoolStake, NonEmpty RelayAccessPoint)]
-> [(PoolStake, NonEmpty RelayAccessPoint)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (PoolStake -> Down PoolStake
forall a. a -> Down a
Down (PoolStake -> Down PoolStake)
-> ((PoolStake, NonEmpty RelayAccessPoint) -> PoolStake)
-> (PoolStake, NonEmpty RelayAccessPoint)
-> Down PoolStake
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PoolStake, NonEmpty RelayAccessPoint) -> PoolStake
forall a b. (a, b) -> a
fst) [(PoolStake, NonEmpty RelayAccessPoint)]
lps
             elems :: [(PoolStake, NonEmpty RelayAccessPoint)]
elems = Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
-> [(PoolStake, NonEmpty RelayAccessPoint)]
forall k a. Map k a -> [a]
Map.elems Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
accumulatedStakeMap
         in String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"initial sublist vaiolation: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ([(PoolStake, NonEmpty RelayAccessPoint)],
 [(PoolStake, NonEmpty RelayAccessPoint)])
-> String
forall a. Show a => a -> String
show ([(PoolStake, NonEmpty RelayAccessPoint)]
elems, [(PoolStake, NonEmpty RelayAccessPoint)]
lps'))
          (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$ [(PoolStake, NonEmpty RelayAccessPoint)]
elems [(PoolStake, NonEmpty RelayAccessPoint)]
-> [(PoolStake, NonEmpty RelayAccessPoint)] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [(PoolStake, NonEmpty RelayAccessPoint)]
lps'
  where
    accumulatedStakeMap :: Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
accumulatedStakeMap = [(PoolStake, NonEmpty RelayAccessPoint)]
-> Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
accBigPoolStakeMap [(PoolStake, NonEmpty RelayAccessPoint)]
lps

-- |This functions checks the following properties:
-- 1. The accumulated relative stake adds up to unity
-- 2. No pool relative stake can be less than 0
-- 3. The relays aren't mangled
-- 4. Running this function multiple times always produces the same result
--
prop_recomputeRelativeStake :: LedgerPools -> Property
prop_recomputeRelativeStake :: LedgerPools -> Property
prop_recomputeRelativeStake (LedgerPools []) = Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
prop_recomputeRelativeStake (LedgerPools [(PoolStake, NonEmpty RelayAccessPoint)]
lps) = Gen Property -> Property
forall prop. Testable prop => prop -> Property
property (Gen Property -> Property) -> Gen Property -> Property
forall a b. (a -> b) -> a -> b
$ do
  lpk <- Gen LedgerPeersKind
genLedgerPeersKind
  let (accStake, relayAccessPointsUnchangedNonNegativeStake) = go (reStake lpk) lps (0, True)
  return $     counterexample "recomputeRelativeStake: relays modified or negative pool stake calculated"
                             relayAccessPointsUnchangedNonNegativeStake
          .&&. accStake === 1
          .&&. counterexample "violates idempotency"
                              ((recomputeRelativeStake BigLedgerPeers . recomputeRelativeStake BigLedgerPeers $ lps) == recomputeRelativeStake BigLedgerPeers lps)
  where
    genLedgerPeersKind :: Gen LedgerPeersKind
genLedgerPeersKind = [LedgerPeersKind] -> Gen LedgerPeersKind
forall a. [a] -> Gen a
elements [LedgerPeersKind
AllLedgerPeers, LedgerPeersKind
BigLedgerPeers]
    reStake :: LedgerPeersKind -> [(PoolStake, NonEmpty RelayAccessPoint)]
reStake LedgerPeersKind
lpk = LedgerPeersKind
-> [(PoolStake, NonEmpty RelayAccessPoint)]
-> [(PoolStake, NonEmpty RelayAccessPoint)]
recomputeRelativeStake LedgerPeersKind
lpk [(PoolStake, NonEmpty RelayAccessPoint)]
lps
    -- compare relay access points in both lists for equality
    -- where we assume that recomputerelativestake doesn't change
    -- the order, and sum up relative stake to make sure it adds up to 1
    go :: [(a, a)] -> [(a, a)] -> (a, Bool) -> (a, Bool)
go ((a
normPoolStake, a
raps):[(a, a)]
rest) ((a
_, a
raps'):[(a, a)]
rest') (a
accStake, Bool
_) =
      if a
raps a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
raps' Bool -> Bool -> Bool
&& a
normPoolStake a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
0
      then [(a, a)] -> [(a, a)] -> (a, Bool) -> (a, Bool)
go [(a, a)]
rest [(a, a)]
rest' (a
accStake a -> a -> a
forall a. Num a => a -> a -> a
+ a
normPoolStake, Bool
True)
      else (a
accStake a -> a -> a
forall a. Num a => a -> a -> a
+ a
normPoolStake, Bool
False)
    go [] ((a, a)
_:[(a, a)]
_) (a
accStake, Bool
_) = (a
accStake, Bool
False)
    go ((a, a)
_:[(a, a)]
_) [] (a
accStake, Bool
_) = (a
accStake, Bool
False)
    go [(a, a)]
_ [(a, a)]
_ (a
accStake, Bool
relayAccessPointsUnchangedNonNegativeStake) = (a
accStake, Bool
relayAccessPointsUnchangedNonNegativeStake)


prop_getLedgerPeers :: ArbitrarySlotNo
                    -> ArbitraryLedgerStateJudgement
                    -> LedgerPools
                    -> ArbitrarySlotNo
                    -> Property
prop_getLedgerPeers :: ArbitrarySlotNo
-> ArbitraryLedgerStateJudgement
-> LedgerPools
-> ArbitrarySlotNo
-> Property
prop_getLedgerPeers (ArbitrarySlotNo SlotNo
curSlot)
                    (ArbitraryLedgerStateJudgement LedgerStateJudgement
lsj)
                    (LedgerPools [(PoolStake, NonEmpty RelayAccessPoint)]
lps)
                    (ArbitrarySlotNo SlotNo
slot) =
  let afterSlot :: AfterSlot
afterSlot = if SlotNo
slot SlotNo -> SlotNo -> Bool
forall a. Eq a => a -> a -> Bool
== SlotNo
0
                     then AfterSlot
Always
                     else SlotNo -> AfterSlot
After SlotNo
slot
      sim :: IOSim m LedgerPeers
      sim :: forall m. IOSim m LedgerPeers
sim = STM (IOSim m) LedgerPeers -> IOSim m LedgerPeers
forall a. HasCallStack => STM (IOSim m) a -> IOSim m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM (IOSim m) LedgerPeers -> IOSim m LedgerPeers)
-> STM (IOSim m) LedgerPeers -> IOSim m LedgerPeers
forall a b. (a -> b) -> a -> b
$ LedgerPeersConsensusInterface (IOSim m)
-> AfterSlot -> STM (IOSim m) LedgerPeers
forall (m :: * -> *).
MonadSTM m =>
LedgerPeersConsensusInterface m -> AfterSlot -> STM m LedgerPeers
getLedgerPeers LedgerPeersConsensusInterface (IOSim m)
forall s. LedgerPeersConsensusInterface (IOSim s)
interface AfterSlot
afterSlot

      result :: LedgerPeers
      result :: LedgerPeers
result = (forall m. IOSim m LedgerPeers) -> LedgerPeers
forall a. (forall s. IOSim s a) -> a
runSimOrThrow IOSim s LedgerPeers
forall m. IOSim m LedgerPeers
sim

   in String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (LedgerPeers -> String
forall a. Show a => a -> String
show LedgerPeers
result) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
      case LedgerPeers
result of
        LedgerPeers LedgerStateJudgement
_ [(PoolStake, NonEmpty RelayAccessPoint)]
_ -> Bool -> Property
forall prop. Testable prop => prop -> Property
property (SlotNo
curSlot SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
>= SlotNo
slot Bool -> Bool -> Bool
|| AfterSlot
afterSlot AfterSlot -> AfterSlot -> Bool
forall a. Eq a => a -> a -> Bool
== AfterSlot
Always)
        LedgerPeers
BeforeSlot      -> Bool -> Property
forall prop. Testable prop => prop -> Property
property (SlotNo
curSlot SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
< SlotNo
slot)
  where
    curSlotWO :: WithOrigin SlotNo
curSlotWO = if SlotNo
curSlot SlotNo -> SlotNo -> Bool
forall a. Eq a => a -> a -> Bool
== SlotNo
0
                  then WithOrigin SlotNo
forall t. WithOrigin t
Origin
                  else SlotNo -> WithOrigin SlotNo
forall t. t -> WithOrigin t
At SlotNo
curSlot

    interface :: LedgerPeersConsensusInterface (IOSim s)
    interface :: forall s. LedgerPeersConsensusInterface (IOSim s)
interface = STM (IOSim s) (WithOrigin SlotNo)
-> STM (IOSim s) LedgerStateJudgement
-> STM (IOSim s) [(PoolStake, NonEmpty RelayAccessPoint)]
-> LedgerPeersConsensusInterface (IOSim s)
forall (m :: * -> *).
STM m (WithOrigin SlotNo)
-> STM m LedgerStateJudgement
-> STM m [(PoolStake, NonEmpty RelayAccessPoint)]
-> LedgerPeersConsensusInterface m
LedgerPeersConsensusInterface
                  (WithOrigin SlotNo -> STM (IOSim s) (WithOrigin SlotNo)
forall a. a -> STM (IOSim s) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WithOrigin SlotNo -> STM (IOSim s) (WithOrigin SlotNo))
-> WithOrigin SlotNo -> STM (IOSim s) (WithOrigin SlotNo)
forall a b. (a -> b) -> a -> b
$ WithOrigin SlotNo
curSlotWO)
                  (LedgerStateJudgement -> STM s LedgerStateJudgement
forall a. a -> STM s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LedgerStateJudgement
lsj)
                  ([(PoolStake, NonEmpty RelayAccessPoint)]
-> STM s [(PoolStake, NonEmpty RelayAccessPoint)]
forall a. a -> STM s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
-> [(PoolStake, NonEmpty RelayAccessPoint)]
forall k a. Map k a -> [a]
Map.elems ([(PoolStake, NonEmpty RelayAccessPoint)]
-> Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
accPoolStake [(PoolStake, NonEmpty RelayAccessPoint)]
lps)))

-- | Checks validity of LedgerPeerSnapshot CBOR encoding, and whether
--   round trip cycle is the identity function
--
prop_ledgerPeerSnapshotCBORV1 :: ArbitrarySlotNo
                              -> LedgerPools
                              -> Property
prop_ledgerPeerSnapshotCBORV1 :: ArbitrarySlotNo -> LedgerPools -> Property
prop_ledgerPeerSnapshotCBORV1 ArbitrarySlotNo
slotNo
                              LedgerPools
ledgerPools =
  String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (LedgerPeerSnapshot -> String
forall a. Show a => a -> String
show LedgerPeerSnapshot
snapshot) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
         String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Invalid CBOR encoding" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> FlatTerm -> String
forall a. Show a => a -> String
show FlatTerm
encoded)
                        (FlatTerm -> Bool
validFlatTerm FlatTerm
encoded)
    Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. (String -> Property)
-> (LedgerPeerSnapshot -> Property)
-> Either String LedgerPeerSnapshot
-> Property
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ((String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
`counterexample` Bool
False) (String -> Property) -> ShowS -> String -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"CBOR decode failed: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<>))
                (String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String -> Bool -> Property)
-> (LedgerPeerSnapshot -> String)
-> LedgerPeerSnapshot
-> Bool
-> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"CBOR round trip failed: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<>) ShowS
-> (LedgerPeerSnapshot -> String) -> LedgerPeerSnapshot -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerPeerSnapshot -> String
forall a. Show a => a -> String
show (LedgerPeerSnapshot -> Bool -> Property)
-> (LedgerPeerSnapshot -> Bool) -> LedgerPeerSnapshot -> Property
forall a b.
(LedgerPeerSnapshot -> a -> b)
-> (LedgerPeerSnapshot -> a) -> LedgerPeerSnapshot -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (LedgerPeerSnapshot
snapshot LedgerPeerSnapshot -> LedgerPeerSnapshot -> Bool
forall a. Eq a => a -> a -> Bool
==))
                Either String LedgerPeerSnapshot
decoded
  where
    snapshot :: LedgerPeerSnapshot
snapshot = ArbitrarySlotNo -> LedgerPools -> LedgerPeerSnapshot
snapshotV1 ArbitrarySlotNo
slotNo LedgerPools
ledgerPools
    encoded :: FlatTerm
encoded = Encoding -> FlatTerm
toFlatTerm (Encoding -> FlatTerm)
-> (LedgerPeerSnapshot -> Encoding)
-> LedgerPeerSnapshot
-> FlatTerm
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerPeerSnapshot -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (LedgerPeerSnapshot -> FlatTerm) -> LedgerPeerSnapshot -> FlatTerm
forall a b. (a -> b) -> a -> b
$ LedgerPeerSnapshot
snapshot
    decoded :: Either String LedgerPeerSnapshot
decoded = (forall s. Decoder s LedgerPeerSnapshot)
-> FlatTerm -> Either String LedgerPeerSnapshot
forall a. (forall s. Decoder s a) -> FlatTerm -> Either String a
fromFlatTerm Decoder s LedgerPeerSnapshot
forall s. Decoder s LedgerPeerSnapshot
forall a s. FromCBOR a => Decoder s a
fromCBOR FlatTerm
encoded

-- | Tests if LedgerPeerSnapshot JSON round trip is the identity function
--
prop_ledgerPeerSnapshotJSONV1 :: ArbitrarySlotNo
                              -> LedgerPools
                              -> Property
prop_ledgerPeerSnapshotJSONV1 :: ArbitrarySlotNo -> LedgerPools -> Property
prop_ledgerPeerSnapshotJSONV1 ArbitrarySlotNo
slotNo
                              LedgerPools
ledgerPools =
  String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (LedgerPeerSnapshot -> String
forall a. Show a => a -> String
show LedgerPeerSnapshot
snapshot) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
     (String -> Property)
-> (LedgerPeerSnapshot -> Property)
-> Either String LedgerPeerSnapshot
-> Property
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ((String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
`counterexample` Bool
False) (String -> Property) -> ShowS -> String -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"JSON decode failed: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<>))
            (String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String -> Property -> Property)
-> (LedgerPeerSnapshot -> String)
-> LedgerPeerSnapshot
-> Property
-> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"JSON round trip failed: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<>) ShowS
-> (LedgerPeerSnapshot -> String) -> LedgerPeerSnapshot -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerPeerSnapshot -> String
forall a. Show a => a -> String
show (LedgerPeerSnapshot -> Property -> Property)
-> (LedgerPeerSnapshot -> Property)
-> LedgerPeerSnapshot
-> Property
forall a b.
(LedgerPeerSnapshot -> a -> b)
-> (LedgerPeerSnapshot -> a) -> LedgerPeerSnapshot -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> LedgerPeerSnapshot -> LedgerPeerSnapshot -> Property
nearlyEqualModuloFullyQualified LedgerPeerSnapshot
snapshot)
            Either String LedgerPeerSnapshot
roundTrip
  where
    snapshot :: LedgerPeerSnapshot
snapshot = ArbitrarySlotNo -> LedgerPools -> LedgerPeerSnapshot
snapshotV1 ArbitrarySlotNo
slotNo LedgerPools
ledgerPools
    roundTrip :: Either String LedgerPeerSnapshot
roundTrip = case Value -> Result LedgerPeerSnapshot
forall a. FromJSON a => Value -> Result a
fromJSON (Value -> Result LedgerPeerSnapshot)
-> (LedgerPeerSnapshot -> Value)
-> LedgerPeerSnapshot
-> Result LedgerPeerSnapshot
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerPeerSnapshot -> Value
forall a. ToJSON a => a -> Value
toJSON (LedgerPeerSnapshot -> Result LedgerPeerSnapshot)
-> LedgerPeerSnapshot -> Result LedgerPeerSnapshot
forall a b. (a -> b) -> a -> b
$ LedgerPeerSnapshot
snapshot of
                  Aeson.Success LedgerPeerSnapshot
s -> LedgerPeerSnapshot -> Either String LedgerPeerSnapshot
forall a b. b -> Either a b
Right LedgerPeerSnapshot
s
                  Error String
str       -> String -> Either String LedgerPeerSnapshot
forall a b. a -> Either a b
Left String
str

    nearlyEqualModuloFullyQualified :: LedgerPeerSnapshot -> LedgerPeerSnapshot -> Property
nearlyEqualModuloFullyQualified LedgerPeerSnapshot
snapshotOriginal LedgerPeerSnapshot
snapshotRoundTripped =
      let LedgerPeerSnapshotV1 (WithOrigin SlotNo
wOrigin, [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
relaysWithAccStake) = LedgerPeerSnapshot
snapshotOriginal
          strippedRelaysWithAccStake :: [NonEmpty RelayAccessPoint]
strippedRelaysWithAccStake = (AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))
-> NonEmpty RelayAccessPoint
forall {f :: * -> *} {a} {a}.
Functor f =>
(a, (a, f RelayAccessPoint)) -> f RelayAccessPoint
stripFQN ((AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))
 -> NonEmpty RelayAccessPoint)
-> [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
-> [NonEmpty RelayAccessPoint]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
relaysWithAccStake
          LedgerPeerSnapshotV1 (WithOrigin SlotNo
wOrigin', [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
relaysWithAccStake') = LedgerPeerSnapshot
snapshotRoundTripped
          strippedRelaysWithAccStake' :: [NonEmpty RelayAccessPoint]
strippedRelaysWithAccStake' = (AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))
-> NonEmpty RelayAccessPoint
forall {f :: * -> *} {a} {a}.
Functor f =>
(a, (a, f RelayAccessPoint)) -> f RelayAccessPoint
stripFQN ((AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))
 -> NonEmpty RelayAccessPoint)
-> [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
-> [NonEmpty RelayAccessPoint]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
relaysWithAccStake'
      in
             WithOrigin SlotNo
wOrigin WithOrigin SlotNo -> WithOrigin SlotNo -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== WithOrigin SlotNo
wOrigin'
        Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
"fully qualified name"
                            ([NonEmpty RelayAccessPoint]
strippedRelaysWithAccStake [NonEmpty RelayAccessPoint]
-> [NonEmpty RelayAccessPoint] -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== [NonEmpty RelayAccessPoint]
strippedRelaysWithAccStake')
        Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
"approximation error"
                            ([(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
-> [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))] -> Bool
forall {b} {b}.
[(AccPoolStake, (PoolStake, b))]
-> [(AccPoolStake, (PoolStake, b))] -> Bool
compareApprox [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
relaysWithAccStake [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
relaysWithAccStake')

    stripFQN :: (a, (a, f RelayAccessPoint)) -> f RelayAccessPoint
stripFQN (a
_, (a
_, f RelayAccessPoint
relays)) = RelayAccessPoint -> RelayAccessPoint
step (RelayAccessPoint -> RelayAccessPoint)
-> f RelayAccessPoint -> f RelayAccessPoint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f RelayAccessPoint
relays
    step :: RelayAccessPoint -> RelayAccessPoint
step it :: RelayAccessPoint
it@(RelayAccessDomain Domain
domain PortNumber
port) =
      case Domain -> Maybe (Domain, Char)
BS.unsnoc Domain
domain of
        Just (Domain
prefix, Char
'.') -> Domain -> PortNumber -> RelayAccessPoint
RelayAccessDomain Domain
prefix PortNumber
port
        Maybe (Domain, Char)
_otherwise         -> RelayAccessPoint
it
    step RelayAccessPoint
it = RelayAccessPoint
it

    compareApprox :: [(AccPoolStake, (PoolStake, b))]
-> [(AccPoolStake, (PoolStake, b))] -> Bool
compareApprox [(AccPoolStake, (PoolStake, b))]
left [(AccPoolStake, (PoolStake, b))]
right =
      let left' :: [(Rational, Rational)]
left' = [(Rational
accStake, Rational
relativeStake)
                  | (AccPoolStake Rational
accStake, (PoolStake Rational
relativeStake, b
_)) <- [(AccPoolStake, (PoolStake, b))]
left]
          right' :: [(Rational, Rational)]
right' = [(Rational
accStake, Rational
relativeStake)
                   | (AccPoolStake Rational
accStake, (PoolStake Rational
relativeStake, b
_)) <- [(AccPoolStake, (PoolStake, b))]
right]
          go :: (Ratio a, Ratio a) -> (Ratio a, Ratio a) -> Bool
go (Ratio a
accStake, Ratio a
relativeStake)
             (Ratio a
accStake', Ratio a
relativeStake') =
               Ratio a
accStake' Ratio a -> Ratio a -> Ratio a
forall a. Fractional a => a -> a -> a
/ Ratio a
accStake Ratio a -> Ratio a -> Bool
forall a. Ord a => a -> a -> Bool
> a
999999 a -> a -> Ratio a
forall a. Integral a => a -> a -> Ratio a
% a
1000000
            Bool -> Bool -> Bool
&& Ratio a
accStake' Ratio a -> Ratio a -> Ratio a
forall a. Fractional a => a -> a -> a
/ Ratio a
accStake Ratio a -> Ratio a -> Bool
forall a. Ord a => a -> a -> Bool
< a
1000001 a -> a -> Ratio a
forall a. Integral a => a -> a -> Ratio a
% a
1000000
            Bool -> Bool -> Bool
&& Ratio a
relativeStake' Ratio a -> Ratio a -> Ratio a
forall a. Fractional a => a -> a -> a
/ Ratio a
relativeStake Ratio a -> Ratio a -> Bool
forall a. Ord a => a -> a -> Bool
> a
999999 a -> a -> Ratio a
forall a. Integral a => a -> a -> Ratio a
% a
1000000
            Bool -> Bool -> Bool
&& Ratio a
relativeStake' Ratio a -> Ratio a -> Ratio a
forall a. Fractional a => a -> a -> a
/ Ratio a
relativeStake Ratio a -> Ratio a -> Bool
forall a. Ord a => a -> a -> Bool
< a
1000001 a -> a -> Ratio a
forall a. Integral a => a -> a -> Ratio a
% a
1000000

      in (((Rational, Rational), (Rational, Rational)) -> Bool)
-> [((Rational, Rational), (Rational, Rational))] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (((Rational, Rational) -> (Rational, Rational) -> Bool)
-> ((Rational, Rational), (Rational, Rational)) -> Bool
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Rational, Rational) -> (Rational, Rational) -> Bool
forall {a} {a}.
(Integral a, Integral a) =>
(Ratio a, Ratio a) -> (Ratio a, Ratio a) -> Bool
go) ([(Rational, Rational)]
-> [(Rational, Rational)]
-> [((Rational, Rational), (Rational, Rational))]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Rational, Rational)]
left' [(Rational, Rational)]
right')

-- | helper functions for ledgerpeersnapshot encoding tests
--
snapshotV1 :: ArbitrarySlotNo
           -> LedgerPools
           -> LedgerPeerSnapshot
snapshotV1 :: ArbitrarySlotNo -> LedgerPools -> LedgerPeerSnapshot
snapshotV1 (ArbitrarySlotNo SlotNo
slot)
           (LedgerPools [(PoolStake, NonEmpty RelayAccessPoint)]
pools) = (WithOrigin SlotNo,
 [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))])
-> LedgerPeerSnapshot
LedgerPeerSnapshotV1 (WithOrigin SlotNo
originOrSlot, [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
poolStakeWithAccumulation)
  where
    poolStakeWithAccumulation :: [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
poolStakeWithAccumulation = Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
-> [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
forall k a. Map k a -> [(k, a)]
Map.assocs (Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
 -> [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))])
-> ([(PoolStake, NonEmpty RelayAccessPoint)]
    -> Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint))
-> [(PoolStake, NonEmpty RelayAccessPoint)]
-> [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(PoolStake, NonEmpty RelayAccessPoint)]
-> Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
accPoolStake ([(PoolStake, NonEmpty RelayAccessPoint)]
 -> [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))])
-> [(PoolStake, NonEmpty RelayAccessPoint)]
-> [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
forall a b. (a -> b) -> a -> b
$ [(PoolStake, NonEmpty RelayAccessPoint)]
pools
    originOrSlot :: WithOrigin SlotNo
originOrSlot = if SlotNo
slot SlotNo -> SlotNo -> Bool
forall a. Eq a => a -> a -> Bool
== SlotNo
0
                   then WithOrigin SlotNo
forall t. WithOrigin t
Origin
                   else SlotNo -> WithOrigin SlotNo
forall t. t -> WithOrigin t
At SlotNo
slot

-- TODO: Belongs in iosim.
data SimResult a = SimReturn a [String]
                 | SimException SomeException [String]
                 | SimDeadLock [String]

-- Traverses a list of trace events and returns the result along with all log messages.
-- In case of a pure exception, ie an assert, all tracers evaluated so far are returned.
evaluateTrace :: SimTrace a -> IO (SimResult a)
evaluateTrace :: forall a. SimTrace a -> IO (SimResult a)
evaluateTrace = [String] -> SimTrace a -> IO (SimResult a)
forall {m :: * -> *} {a}.
(MonadCatch m, MonadEvaluate m) =>
[String] -> SimTrace a -> m (SimResult a)
go []
  where
    go :: [String] -> SimTrace a -> m (SimResult a)
go [String]
as SimTrace a
tr = do
      r <- m (SimTrace a) -> m (Either SomeException (SimTrace a))
forall e a. Exception e => m a -> m (Either e a)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (SimTrace a -> m (SimTrace a)
forall a. a -> m a
forall (m :: * -> *) a. MonadEvaluate m => a -> m a
evaluate SimTrace a
tr)
      case r of
        Right (SimTrace Time
_ IOSimThreadId
_ Maybe String
_ (EventSay String
s) SimTrace a
tr')      -> [String] -> SimTrace a -> m (SimResult a)
go (String
s String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
as) SimTrace a
tr'
        Right (SimTrace Time
_ IOSimThreadId
_ Maybe String
_ SimEventType
_ SimTrace a
tr' )                -> [String] -> SimTrace a -> m (SimResult a)
go [String]
as SimTrace a
tr'
        Right (SimPORTrace Time
_ IOSimThreadId
_ Int
_ Maybe String
_ (EventSay String
s) SimTrace a
tr') -> [String] -> SimTrace a -> m (SimResult a)
go (String
s String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
as) SimTrace a
tr'
        Right (SimPORTrace Time
_ IOSimThreadId
_ Int
_ Maybe String
_ SimEventType
_ SimTrace a
tr' )           -> [String] -> SimTrace a -> m (SimResult a)
go [String]
as SimTrace a
tr'
        Right (TraceMainReturn Time
_ Labelled IOSimThreadId
_ a
a [Labelled IOSimThreadId]
_)              -> SimResult a -> m (SimResult a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SimResult a -> m (SimResult a)) -> SimResult a -> m (SimResult a)
forall a b. (a -> b) -> a -> b
$ a -> [String] -> SimResult a
forall a. a -> [String] -> SimResult a
SimReturn a
a ([String] -> [String]
forall a. [a] -> [a]
reverse [String]
as)
        Right (TraceMainException Time
_ Labelled IOSimThreadId
_ SomeException
e [Labelled IOSimThreadId]
_)           -> SimResult a -> m (SimResult a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SimResult a -> m (SimResult a)) -> SimResult a -> m (SimResult a)
forall a b. (a -> b) -> a -> b
$ SomeException -> [String] -> SimResult a
forall a. SomeException -> [String] -> SimResult a
SimException SomeException
e ([String] -> [String]
forall a. [a] -> [a]
reverse [String]
as)
        Right (TraceDeadlock Time
_ [Labelled IOSimThreadId]
_)                    -> SimResult a -> m (SimResult a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SimResult a -> m (SimResult a)) -> SimResult a -> m (SimResult a)
forall a b. (a -> b) -> a -> b
$ [String] -> SimResult a
forall a. [String] -> SimResult a
SimDeadLock ([String] -> [String]
forall a. [a] -> [a]
reverse [String]
as)
        Right SimTrace a
TraceLoop                              -> String -> m (SimResult a)
forall a. HasCallStack => String -> a
error String
"IOSimPOR step time limit exceeded"
        Right (TraceInternalError String
e)                 -> String -> m (SimResult a)
forall a. HasCallStack => String -> a
error (String
"IOSim: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
e)
        Left  (SomeException e
e)                      -> SimResult a -> m (SimResult a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SimResult a -> m (SimResult a)) -> SimResult a -> m (SimResult a)
forall a b. (a -> b) -> a -> b
$ SomeException -> [String] -> SimResult a
forall a. SomeException -> [String] -> SimResult a
SimException (e -> SomeException
forall e. (Exception e, HasExceptionContext) => e -> SomeException
SomeException e
e) ([String] -> [String]
forall a. [a] -> [a]
reverse [String]
as)

data WithThreadAndTime a = WithThreadAndTime {
      forall a. WithThreadAndTime a -> Time
wtatOccuredAt    :: !Time
    , forall a. WithThreadAndTime a -> String
wtatWithinThread :: !String
    , forall a. WithThreadAndTime a -> a
wtatEvent        :: !a
    }

instance (Show a) => Show (WithThreadAndTime a) where
    show :: WithThreadAndTime a -> String
show WithThreadAndTime {Time
wtatOccuredAt :: forall a. WithThreadAndTime a -> Time
wtatOccuredAt :: Time
wtatOccuredAt, String
wtatWithinThread :: forall a. WithThreadAndTime a -> String
wtatWithinThread :: String
wtatWithinThread, a
wtatEvent :: forall a. WithThreadAndTime a -> a
wtatEvent :: a
wtatEvent} =
        String -> String -> String -> ShowS
forall r. PrintfType r => String -> r
printf String
"%s: %s: %s" (Time -> String
forall a. Show a => a -> String
show Time
wtatOccuredAt) (ShowS
forall a. Show a => a -> String
show String
wtatWithinThread) (a -> String
forall a. Show a => a -> String
show a
wtatEvent)

verboseTracer :: forall a m. (MonadSay m, Show a)
               => Tracer m a
verboseTracer :: forall a (m :: * -> *). (MonadSay m, Show a) => Tracer m a
verboseTracer = Tracer m a
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer -- threadAndTimeTracer $ Tracer (say . show)

threadAndTimeTracer :: forall a m.
                       ( MonadAsync m
                       , MonadMonotonicTime m
                       )
                    => Tracer m (WithThreadAndTime a) -> Tracer m a
threadAndTimeTracer :: forall a (m :: * -> *).
(MonadAsync m, MonadMonotonicTime m) =>
Tracer m (WithThreadAndTime a) -> Tracer m a
threadAndTimeTracer Tracer m (WithThreadAndTime a)
tr = (a -> m ()) -> Tracer m a
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer ((a -> m ()) -> Tracer m a) -> (a -> m ()) -> Tracer m a
forall a b. (a -> b) -> a -> b
$ \a
s -> do
    !now <- m Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime
    !tid <- show <$> myThreadId
    traceWith tr $! WithThreadAndTime now tid s