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

{-# OPTIONS_GHC -Wno-orphans #-}

module Test.Ouroboros.Network.LedgerPeers where

import Codec.CBOR.FlatTerm
import Control.Concurrent.Class.MonadSTM.Strict
import Control.Exception (SomeException (..))
import Control.Monad (forM)
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.Network.Diffusion.Configuration qualified as Cardano (srvPrefix)
import Cardano.Slotting.Slot (SlotNo (..), WithOrigin (..))
import Ouroboros.Network.PeerSelection.LedgerPeers
import Ouroboros.Network.PeerSelection.LedgerPeers.Utils
           (recomputeRelativeStake)
import Ouroboros.Network.PeerSelection.RootPeersDNS

import Test.Ouroboros.Network.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
    -> LedgerPeersKind
    -> MockRoots
    -> DelayAndTimeoutScripts
    -> SlotNo
    -> Property)
-> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"Pick 100%" Word16
-> NonNegative Int
-> LedgerPeersKind
-> MockRoots
-> DelayAndTimeoutScripts
-> SlotNo
-> Property
prop_pick100
  , String
-> (LedgerPools
    -> LedgerPeersKind
    -> Word16
    -> Word16
    -> MockRoots
    -> Script DNSLookupDelay
    -> SlotNo
    -> Property)
-> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"Pick" LedgerPools
-> LedgerPeersKind
-> Word16
-> Word16
-> MockRoots
-> Script DNSLookupDelay
-> SlotNo
-> 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 -> (SlotNo -> LedgerPools -> SlotNo -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"getLedgerPeers invariants" SlotNo -> LedgerPools -> SlotNo -> Property
prop_getLedgerPeers
  , String
-> (LedgerPeerSnapshotSRVSupport
    -> SlotNo -> LedgerPools -> Property)
-> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"LedgerPeerSnapshot CBOR version 2" LedgerPeerSnapshotSRVSupport -> SlotNo -> LedgerPools -> Property
prop_ledgerPeerSnapshotCBORV2
  , String -> (SlotNo -> LedgerPools -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"LedgerPeerSnapshot JSON version 2" SlotNo -> LedgerPools -> Property
prop_ledgerPeerSnapshotJSONV2
  ]

type ExtraTestInterface = ()


cardanoSRVPrefix :: SRVPrefix
cardanoSRVPrefix :: SRVPrefix
cardanoSRVPrefix = SRVPrefix
Cardano.srvPrefix

data StakePool = StakePool {
      StakePool -> Word64
spStake :: !Word64
    , StakePool -> NonEmpty LedgerRelayAccessPoint
spRelay :: NonEmpty LedgerRelayAccessPoint
    } 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
1, Word64
1_000_000)
        firstRelay <- arbitrary
        moreRelays <- filter (/= firstRelay) . nub <$> arbitrary
        return $ StakePool stake (firstRelay :| moreRelays)

    shrink :: StakePool -> [StakePool]
shrink sp :: StakePool
sp@StakePool { Word64
spStake :: StakePool -> Word64
spStake :: Word64
spStake, NonEmpty LedgerRelayAccessPoint
spRelay :: StakePool -> NonEmpty LedgerRelayAccessPoint
spRelay :: NonEmpty LedgerRelayAccessPoint
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' :: [LedgerRelayAccessPoint]
spRelay'@(LedgerRelayAccessPoint
_ : [LedgerRelayAccessPoint]
_) <- (LedgerRelayAccessPoint -> [LedgerRelayAccessPoint])
-> [LedgerRelayAccessPoint] -> [[LedgerRelayAccessPoint]]
forall a. (a -> [a]) -> [a] -> [[a]]
shrinkList ([LedgerRelayAccessPoint]
-> LedgerRelayAccessPoint -> [LedgerRelayAccessPoint]
forall a b. a -> b -> a
const [])
                                       (NonEmpty LedgerRelayAccessPoint -> [LedgerRelayAccessPoint]
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty LedgerRelayAccessPoint
spRelay)
      ]


newtype LedgerPools =
  LedgerPools { LedgerPools -> [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
getLedgerPools :: [(PoolStake, NonEmpty LedgerRelayAccessPoint)] }
  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 LedgerRelayAccessPoint)] -> LedgerPools
LedgerPools ([(PoolStake, NonEmpty LedgerRelayAccessPoint)] -> LedgerPools)
-> ([StakePool] -> [(PoolStake, NonEmpty LedgerRelayAccessPoint)])
-> [StakePool]
-> LedgerPools
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [StakePool] -> [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
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 Gen [StakePool] -> ([StakePool] -> Bool) -> Gen [StakePool]
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` (\[StakePool]
as -> [Word64] -> Word64
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (StakePool -> Word64
spStake (StakePool -> Word64) -> [StakePool] -> [Word64]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [StakePool]
as) Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> Word64
0)


-- ^ Calculate relative stake.
--
-- PRECONDITION: total stake must be > 0, otherwise the exception `Ratio has
-- zero denominator` is thrown (see
-- <https://github.com/IntersectMBO/ouroboros-network/issues/5091>).
calculateRelativeStake :: [StakePool]
                       -> [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
calculateRelativeStake :: [StakePool] -> [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
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 LedgerRelayAccessPoint))
-> [StakePool] -> [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
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 LedgerRelayAccessPoint
spRelay StakePool
p)) [StakePool]
sps


-- | Enhance a list of pools, each one represented by a list of
-- `RelayAccessPoint`, with a stake.
--
genLedgerPoolsFrom :: [NonEmpty LedgerRelayAccessPoint]
                   -- ^ each inner list denotes relays of one pool.
                   -- PRECONDITION: each inner list must be non-empty.
                   -> Gen LedgerPools
genLedgerPoolsFrom :: [NonEmpty LedgerRelayAccessPoint] -> Gen LedgerPools
genLedgerPoolsFrom [NonEmpty LedgerRelayAccessPoint]
relays = do
  stakePools <-
    [NonEmpty LedgerRelayAccessPoint]
-> (NonEmpty LedgerRelayAccessPoint -> Gen StakePool)
-> Gen [StakePool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [NonEmpty LedgerRelayAccessPoint]
relays (\NonEmpty LedgerRelayAccessPoint
poolRelays -> do
      stake <- (Word64, Word64) -> Gen Word64
forall a. Random a => (a, a) -> Gen a
choose (Word64
0, Word64
1_000_000)
      return $ StakePool stake poolRelays)
    Gen [StakePool] -> ([StakePool] -> Bool) -> Gen [StakePool]
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` (\[StakePool]
pools -> [Word64] -> Word64
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (StakePool -> Word64
spStake (StakePool -> Word64) -> [StakePool] -> [Word64]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [StakePool]
pools) Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> Word64
0)
  return (LedgerPools $ calculateRelativeStake stakePools)


instance Arbitrary LedgerPeersKind where
    arbitrary :: Gen LedgerPeersKind
arbitrary =  [LedgerPeersKind] -> Gen LedgerPeersKind
forall a. HasCallStack => [a] -> Gen a
elements [LedgerPeersKind
AllLedgerPeers, LedgerPeersKind
BigLedgerPeers]
    shrink :: LedgerPeersKind -> [LedgerPeersKind]
shrink LedgerPeersKind
AllLedgerPeers = [LedgerPeersKind
BigLedgerPeers]
    shrink LedgerPeersKind
BigLedgerPeers = []

instance Arbitrary StakeMapOverSource where
  arbitrary :: Gen StakeMapOverSource
arbitrary = do
    peerSnapshot <-
      [Gen (Maybe LedgerPeerSnapshot)] -> Gen (Maybe LedgerPeerSnapshot)
forall a. HasCallStack => [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
    useLedgerAfter <- arbitrary
    ledgerPeers <-
      case (useLedgerAfter, ledgerWithOrigin) of
        (AfterSlot
Always, WithOrigin SlotNo
_) ->
              [(PoolStake, NonEmpty RelayAccessPoint)] -> LedgerPeers
LedgerPeers
            ([(PoolStake, NonEmpty RelayAccessPoint)] -> LedgerPeers)
-> (LedgerPools -> [(PoolStake, NonEmpty RelayAccessPoint)])
-> LedgerPools
-> LedgerPeers
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((PoolStake, NonEmpty LedgerRelayAccessPoint)
 -> (PoolStake, NonEmpty RelayAccessPoint))
-> [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
-> [(PoolStake, NonEmpty RelayAccessPoint)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((NonEmpty LedgerRelayAccessPoint -> NonEmpty RelayAccessPoint)
-> (PoolStake, NonEmpty LedgerRelayAccessPoint)
-> (PoolStake, NonEmpty RelayAccessPoint)
forall a b. (a -> b) -> (PoolStake, a) -> (PoolStake, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((LedgerRelayAccessPoint -> RelayAccessPoint)
-> NonEmpty LedgerRelayAccessPoint -> NonEmpty RelayAccessPoint
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SRVPrefix -> LedgerRelayAccessPoint -> RelayAccessPoint
prefixLedgerRelayAccessPoint SRVPrefix
cardanoSRVPrefix)))
            ([(PoolStake, NonEmpty LedgerRelayAccessPoint)]
 -> [(PoolStake, NonEmpty RelayAccessPoint)])
-> (LedgerPools -> [(PoolStake, NonEmpty LedgerRelayAccessPoint)])
-> LedgerPools
-> [(PoolStake, NonEmpty RelayAccessPoint)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerPools -> [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
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 ->
              [(PoolStake, NonEmpty RelayAccessPoint)] -> LedgerPeers
LedgerPeers
            ([(PoolStake, NonEmpty RelayAccessPoint)] -> LedgerPeers)
-> (LedgerPools -> [(PoolStake, NonEmpty RelayAccessPoint)])
-> LedgerPools
-> LedgerPeers
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((PoolStake, NonEmpty LedgerRelayAccessPoint)
 -> (PoolStake, NonEmpty RelayAccessPoint))
-> [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
-> [(PoolStake, NonEmpty RelayAccessPoint)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((NonEmpty LedgerRelayAccessPoint -> NonEmpty RelayAccessPoint)
-> (PoolStake, NonEmpty LedgerRelayAccessPoint)
-> (PoolStake, NonEmpty RelayAccessPoint)
forall a b. (a -> b) -> (PoolStake, a) -> (PoolStake, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((LedgerRelayAccessPoint -> RelayAccessPoint)
-> NonEmpty LedgerRelayAccessPoint -> NonEmpty RelayAccessPoint
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SRVPrefix -> LedgerRelayAccessPoint -> RelayAccessPoint
prefixLedgerRelayAccessPoint SRVPrefix
cardanoSRVPrefix)))
            ([(PoolStake, NonEmpty LedgerRelayAccessPoint)]
 -> [(PoolStake, NonEmpty RelayAccessPoint)])
-> (LedgerPools -> [(PoolStake, NonEmpty LedgerRelayAccessPoint)])
-> LedgerPools
-> [(PoolStake, NonEmpty RelayAccessPoint)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerPools -> [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
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 (LedgerPeerSnapshotV2 (At SlotNo
slot, [(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))]
accPools))
                   ->
                     let accPools' :: [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
accPools' =
                           ((AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))
 -> (AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint)))
-> [(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))]
-> [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((PoolStake, NonEmpty LedgerRelayAccessPoint)
 -> (PoolStake, NonEmpty RelayAccessPoint))
-> (AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))
-> (AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))
forall a b. (a -> b) -> (AccPoolStake, a) -> (AccPoolStake, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((NonEmpty LedgerRelayAccessPoint -> NonEmpty RelayAccessPoint)
-> (PoolStake, NonEmpty LedgerRelayAccessPoint)
-> (PoolStake, NonEmpty RelayAccessPoint)
forall a b. (a -> b) -> (PoolStake, a) -> (PoolStake, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((LedgerRelayAccessPoint -> RelayAccessPoint)
-> NonEmpty LedgerRelayAccessPoint -> NonEmpty RelayAccessPoint
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SRVPrefix -> LedgerRelayAccessPoint -> RelayAccessPoint
prefixLedgerRelayAccessPoint SRVPrefix
cardanoSRVPrefix)))) [(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))]
accPools
                     in ([(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 $ StakeMapOverSource {
      ledgerWithOrigin,
      ledgerPeers,
      peerSnapshot,
      peerMap,
      bigPeerMap,
      useLedgerAfter,
      cachedSlot,
      srvPrefix = cardanoSRVPrefix
    }
    where
      genWithOrigin :: Gen (WithOrigin SlotNo)
genWithOrigin = do
        slotNo <- Gen SlotNo
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 $ LedgerPeerSnapshotV2 (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 :: StakeMapOverSource
                                 -> Property
prop_ledgerPeerSnapshot_requests :: StakeMapOverSource -> Property
prop_ledgerPeerSnapshot_requests
  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
useLedgerAfter :: StakeMapOverSource -> AfterSlot
useLedgerAfter :: AfterSlot
useLedgerAfter
  }
  =
  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
useLedgerAfter]) (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 [(PoolStake, NonEmpty RelayAccessPoint)]
ledgerPools, Just (LedgerPeerSnapshot (At SlotNo
t', [(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))]
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 :: [NonEmpty RelayAccessPoint]
snapshotRelays = ((AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))
 -> NonEmpty RelayAccessPoint)
-> [(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))]
-> [NonEmpty RelayAccessPoint]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((LedgerRelayAccessPoint -> RelayAccessPoint)
-> NonEmpty LedgerRelayAccessPoint -> NonEmpty RelayAccessPoint
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SRVPrefix -> LedgerRelayAccessPoint -> RelayAccessPoint
prefixLedgerRelayAccessPoint SRVPrefix
cardanoSRVPrefix) (NonEmpty LedgerRelayAccessPoint -> NonEmpty RelayAccessPoint)
-> ((AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))
    -> NonEmpty LedgerRelayAccessPoint)
-> (AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))
-> NonEmpty RelayAccessPoint
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PoolStake, NonEmpty LedgerRelayAccessPoint)
-> NonEmpty LedgerRelayAccessPoint
forall a b. (a, b) -> b
snd ((PoolStake, NonEmpty LedgerRelayAccessPoint)
 -> NonEmpty LedgerRelayAccessPoint)
-> ((AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))
    -> (PoolStake, NonEmpty LedgerRelayAccessPoint))
-> (AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))
-> NonEmpty LedgerRelayAccessPoint
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))
-> (PoolStake, NonEmpty LedgerRelayAccessPoint)
forall a b. (a, b) -> b
snd) [(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))]
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))]
forall relayAccessPoint.
[(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)
forall relayAccessPoint.
[(PoolStake, NonEmpty relayAccessPoint)]
-> Map AccPoolStake (PoolStake, NonEmpty relayAccessPoint)
accPoolStake [(PoolStake, NonEmpty RelayAccessPoint)]
ledgerPools

        (WithOrigin SlotNo
_, LedgerPeers [(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))]
forall relayAccessPoint.
[(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)
forall relayAccessPoint.
[(PoolStake, NonEmpty relayAccessPoint)]
-> Map AccPoolStake (PoolStake, NonEmpty relayAccessPoint)
accPoolStake [(PoolStake, NonEmpty RelayAccessPoint)]
ledgerPools

        (WithOrigin SlotNo
_, LedgerPeers
_, Just (LedgerPeerSnapshot (At SlotNo
t', [(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))]
snapshotAccStake)))
          | After SlotNo
slot <- AfterSlot
useLedgerAfter, 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 :: [NonEmpty RelayAccessPoint]
snapshotRelays = ((AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))
 -> NonEmpty RelayAccessPoint)
-> [(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))]
-> [NonEmpty RelayAccessPoint]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((LedgerRelayAccessPoint -> RelayAccessPoint)
-> NonEmpty LedgerRelayAccessPoint -> NonEmpty RelayAccessPoint
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SRVPrefix -> LedgerRelayAccessPoint -> RelayAccessPoint
prefixLedgerRelayAccessPoint SRVPrefix
cardanoSRVPrefix) (NonEmpty LedgerRelayAccessPoint -> NonEmpty RelayAccessPoint)
-> ((AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))
    -> NonEmpty LedgerRelayAccessPoint)
-> (AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))
-> NonEmpty RelayAccessPoint
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PoolStake, NonEmpty LedgerRelayAccessPoint)
-> NonEmpty LedgerRelayAccessPoint
forall a b. (a, b) -> b
snd ((PoolStake, NonEmpty LedgerRelayAccessPoint)
 -> NonEmpty LedgerRelayAccessPoint)
-> ((AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))
    -> (PoolStake, NonEmpty LedgerRelayAccessPoint))
-> (AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))
-> NonEmpty LedgerRelayAccessPoint
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))
-> (PoolStake, NonEmpty LedgerRelayAccessPoint)
forall a b. (a, b) -> b
snd) [(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))]
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
             -> LedgerPeersKind
             -> MockRoots
             -> DelayAndTimeoutScripts
             -> SlotNo
             -> Property
prop_pick100 :: Word16
-> NonNegative Int
-> LedgerPeersKind
-> MockRoots
-> DelayAndTimeoutScripts
-> SlotNo
-> Property
prop_pick100 Word16
seed (NonNegative Int
n) LedgerPeersKind
ledgerPeersKind (MockRoots [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig ()))]
_ Script MockDNSMap
dnsMapScript Map RelayAccessPoint PeerAdvertise
_ Script MockDNSMap
_)
             (DelayAndTimeoutScripts Script DNSLookupDelay
dnsLookupDelayScript Script DNSTimeout
dnsTimeoutScript)
             SlotNo
slot =
    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 LedgerRelayAccessPoint)]
sps = [ (PoolStake
0, IP -> PortNumber -> LedgerRelayAccessPoint
LedgerRelayAccessAddress (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 LedgerRelayAccessPoint
-> [LedgerRelayAccessPoint] -> NonEmpty LedgerRelayAccessPoint
forall a. a -> [a] -> NonEmpty a
:| [])
              | Int
a <- [Int
0..Int
n]
              ]
           [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
-> [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
-> [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
forall a. [a] -> [a] -> [a]
++ [ (PoolStake
1, IP -> PortNumber -> LedgerRelayAccessPoint
LedgerRelayAccessAddress (String -> IP
forall a. Read a => String -> a
read String
"1.1.1.1") PortNumber
1  LedgerRelayAccessPoint
-> [LedgerRelayAccessPoint] -> NonEmpty LedgerRelayAccessPoint
forall a. a -> [a] -> NonEmpty a
:| []) ]

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

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

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

          dnsSemaphore <- newLedgerAndPublicRootDNSSemaphore

          withLedgerPeers
                PeerActionsDNS { paToPeerAddr = curry IP.toSockAddr,
                                 paDnsActions = mockDNSActions
                                                   (Tracer traceM)
                                                   LookupReqAOnly
                                                   (curry IP.toSockAddr)
                                                   dnsMapVar
                                                   dnsTimeoutScriptVar
                                                   dnsLookupDelayScriptVar }
                WithLedgerPeersArgs { wlpRng = rng,
                                      wlpConsensusInterface = interface,
                                      wlpTracer = verboseTracer,
                                      wlpGetUseLedgerPeers = pure $ UseLedgerPeers Always,
                                      wlpGetLedgerPeerSnapshot = pure Nothing,
                                      wlpSemaphore = dnsSemaphore,
                                      wlpSRVPrefix = cardanoSRVPrefix
                                    }
                (\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) [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
-> ()
-> LedgerPeersConsensusInterface () (IOSim s)
forall extraAPI (m :: * -> *).
STM m (WithOrigin SlotNo)
-> STM m [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
-> extraAPI
-> LedgerPeersConsensusInterface extraAPI 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)
                ([(PoolStake, NonEmpty LedgerRelayAccessPoint)]
-> STM (IOSim s) [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
forall a. a -> STM (IOSim s) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map AccPoolStake (PoolStake, NonEmpty LedgerRelayAccessPoint)
-> [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
forall k a. Map k a -> [a]
Map.elems Map AccPoolStake (PoolStake, NonEmpty LedgerRelayAccessPoint)
accumulatedStakeMap))
                ()

    in String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (Map AccPoolStake (PoolStake, NonEmpty LedgerRelayAccessPoint)
-> String
forall a. Show a => a -> String
show Map AccPoolStake (PoolStake, NonEmpty LedgerRelayAccessPoint)
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
          -> LedgerPeersKind
          -> Word16
          -> Word16
          -> MockRoots
          -> Script DNSLookupDelay
          -> SlotNo
          -> Property
prop_pick :: LedgerPools
-> LedgerPeersKind
-> Word16
-> Word16
-> MockRoots
-> Script DNSLookupDelay
-> SlotNo
-> Property
prop_pick (LedgerPools [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
lps) LedgerPeersKind
ledgerPeersKind Word16
count Word16
seed (MockRoots [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig ()))]
_ Script MockDNSMap
dnsMapScript Map RelayAccessPoint PeerAdvertise
_ Script MockDNSMap
_)
          Script DNSLookupDelay
dnsLookupDelayScript SlotNo
slot =
    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 MockDNSMap
-> IOSim s (StrictTVar (IOSim s) (Script MockDNSMap))
forall (m :: * -> *) a.
MonadSTM m =>
Script a -> m (StrictTVar m (Script a))
initScript' Script MockDNSMap
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
                                                  (Tracer traceM)
                                                  LookupReqAOnly
                                                  (curry IP.toSockAddr)
                                                  dnsMapVar
                                                  dnsTimeoutScriptVar
                                                  dnsLookupDelayScriptVar }
                WithLedgerPeersArgs { wlpRng = rng,
                                      wlpConsensusInterface = interface,
                                      wlpTracer = verboseTracer,
                                      wlpGetUseLedgerPeers = pure $ UseLedgerPeers (After 0),
                                      wlpGetLedgerPeerSnapshot = pure Nothing,
                                      wlpSemaphore = dnsSemaphore,
                                      wlpSRVPrefix = cardanoSRVPrefix
                                    }
                (\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 ExtraTestInterface (IOSim s)
            interface :: forall s. LedgerPeersConsensusInterface () (IOSim s)
interface = STM (IOSim s) (WithOrigin SlotNo)
-> STM (IOSim s) [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
-> ()
-> LedgerPeersConsensusInterface () (IOSim s)
forall extraAPI (m :: * -> *).
STM m (WithOrigin SlotNo)
-> STM m [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
-> extraAPI
-> LedgerPeersConsensusInterface extraAPI 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)
                          ([(PoolStake, NonEmpty LedgerRelayAccessPoint)]
-> STM s [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
forall a. a -> STM s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
lps)
                          ()

            domainMap :: Map Domain (Set IP)
            domainMap :: Map SRVPrefix (Set IP)
domainMap = [(SRVPrefix, Set IP)] -> Map SRVPrefix (Set IP)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(SRVPrefix
"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 [ SRVPrefix
domain
                     | (SRVPrefix
domain, Set IP
addrs) <- Map SRVPrefix (Set IP) -> [(SRVPrefix, Set IP)]
forall k a. Map k a -> [(k, a)]
Map.assocs Map SRVPrefix (Set IP)
domainMap
                     , IP
ip IP -> Set IP -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set IP
addrs
                     ] of
                  (SRVPrefix
domain : [SRVPrefix]
_) -> SRVPrefix -> PortNumber -> RelayAccessPoint
RelayAccessDomain SRVPrefix
domain PortNumber
port
                  [SRVPrefix]
_            -> 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 LedgerRelayAccessPoint)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
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 LedgerRelayAccessPoint)]
lps@((PoolStake, NonEmpty LedgerRelayAccessPoint)
_:[(PoolStake, NonEmpty LedgerRelayAccessPoint)]
_)) =
         -- the accumulated map is non empty, whenever ledger peers set is non
         -- empty
         Bool -> Bool
not (Map AccPoolStake (PoolStake, NonEmpty LedgerRelayAccessPoint)
-> Bool
forall k a. Map k a -> Bool
Map.null Map AccPoolStake (PoolStake, NonEmpty LedgerRelayAccessPoint)
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 LedgerRelayAccessPoint),
 [(PoolStake, NonEmpty LedgerRelayAccessPoint)])
-> String
forall a. Show a => a -> String
show (Map AccPoolStake (PoolStake, NonEmpty LedgerRelayAccessPoint)
accumulatedStakeMap, [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
lps))
           (PoolStake -> Rational
unPoolStake (Sum PoolStake -> PoolStake
forall a. Sum a -> a
getSum (((PoolStake, NonEmpty LedgerRelayAccessPoint) -> Sum PoolStake)
-> Map AccPoolStake (PoolStake, NonEmpty LedgerRelayAccessPoint)
-> 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 LedgerRelayAccessPoint) -> PoolStake)
-> (PoolStake, NonEmpty LedgerRelayAccessPoint)
-> Sum PoolStake
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PoolStake, NonEmpty LedgerRelayAccessPoint) -> PoolStake
forall a b. (a, b) -> a
fst) Map AccPoolStake (PoolStake, NonEmpty LedgerRelayAccessPoint)
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 LedgerRelayAccessPoint) -> PoolStake
forall a b. (a, b) -> a
fst ((PoolStake, NonEmpty LedgerRelayAccessPoint) -> PoolStake)
-> [(PoolStake, NonEmpty LedgerRelayAccessPoint)] -> [PoolStake]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
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 LedgerRelayAccessPoint)]
lps'  = ((PoolStake, NonEmpty LedgerRelayAccessPoint) -> Down PoolStake)
-> [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
-> [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (PoolStake -> Down PoolStake
forall a. a -> Down a
Down (PoolStake -> Down PoolStake)
-> ((PoolStake, NonEmpty LedgerRelayAccessPoint) -> PoolStake)
-> (PoolStake, NonEmpty LedgerRelayAccessPoint)
-> Down PoolStake
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PoolStake, NonEmpty LedgerRelayAccessPoint) -> PoolStake
forall a b. (a, b) -> a
fst) [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
lps
             elems :: [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
elems = Map AccPoolStake (PoolStake, NonEmpty LedgerRelayAccessPoint)
-> [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
forall k a. Map k a -> [a]
Map.elems Map AccPoolStake (PoolStake, NonEmpty LedgerRelayAccessPoint)
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 LedgerRelayAccessPoint)],
 [(PoolStake, NonEmpty LedgerRelayAccessPoint)])
-> String
forall a. Show a => a -> String
show ([(PoolStake, NonEmpty LedgerRelayAccessPoint)]
elems, [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
lps'))
          (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$ [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
elems [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
-> [(PoolStake, NonEmpty LedgerRelayAccessPoint)] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
lps'
  where
    accumulatedStakeMap :: Map AccPoolStake (PoolStake, NonEmpty LedgerRelayAccessPoint)
accumulatedStakeMap = [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
-> Map AccPoolStake (PoolStake, NonEmpty LedgerRelayAccessPoint)
forall relayAccessPoint.
[(PoolStake, NonEmpty relayAccessPoint)]
-> Map AccPoolStake (PoolStake, NonEmpty relayAccessPoint)
accBigPoolStakeMap [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
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 LedgerRelayAccessPoint)]
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. HasCallStack => [a] -> Gen a
elements [LedgerPeersKind
AllLedgerPeers, LedgerPeersKind
BigLedgerPeers]
    reStake :: LedgerPeersKind -> [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
reStake LedgerPeersKind
lpk = LedgerPeersKind
-> [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
-> [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
forall relayAccessPoint.
LedgerPeersKind
-> [(PoolStake, NonEmpty relayAccessPoint)]
-> [(PoolStake, NonEmpty relayAccessPoint)]
recomputeRelativeStake LedgerPeersKind
lpk [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
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 :: SlotNo
                    -> LedgerPools
                    -> SlotNo
                    -> Property
prop_getLedgerPeers :: SlotNo -> LedgerPools -> SlotNo -> Property
prop_getLedgerPeers SlotNo
curSlot
                    (LedgerPools [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
lps)
                    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
$ SRVPrefix
-> LedgerPeersConsensusInterface () (IOSim m)
-> AfterSlot
-> STM (IOSim m) LedgerPeers
forall (m :: * -> *) extraAPI.
MonadSTM m =>
SRVPrefix
-> LedgerPeersConsensusInterface extraAPI m
-> AfterSlot
-> STM m LedgerPeers
getLedgerPeers SRVPrefix
cardanoSRVPrefix 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 [(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 ExtraTestInterface (IOSim s)
    interface :: forall s. LedgerPeersConsensusInterface () (IOSim s)
interface = STM (IOSim s) (WithOrigin SlotNo)
-> STM (IOSim s) [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
-> ()
-> LedgerPeersConsensusInterface () (IOSim s)
forall extraAPI (m :: * -> *).
STM m (WithOrigin SlotNo)
-> STM m [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
-> extraAPI
-> LedgerPeersConsensusInterface extraAPI 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)
                  ([(PoolStake, NonEmpty LedgerRelayAccessPoint)]
-> STM s [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
forall a. a -> STM s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map AccPoolStake (PoolStake, NonEmpty LedgerRelayAccessPoint)
-> [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
forall k a. Map k a -> [a]
Map.elems ([(PoolStake, NonEmpty LedgerRelayAccessPoint)]
-> Map AccPoolStake (PoolStake, NonEmpty LedgerRelayAccessPoint)
forall relayAccessPoint.
[(PoolStake, NonEmpty relayAccessPoint)]
-> Map AccPoolStake (PoolStake, NonEmpty relayAccessPoint)
accPoolStake [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
lps)))
                  ()

instance Arbitrary LedgerPeerSnapshotSRVSupport where
  arbitrary :: Gen LedgerPeerSnapshotSRVSupport
arbitrary = [LedgerPeerSnapshotSRVSupport] -> Gen LedgerPeerSnapshotSRVSupport
forall a. HasCallStack => [a] -> Gen a
elements [ LedgerPeerSnapshotSRVSupport
LedgerPeerSnapshotSupportsSRV
                       , LedgerPeerSnapshotSRVSupport
LedgerPeerSnapshotDoesntSupportSRV
                       ]

-- | Checks validity of LedgerPeerSnapshot CBOR encoding, and whether
--   round trip cycle is the identity function
--
-- TODO: move to `ouroboros-network-api:test`
prop_ledgerPeerSnapshotCBORV2 :: LedgerPeerSnapshotSRVSupport
                              -> SlotNo
                              -> LedgerPools
                              -> Property
prop_ledgerPeerSnapshotCBORV2 :: LedgerPeerSnapshotSRVSupport -> SlotNo -> LedgerPools -> Property
prop_ledgerPeerSnapshotCBORV2 LedgerPeerSnapshotSRVSupport
srvSupport SlotNo
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
result LedgerPeerSnapshot -> LedgerPeerSnapshot -> Bool
forall a. Eq a => a -> a -> Bool
==))
                Either String LedgerPeerSnapshot
decoded
  where
    snapshot :: LedgerPeerSnapshot
snapshot = SlotNo -> LedgerPools -> LedgerPeerSnapshot
snapshotV2 SlotNo
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
. LedgerPeerSnapshotSRVSupport -> LedgerPeerSnapshot -> Encoding
encodeLedgerPeerSnapshot LedgerPeerSnapshotSRVSupport
srvSupport (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 (LedgerPeerSnapshotSRVSupport -> Decoder s LedgerPeerSnapshot
forall s.
LedgerPeerSnapshotSRVSupport -> Decoder s LedgerPeerSnapshot
decodeLedgerPeerSnapshot LedgerPeerSnapshotSRVSupport
srvSupport) FlatTerm
encoded

    result :: LedgerPeerSnapshot
result = case LedgerPeerSnapshotSRVSupport
srvSupport of
      LedgerPeerSnapshotSRVSupport
LedgerPeerSnapshotSupportsSRV      -> LedgerPeerSnapshot
snapshot
      LedgerPeerSnapshotSRVSupport
LedgerPeerSnapshotDoesntSupportSRV ->
          -- filter out SRV records
          (WithOrigin SlotNo,
 [(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))])
-> LedgerPeerSnapshot
LedgerPeerSnapshotV2
            ( WithOrigin SlotNo
slotNo'
            , [ (AccPoolStake
accStake, (PoolStake
stake, [LedgerRelayAccessPoint] -> NonEmpty LedgerRelayAccessPoint
forall a. HasCallStack => [a] -> NonEmpty a
NonEmpty.fromList [LedgerRelayAccessPoint]
relays'))
              | (AccPoolStake
accStake, (PoolStake
stake, NonEmpty LedgerRelayAccessPoint
relays)) <- [(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))]
peers
              , let relays' :: [LedgerRelayAccessPoint]
relays' = (LedgerRelayAccessPoint -> Bool)
-> NonEmpty LedgerRelayAccessPoint -> [LedgerRelayAccessPoint]
forall a. (a -> Bool) -> NonEmpty a -> [a]
NonEmpty.filter
                      (\case
                         LedgerRelayAccessSRVDomain {} -> Bool
False
                         LedgerRelayAccessPoint
_ -> Bool
True
                      )
                      NonEmpty LedgerRelayAccessPoint
relays
              , Bool -> Bool
not ([LedgerRelayAccessPoint] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LedgerRelayAccessPoint]
relays')
              ]
            )
        where
          LedgerPeerSnapshotV2 (WithOrigin SlotNo
slotNo', [(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))]
peers) = LedgerPeerSnapshot
snapshot

-- | Tests if LedgerPeerSnapshot JSON round trip is the identity function
--
-- TODO: move to `ouroboros-network-api:test`
prop_ledgerPeerSnapshotJSONV2 :: SlotNo
                              -> LedgerPools
                              -> Property
prop_ledgerPeerSnapshotJSONV2 :: SlotNo -> LedgerPools -> Property
prop_ledgerPeerSnapshotJSONV2 SlotNo
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 = SlotNo -> LedgerPools -> LedgerPeerSnapshot
snapshotV2 SlotNo
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 LedgerPeerSnapshotV2 (WithOrigin SlotNo
wOrigin, [(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))]
relaysWithAccStake) = LedgerPeerSnapshot
snapshotOriginal
          strippedRelaysWithAccStake :: [NonEmpty LedgerRelayAccessPoint]
strippedRelaysWithAccStake = (AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))
-> NonEmpty LedgerRelayAccessPoint
forall {f :: * -> *} {a} {a}.
Functor f =>
(a, (a, f LedgerRelayAccessPoint)) -> f LedgerRelayAccessPoint
stripFQN ((AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))
 -> NonEmpty LedgerRelayAccessPoint)
-> [(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))]
-> [NonEmpty LedgerRelayAccessPoint]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))]
relaysWithAccStake
          LedgerPeerSnapshotV2 (WithOrigin SlotNo
wOrigin', [(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))]
relaysWithAccStake') = LedgerPeerSnapshot
snapshotRoundTripped
          strippedRelaysWithAccStake' :: [NonEmpty LedgerRelayAccessPoint]
strippedRelaysWithAccStake' = (AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))
-> NonEmpty LedgerRelayAccessPoint
forall {f :: * -> *} {a} {a}.
Functor f =>
(a, (a, f LedgerRelayAccessPoint)) -> f LedgerRelayAccessPoint
stripFQN ((AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))
 -> NonEmpty LedgerRelayAccessPoint)
-> [(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))]
-> [NonEmpty LedgerRelayAccessPoint]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))]
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 LedgerRelayAccessPoint]
strippedRelaysWithAccStake [NonEmpty LedgerRelayAccessPoint]
-> [NonEmpty LedgerRelayAccessPoint] -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== [NonEmpty LedgerRelayAccessPoint]
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 LedgerRelayAccessPoint))]
-> [(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))]
-> Bool
forall {b} {b}.
[(AccPoolStake, (PoolStake, b))]
-> [(AccPoolStake, (PoolStake, b))] -> Bool
compareApprox [(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))]
relaysWithAccStake [(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))]
relaysWithAccStake')

    stripFQN :: (a, (a, f LedgerRelayAccessPoint)) -> f LedgerRelayAccessPoint
stripFQN (a
_, (a
_, f LedgerRelayAccessPoint
relays)) = LedgerRelayAccessPoint -> LedgerRelayAccessPoint
step (LedgerRelayAccessPoint -> LedgerRelayAccessPoint)
-> f LedgerRelayAccessPoint -> f LedgerRelayAccessPoint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f LedgerRelayAccessPoint
relays
    step :: LedgerRelayAccessPoint -> LedgerRelayAccessPoint
step it :: LedgerRelayAccessPoint
it@(LedgerRelayAccessDomain SRVPrefix
domain PortNumber
port) =
      case SRVPrefix -> Maybe (SRVPrefix, Char)
BS.unsnoc SRVPrefix
domain of
        Just (SRVPrefix
prefix, Char
'.') -> SRVPrefix -> PortNumber -> LedgerRelayAccessPoint
LedgerRelayAccessDomain SRVPrefix
prefix PortNumber
port
        Maybe (SRVPrefix, Char)
_otherwise         -> LedgerRelayAccessPoint
it
    step it :: LedgerRelayAccessPoint
it@(LedgerRelayAccessSRVDomain SRVPrefix
domain) =
      case SRVPrefix -> Maybe (SRVPrefix, Char)
BS.unsnoc SRVPrefix
domain of
        Just (SRVPrefix
prefix, Char
'.') -> SRVPrefix -> LedgerRelayAccessPoint
LedgerRelayAccessSRVDomain SRVPrefix
prefix
        Maybe (SRVPrefix, Char)
_otherwise         -> LedgerRelayAccessPoint
it
    step LedgerRelayAccessPoint
it = LedgerRelayAccessPoint
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
--
snapshotV2 :: SlotNo
           -> LedgerPools
           -> LedgerPeerSnapshot
snapshotV2 :: SlotNo -> LedgerPools -> LedgerPeerSnapshot
snapshotV2 SlotNo
slot
           (LedgerPools [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
pools) = (WithOrigin SlotNo,
 [(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))])
-> LedgerPeerSnapshot
LedgerPeerSnapshotV2 (WithOrigin SlotNo
originOrSlot, [(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))]
poolStakeWithAccumulation)
  where
    poolStakeWithAccumulation :: [(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))]
poolStakeWithAccumulation = Map AccPoolStake (PoolStake, NonEmpty LedgerRelayAccessPoint)
-> [(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))]
forall k a. Map k a -> [(k, a)]
Map.assocs (Map AccPoolStake (PoolStake, NonEmpty LedgerRelayAccessPoint)
 -> [(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))])
-> ([(PoolStake, NonEmpty LedgerRelayAccessPoint)]
    -> Map AccPoolStake (PoolStake, NonEmpty LedgerRelayAccessPoint))
-> [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
-> [(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
-> Map AccPoolStake (PoolStake, NonEmpty LedgerRelayAccessPoint)
forall relayAccessPoint.
[(PoolStake, NonEmpty relayAccessPoint)]
-> Map AccPoolStake (PoolStake, NonEmpty relayAccessPoint)
accPoolStake ([(PoolStake, NonEmpty LedgerRelayAccessPoint)]
 -> [(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))])
-> [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
-> [(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))]
forall a b. (a -> b) -> a -> b
$ [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
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