{-# LANGUAGE BangPatterns       #-}
{-# LANGUAGE DataKinds          #-}
{-# LANGUAGE DerivingVia        #-}
{-# LANGUAGE LambdaCase         #-}
{-# LANGUAGE NamedFieldPuns     #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE RankNTypes         #-}
{-# LANGUAGE TypeApplications   #-}
{-# LANGUAGE TypeData           #-}
{-# LANGUAGE TypeFamilies       #-}

{-# 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.Builder (toLazyByteString, word64BE)
import Data.ByteString.Char8 qualified as BS
import Data.ByteString.Lazy qualified as BL
import Data.ByteString.Short (ShortByteString, toShort)
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 Ouroboros.Network.Block
import Ouroboros.Network.Magic
import Ouroboros.Network.PeerSelection.LedgerPeers
import Ouroboros.Network.PeerSelection.LedgerPeers.Utils
           (recomputeRelativeStake)
import Ouroboros.Network.PeerSelection.RootPeersDNS
import Ouroboros.Network.Point (WithOrigin (..))

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
    -> SomeLedgerPeersKind
    -> MockRoots
    -> DelayAndTimeoutScripts
    -> SlotNo
    -> Property)
-> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"Pick 100%" Word16
-> NonNegative Int
-> SomeLedgerPeersKind
-> MockRoots
-> DelayAndTimeoutScripts
-> SlotNo
-> Property
prop_pick100
  , String
-> (LedgerPools
    -> SomeLedgerPeersKind
    -> Word16
    -> Word16
    -> MockRoots
    -> Script DNSLookupDelay
    -> SlotNo
    -> Property)
-> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"Pick" LedgerPools
-> SomeLedgerPeersKind
-> 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 -> Word32 -> LedgerPools -> Bool -> Property)
-> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"LedgerPeerSnapshot CBOR version 3" SlotNo -> Word32 -> LedgerPools -> Bool -> Property
prop_ledgerPeerSnapshotCBORV3
  , String
-> (SlotNo -> (Bool, Bool) -> Word32 -> LedgerPools -> Property)
-> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"LedgerPeerSnapshot JSON version 2/3" SlotNo -> (Bool, Bool) -> Word32 -> LedgerPools -> Property
prop_ledgerPeerSnapshotJSON
  ]

type ExtraTestInterface = ()

cardanoSRVPrefix :: SRVPrefix
cardanoSRVPrefix :: SRVPrefix
cardanoSRVPrefix = SRVPrefix
"_cardano._tcp"

type data MockBlock

type instance HeaderHash MockBlock = Word64

instance StandardHash MockBlock

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 SomeLedgerPeersKind where
    arbitrary :: Gen SomeLedgerPeersKind
arbitrary =  [SomeLedgerPeersKind] -> Gen SomeLedgerPeersKind
forall a. HasCallStack => [a] -> Gen a
elements [ SingLedgerPeersKind AllLedgerPeers -> SomeLedgerPeersKind
forall (k :: LedgerPeersKind).
SingLedgerPeersKind k -> SomeLedgerPeersKind
SomeLedgerPeersKind SingLedgerPeersKind AllLedgerPeers
SingAllLedgerPeers
                          , SingLedgerPeersKind BigLedgerPeers -> SomeLedgerPeersKind
forall (k :: LedgerPeersKind).
SingLedgerPeersKind k -> SomeLedgerPeersKind
SomeLedgerPeersKind SingLedgerPeersKind BigLedgerPeers
SingBigLedgerPeers
                          ]
    shrink :: SomeLedgerPeersKind -> [SomeLedgerPeersKind]
shrink (SomeLedgerPeersKind SingLedgerPeersKind k
SingAllLedgerPeers) = [SingLedgerPeersKind BigLedgerPeers -> SomeLedgerPeersKind
forall (k :: LedgerPeersKind).
SingLedgerPeersKind k -> SomeLedgerPeersKind
SomeLedgerPeersKind SingLedgerPeersKind BigLedgerPeers
SingBigLedgerPeers]
    shrink (SomeLedgerPeersKind SingLedgerPeersKind k
SingBigLedgerPeers) = []

instance Arbitrary StakeMapOverSource where
  arbitrary :: Gen StakeMapOverSource
arbitrary = do
    peerSnapshot <-
      [Gen (Maybe (LedgerPeerSnapshot BigLedgerPeers))]
-> Gen (Maybe (LedgerPeerSnapshot BigLedgerPeers))
forall a. HasCallStack => [Gen a] -> Gen a
oneof [ Maybe (LedgerPeerSnapshot BigLedgerPeers)
-> Gen (Maybe (LedgerPeerSnapshot BigLedgerPeers))
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (LedgerPeerSnapshot BigLedgerPeers)
forall a. Maybe a
Nothing, LedgerPeerSnapshot BigLedgerPeers
-> Maybe (LedgerPeerSnapshot BigLedgerPeers)
forall a. a -> Maybe a
Just (LedgerPeerSnapshot BigLedgerPeers
 -> Maybe (LedgerPeerSnapshot BigLedgerPeers))
-> Gen (LedgerPeerSnapshot BigLedgerPeers)
-> Gen (Maybe (LedgerPeerSnapshot BigLedgerPeers))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (LedgerPeerSnapshot BigLedgerPeers)
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 BigLedgerPeers)
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 BigLedgerPeers)
_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 BigLedgerPeers)
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 BigLedgerPeers)
peerSnapshot :: StakeMapOverSource -> Maybe (LedgerPeerSnapshot BigLedgerPeers)
peerSnapshot :: Maybe (LedgerPeerSnapshot BigLedgerPeers)
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 BigLedgerPeers) -> String
forall a. Show a => a -> String
show Maybe (LedgerPeerSnapshot BigLedgerPeers)
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 BigLedgerPeers)
peerSnapshot) of
        (At SlotNo
t,
         LedgerPeers [(PoolStake, NonEmpty RelayAccessPoint)]
ledgerPools,
         Just (LedgerBigPeerSnapshotV23 BlockPoint { SlotNo
atSlot :: SlotNo
atSlot :: forall {k} (block :: k). Point block -> SlotNo
atSlot } NetworkMagic
_magic [(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))]
snapshotAccStake))
          | SlotNo
atSlot 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 BigLedgerPeers)
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 (LedgerBigPeerSnapshotV23 BlockPoint { SlotNo
atSlot :: forall {k} (block :: k). Point block -> SlotNo
atSlot :: SlotNo
atSlot } NetworkMagic
_magic [(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))]
snapshotAccStake))
          | After SlotNo
slot <- AfterSlot
useLedgerAfter, SlotNo
atSlot 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 BigLedgerPeers))
_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
             -> SomeLedgerPeersKind
             -> MockRoots
             -> DelayAndTimeoutScripts
             -> SlotNo
             -> Property
prop_pick100 :: Word16
-> NonNegative Int
-> SomeLedgerPeersKind
-> MockRoots
-> DelayAndTimeoutScripts
-> SlotNo
-> Property
prop_pick100 Word16
seed (NonNegative Int
n) SomeLedgerPeersKind
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, 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] :: [Int]
              ]
           [(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 :: Map AccPoolStake (PoolStake, NonEmpty LedgerRelayAccessPoint)
accumulatedStakeMap = case SomeLedgerPeersKind
ledgerPeersKind of
          SomeLedgerPeersKind SingLedgerPeersKind k
SingAllLedgerPeers -> [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
-> Map AccPoolStake (PoolStake, NonEmpty LedgerRelayAccessPoint)
forall relayAccessPoint.
[(PoolStake, NonEmpty relayAccessPoint)]
-> Map AccPoolStake (PoolStake, NonEmpty relayAccessPoint)
accPoolStake [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
sps
          SomeLedgerPeersKind SingLedgerPeersKind k
SingBigLedgerPeers -> [(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
-> SomeLedgerPeersKind -> 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
-> SomeLedgerPeersKind -> IOSim s (Maybe (Set SockAddr, DiffTime))
request (Word16 -> NumberOfPeers
NumberOfPeers Word16
1) SomeLedgerPeersKind
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 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 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
          -> SomeLedgerPeersKind
          -> Word16
          -> Word16
          -> MockRoots
          -> Script DNSLookupDelay
          -> SlotNo
          -> Property
prop_pick :: LedgerPools
-> SomeLedgerPeersKind
-> Word16
-> Word16
-> MockRoots
-> Script DNSLookupDelay
-> SlotNo
-> Property
prop_pick (LedgerPools [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
lps) SomeLedgerPeersKind
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
-> SomeLedgerPeersKind -> 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
-> SomeLedgerPeersKind -> IOSim s (Maybe (Set SockAddr, DiffTime))
request (Word16 -> NumberOfPeers
NumberOfPeers Word16
count) SomeLedgerPeersKind
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
  SomeLedgerPeersKind lpk <- Gen SomeLedgerPeersKind
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 SingBigLedgerPeers . recomputeRelativeStake SingBigLedgerPeers $ lps) == recomputeRelativeStake SingBigLedgerPeers lps)
  where
    genLedgerPeersKind :: Gen SomeLedgerPeersKind
genLedgerPeersKind = [SomeLedgerPeersKind] -> Gen SomeLedgerPeersKind
forall a. HasCallStack => [a] -> Gen a
elements [ SingLedgerPeersKind AllLedgerPeers -> SomeLedgerPeersKind
forall (k :: LedgerPeersKind).
SingLedgerPeersKind k -> SomeLedgerPeersKind
SomeLedgerPeersKind SingLedgerPeersKind AllLedgerPeers
SingAllLedgerPeers
                                  , SingLedgerPeersKind BigLedgerPeers -> SomeLedgerPeersKind
forall (k :: LedgerPeersKind).
SingLedgerPeersKind k -> SomeLedgerPeersKind
SomeLedgerPeersKind SingLedgerPeersKind BigLedgerPeers
SingBigLedgerPeers
                                  ]

    reStake :: forall (k :: LedgerPeersKind).
               SingLedgerPeersKind k
            -> [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
    reStake :: forall (k :: LedgerPeersKind).
SingLedgerPeersKind k
-> [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
reStake SingLedgerPeersKind k
lpk = SingLedgerPeersKind k
-> [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
-> [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
forall (k :: LedgerPeersKind) relayAccessPoint.
SingLedgerPeersKind k
-> [(PoolStake, NonEmpty relayAccessPoint)]
-> [(PoolStake, NonEmpty relayAccessPoint)]
recomputeRelativeStake SingLedgerPeersKind k
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 (SomeLedgerPeerSnapshot -> String
forall a. Show a => a -> String
show SomeLedgerPeerSnapshot
someSnapshot) (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
<> [TermToken] -> String
forall a. Show a => a -> String
show [TermToken]
encoded)
                        ([TermToken] -> Bool
validFlatTerm [TermToken]
encoded)
    Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. (String -> Property)
-> (SomeLedgerPeerSnapshot -> Property)
-> Either String SomeLedgerPeerSnapshot
-> 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)
-> (SomeLedgerPeerSnapshot -> String)
-> SomeLedgerPeerSnapshot
-> 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
-> (SomeLedgerPeerSnapshot -> String)
-> SomeLedgerPeerSnapshot
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeLedgerPeerSnapshot -> String
forall a. Show a => a -> String
show (SomeLedgerPeerSnapshot -> Bool -> Property)
-> (SomeLedgerPeerSnapshot -> Bool)
-> SomeLedgerPeerSnapshot
-> Property
forall a b.
(SomeLedgerPeerSnapshot -> a -> b)
-> (SomeLedgerPeerSnapshot -> a) -> SomeLedgerPeerSnapshot -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (SomeLedgerPeerSnapshot
result SomeLedgerPeerSnapshot -> SomeLedgerPeerSnapshot -> Bool
forall a. Eq a => a -> a -> Bool
==))
                Either String SomeLedgerPeerSnapshot
decoded
  where
    someSnapshot :: SomeLedgerPeerSnapshot
someSnapshot = SlotNo -> LedgerPools -> SomeLedgerPeerSnapshot
snapshotV2 SlotNo
slotNo LedgerPools
ledgerPools
    encoded :: [TermToken]
encoded = case SomeLedgerPeerSnapshot
someSnapshot of
      SomeLedgerPeerSnapshot LedgerPeerSnapshot k
snapshot ->
        Encoding -> [TermToken]
toFlatTerm (LedgerPeerSnapshotSRVSupport -> LedgerPeerSnapshot k -> Encoding
forall (a :: LedgerPeersKind).
LedgerPeerSnapshotSRVSupport -> LedgerPeerSnapshot a -> Encoding
encodeLedgerPeerSnapshot LedgerPeerSnapshotSRVSupport
srvSupport LedgerPeerSnapshot k
snapshot)
    decoded :: Either String SomeLedgerPeerSnapshot
decoded = case SomeLedgerPeerSnapshot -> SomeLedgerPeersKind
someLedgerPeerSnapshotKind SomeLedgerPeerSnapshot
someSnapshot of
      SomeLedgerPeersKind SingLedgerPeersKind k
ledgerPeersKind ->
        (forall s. Decoder s SomeLedgerPeerSnapshot)
-> [TermToken] -> Either String SomeLedgerPeerSnapshot
forall a. (forall s. Decoder s a) -> [TermToken] -> Either String a
fromFlatTerm (LedgerPeerSnapshot k -> SomeLedgerPeerSnapshot
forall (k :: LedgerPeersKind).
LedgerPeerSnapshot k -> SomeLedgerPeerSnapshot
SomeLedgerPeerSnapshot (LedgerPeerSnapshot k -> SomeLedgerPeerSnapshot)
-> Decoder s (LedgerPeerSnapshot k)
-> Decoder s SomeLedgerPeerSnapshot
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SingLedgerPeersKind k -> Decoder s (LedgerPeerSnapshot k)
forall s (ledgerPeersKind :: LedgerPeersKind).
SingLedgerPeersKind ledgerPeersKind
-> Decoder s (LedgerPeerSnapshot ledgerPeersKind)
decodeLedgerPeerSnapshot SingLedgerPeersKind k
ledgerPeersKind) [TermToken]
encoded

    result :: SomeLedgerPeerSnapshot
result = case SomeLedgerPeerSnapshot
someSnapshot of
      SomeLedgerPeerSnapshot lps :: LedgerPeerSnapshot k
lps@(LedgerPeerSnapshotV2 (WithOrigin SlotNo
slotNo', [(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))]
peers)) ->
        LedgerPeerSnapshot k -> SomeLedgerPeerSnapshot
forall (k :: LedgerPeersKind).
LedgerPeerSnapshot k -> SomeLedgerPeerSnapshot
SomeLedgerPeerSnapshot (LedgerPeerSnapshot k -> SomeLedgerPeerSnapshot)
-> LedgerPeerSnapshot k -> SomeLedgerPeerSnapshot
forall a b. (a -> b) -> a -> b
$
          case LedgerPeerSnapshotSRVSupport
srvSupport of
            LedgerPeerSnapshotSRVSupport
LedgerPeerSnapshotSupportsSRV      -> LedgerPeerSnapshot k
lps
            LedgerPeerSnapshotSRVSupport
LedgerPeerSnapshotDoesntSupportSRV ->
              (WithOrigin SlotNo,
 [(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))])
-> LedgerPeerSnapshot BigLedgerPeers
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')
                  ]
                )
      SomeLedgerPeerSnapshot
_otherwise -> String -> SomeLedgerPeerSnapshot
forall a. HasCallStack => String -> a
error String
"impossible"


-- TODO: move to `ouroboros-network:api-tests`
prop_ledgerPeerSnapshotCBORV3 :: SlotNo -> Word32 -> LedgerPools -> Bool -> Property
prop_ledgerPeerSnapshotCBORV3 :: SlotNo -> Word32 -> LedgerPools -> Bool -> Property
prop_ledgerPeerSnapshotCBORV3 SlotNo
slotNo Word32
magic LedgerPools
ledgerPools Bool
big =
  String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (SomeLedgerPeerSnapshot -> String
forall a. Show a => a -> String
show SomeLedgerPeerSnapshot
someSnapshot) (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
<> [TermToken] -> String
forall a. Show a => a -> String
show [TermToken]
encoded)
                        ([TermToken] -> Bool
validFlatTerm [TermToken]
encoded)
    Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. (String -> Property)
-> (SomeLedgerPeerSnapshot -> Property)
-> Either String SomeLedgerPeerSnapshot
-> 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)
-> (SomeLedgerPeerSnapshot -> String)
-> SomeLedgerPeerSnapshot
-> 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
-> (SomeLedgerPeerSnapshot -> String)
-> SomeLedgerPeerSnapshot
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeLedgerPeerSnapshot -> String
forall a. Show a => a -> String
show (SomeLedgerPeerSnapshot -> Bool -> Property)
-> (SomeLedgerPeerSnapshot -> Bool)
-> SomeLedgerPeerSnapshot
-> Property
forall a b.
(SomeLedgerPeerSnapshot -> a -> b)
-> (SomeLedgerPeerSnapshot -> a) -> SomeLedgerPeerSnapshot -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (SomeLedgerPeerSnapshot -> SomeLedgerPeerSnapshot -> Bool
forall a. Eq a => a -> a -> Bool
== SomeLedgerPeerSnapshot
someSnapshot))
                Either String SomeLedgerPeerSnapshot
decoded
  where
    someSnapshot :: SomeLedgerPeerSnapshot
someSnapshot = SlotNo
-> NetworkMagic -> LedgerPools -> Bool -> SomeLedgerPeerSnapshot
snapshotV3 SlotNo
slotNo (Word32 -> NetworkMagic
NetworkMagic Word32
magic) LedgerPools
ledgerPools Bool
big
    encoded :: [TermToken]
encoded = case SomeLedgerPeerSnapshot
someSnapshot of
      SomeLedgerPeerSnapshot LedgerPeerSnapshot k
snapshot ->
        Encoding -> [TermToken]
toFlatTerm (LedgerPeerSnapshotSRVSupport -> LedgerPeerSnapshot k -> Encoding
forall (a :: LedgerPeersKind).
LedgerPeerSnapshotSRVSupport -> LedgerPeerSnapshot a -> Encoding
encodeLedgerPeerSnapshot LedgerPeerSnapshotSRVSupport
LedgerPeerSnapshotSupportsSRV LedgerPeerSnapshot k
snapshot)
    decoded :: Either String SomeLedgerPeerSnapshot
decoded = case SomeLedgerPeerSnapshot -> SomeLedgerPeersKind
someLedgerPeerSnapshotKind SomeLedgerPeerSnapshot
someSnapshot of
      SomeLedgerPeersKind SingLedgerPeersKind k
ledgerPeersKind ->
        (forall s. Decoder s SomeLedgerPeerSnapshot)
-> [TermToken] -> Either String SomeLedgerPeerSnapshot
forall a. (forall s. Decoder s a) -> [TermToken] -> Either String a
fromFlatTerm (LedgerPeerSnapshot k -> SomeLedgerPeerSnapshot
forall (k :: LedgerPeersKind).
LedgerPeerSnapshot k -> SomeLedgerPeerSnapshot
SomeLedgerPeerSnapshot (LedgerPeerSnapshot k -> SomeLedgerPeerSnapshot)
-> Decoder s (LedgerPeerSnapshot k)
-> Decoder s SomeLedgerPeerSnapshot
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SingLedgerPeersKind k -> Decoder s (LedgerPeerSnapshot k)
forall s (ledgerPeersKind :: LedgerPeersKind).
SingLedgerPeersKind ledgerPeersKind
-> Decoder s (LedgerPeerSnapshot ledgerPeersKind)
decodeLedgerPeerSnapshot SingLedgerPeersKind k
ledgerPeersKind) [TermToken]
encoded


-- | Tests if LedgerPeerSnapshot JSON round trip is the identity function
--
-- TODO: move to `ouroboros-network-api:test`
prop_ledgerPeerSnapshotJSON :: SlotNo
                            -> (Bool, Bool)
                            -> Word32
                            -> LedgerPools
                            -> Property
prop_ledgerPeerSnapshotJSON :: SlotNo -> (Bool, Bool) -> Word32 -> LedgerPools -> Property
prop_ledgerPeerSnapshotJSON SlotNo
slotNo (Bool
v3, Bool
big) Word32
pureMagic LedgerPools
ledgerPools =
  String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (SomeLedgerPeerSnapshot -> String
forall a. Show a => a -> String
show SomeLedgerPeerSnapshot
someSnapshot) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
     (String -> Property)
-> (SomeLedgerPeerSnapshot -> Property)
-> Either String SomeLedgerPeerSnapshot
-> 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
. ShowS
renderMsg)
            (    String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String -> Property -> Property)
-> (SomeLedgerPeerSnapshot -> String)
-> SomeLedgerPeerSnapshot
-> 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
-> (SomeLedgerPeerSnapshot -> String)
-> SomeLedgerPeerSnapshot
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeLedgerPeerSnapshot -> String
forall a. Show a => a -> String
show
             (SomeLedgerPeerSnapshot -> Property -> Property)
-> (SomeLedgerPeerSnapshot -> Property)
-> SomeLedgerPeerSnapshot
-> Property
forall a b.
(SomeLedgerPeerSnapshot -> a -> b)
-> (SomeLedgerPeerSnapshot -> a) -> SomeLedgerPeerSnapshot -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SomeLedgerPeerSnapshot -> SomeLedgerPeerSnapshot -> Property
nearlyEqualModuloFullyQualified SomeLedgerPeerSnapshot
someSnapshot)
            Either String SomeLedgerPeerSnapshot
someRoundTrip
  where
    renderMsg :: ShowS
renderMsg String
msg = [String] -> String
forall a. Monoid a => [a] -> a
mconcat [String
"JSON decode failed: "
                            , ShowS
forall a. Show a => a -> String
show String
msg
                            , String
"\nNB. JSON encoding: ", Value -> String
forall a. Show a => a -> String
show (Value -> String) -> Value -> String
forall a b. (a -> b) -> a -> b
$ case SomeLedgerPeerSnapshot
someSnapshot of
                                                                SomeLedgerPeerSnapshot LedgerPeerSnapshot k
lps -> LedgerPeerSnapshot k -> Value
forall a. ToJSON a => a -> Value
toJSON LedgerPeerSnapshot k
lps
                            ]

    someSnapshot :: SomeLedgerPeerSnapshot
someSnapshot =
      if Bool
v3
        then SlotNo
-> NetworkMagic -> LedgerPools -> Bool -> SomeLedgerPeerSnapshot
snapshotV3 SlotNo
slotNo (Word32 -> NetworkMagic
NetworkMagic Word32
pureMagic) LedgerPools
ledgerPools Bool
big
        else SlotNo -> LedgerPools -> SomeLedgerPeerSnapshot
snapshotV2 SlotNo
slotNo LedgerPools
ledgerPools

    jsonResult :: Result SomeLedgerPeerSnapshot
jsonResult = case SomeLedgerPeerSnapshot
someSnapshot of
      SomeLedgerPeerSnapshot LedgerPeerSnapshot k
lps -> case LedgerPeerSnapshot k
lps of
        lps' :: LedgerPeerSnapshot k
lps'@LedgerBigPeerSnapshotV23{} ->
          LedgerPeerSnapshot BigLedgerPeers -> SomeLedgerPeerSnapshot
forall (k :: LedgerPeersKind).
LedgerPeerSnapshot k -> SomeLedgerPeerSnapshot
SomeLedgerPeerSnapshot (LedgerPeerSnapshot BigLedgerPeers -> SomeLedgerPeerSnapshot)
-> Result (LedgerPeerSnapshot BigLedgerPeers)
-> Result SomeLedgerPeerSnapshot
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            (forall a. FromJSON a => Value -> Result a
fromJSON @(LedgerPeerSnapshot BigLedgerPeers) (Value -> Result (LedgerPeerSnapshot BigLedgerPeers))
-> (LedgerPeerSnapshot k -> Value)
-> LedgerPeerSnapshot k
-> Result (LedgerPeerSnapshot BigLedgerPeers)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerPeerSnapshot k -> Value
forall a. ToJSON a => a -> Value
toJSON (LedgerPeerSnapshot k
 -> Result (LedgerPeerSnapshot BigLedgerPeers))
-> LedgerPeerSnapshot k
-> Result (LedgerPeerSnapshot BigLedgerPeers)
forall a b. (a -> b) -> a -> b
$ LedgerPeerSnapshot k
lps')
        lps' :: LedgerPeerSnapshot k
lps'@LedgerAllPeerSnapshotV23{} ->
          LedgerPeerSnapshot AllLedgerPeers -> SomeLedgerPeerSnapshot
forall (k :: LedgerPeersKind).
LedgerPeerSnapshot k -> SomeLedgerPeerSnapshot
SomeLedgerPeerSnapshot (LedgerPeerSnapshot AllLedgerPeers -> SomeLedgerPeerSnapshot)
-> Result (LedgerPeerSnapshot AllLedgerPeers)
-> Result SomeLedgerPeerSnapshot
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            (forall a. FromJSON a => Value -> Result a
fromJSON @(LedgerPeerSnapshot AllLedgerPeers) (Value -> Result (LedgerPeerSnapshot AllLedgerPeers))
-> (LedgerPeerSnapshot k -> Value)
-> LedgerPeerSnapshot k
-> Result (LedgerPeerSnapshot AllLedgerPeers)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerPeerSnapshot k -> Value
forall a. ToJSON a => a -> Value
toJSON (LedgerPeerSnapshot k
 -> Result (LedgerPeerSnapshot AllLedgerPeers))
-> LedgerPeerSnapshot k
-> Result (LedgerPeerSnapshot AllLedgerPeers)
forall a b. (a -> b) -> a -> b
$ LedgerPeerSnapshot k
lps')
        lps' :: LedgerPeerSnapshot k
lps'@LedgerPeerSnapshotV2{}     ->
          LedgerPeerSnapshot BigLedgerPeers -> SomeLedgerPeerSnapshot
forall (k :: LedgerPeersKind).
LedgerPeerSnapshot k -> SomeLedgerPeerSnapshot
SomeLedgerPeerSnapshot (LedgerPeerSnapshot BigLedgerPeers -> SomeLedgerPeerSnapshot)
-> Result (LedgerPeerSnapshot BigLedgerPeers)
-> Result SomeLedgerPeerSnapshot
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            (forall a. FromJSON a => Value -> Result a
fromJSON @(LedgerPeerSnapshot BigLedgerPeers) (Value -> Result (LedgerPeerSnapshot BigLedgerPeers))
-> (LedgerPeerSnapshot k -> Value)
-> LedgerPeerSnapshot k
-> Result (LedgerPeerSnapshot BigLedgerPeers)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerPeerSnapshot k -> Value
forall a. ToJSON a => a -> Value
toJSON (LedgerPeerSnapshot k
 -> Result (LedgerPeerSnapshot BigLedgerPeers))
-> LedgerPeerSnapshot k
-> Result (LedgerPeerSnapshot BigLedgerPeers)
forall a b. (a -> b) -> a -> b
$ LedgerPeerSnapshot k
lps')

    someRoundTrip :: Either String SomeLedgerPeerSnapshot
someRoundTrip = case Result SomeLedgerPeerSnapshot
jsonResult of
      Aeson.Success SomeLedgerPeerSnapshot
s -> SomeLedgerPeerSnapshot -> Either String SomeLedgerPeerSnapshot
forall a b. b -> Either a b
Right SomeLedgerPeerSnapshot
s
      Error String
str       -> String -> Either String SomeLedgerPeerSnapshot
forall a b. a -> Either a b
Left String
str

    nearlyEqualModuloFullyQualified :: SomeLedgerPeerSnapshot -> SomeLedgerPeerSnapshot -> Property
    nearlyEqualModuloFullyQualified :: SomeLedgerPeerSnapshot -> SomeLedgerPeerSnapshot -> Property
nearlyEqualModuloFullyQualified (SomeLedgerPeerSnapshot
                                      (LedgerPeerSnapshotV2 (WithOrigin SlotNo
wOrigin, [(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))]
relaysWithAccStake)))
                                    (SomeLedgerPeerSnapshot
                                      (LedgerPeerSnapshotV2 (WithOrigin SlotNo
wOrigin', [(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))]
relaysWithAccStake'))) =
      let 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
          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')

    nearlyEqualModuloFullyQualified (SomeLedgerPeerSnapshot
                                      (LedgerBigPeerSnapshotV23 Point RawBlockHash
point NetworkMagic
magic [(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))]
relaysWithAccStake))
                                    (SomeLedgerPeerSnapshot
                                      (LedgerBigPeerSnapshotV23 Point RawBlockHash
point' NetworkMagic
magic' [(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))]
relaysWithAccStake')) =
      let 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
          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
             Point RawBlockHash
point Point RawBlockHash -> Point RawBlockHash -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Point RawBlockHash
point'
        Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. NetworkMagic
magic NetworkMagic -> NetworkMagic -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== NetworkMagic
magic'
        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')

    nearlyEqualModuloFullyQualified (SomeLedgerPeerSnapshot
                                      (LedgerAllPeerSnapshotV23 Point RawBlockHash
point NetworkMagic
magic [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
relays))
                                    (SomeLedgerPeerSnapshot
                                      (LedgerAllPeerSnapshotV23 Point RawBlockHash
point' NetworkMagic
magic' [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
relays')) =
      let strippedRelays :: [NonEmpty LedgerRelayAccessPoint]
strippedRelays  = (Int, (PoolStake, NonEmpty LedgerRelayAccessPoint))
-> NonEmpty LedgerRelayAccessPoint
forall {f :: * -> *} {a} {a}.
Functor f =>
(a, (a, f LedgerRelayAccessPoint)) -> f LedgerRelayAccessPoint
stripFQN ((Int, (PoolStake, NonEmpty LedgerRelayAccessPoint))
 -> NonEmpty LedgerRelayAccessPoint)
-> [(Int, (PoolStake, NonEmpty LedgerRelayAccessPoint))]
-> [NonEmpty LedgerRelayAccessPoint]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int]
-> [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
-> [(Int, (PoolStake, NonEmpty LedgerRelayAccessPoint))]
forall a b. [a] -> [b] -> [(a, b)]
zip (Int -> [Int]
forall a. a -> [a]
repeat (Int
0 :: Int)) [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
relays
          strippedRelays' :: [NonEmpty LedgerRelayAccessPoint]
strippedRelays' = (Int, (PoolStake, NonEmpty LedgerRelayAccessPoint))
-> NonEmpty LedgerRelayAccessPoint
forall {f :: * -> *} {a} {a}.
Functor f =>
(a, (a, f LedgerRelayAccessPoint)) -> f LedgerRelayAccessPoint
stripFQN ((Int, (PoolStake, NonEmpty LedgerRelayAccessPoint))
 -> NonEmpty LedgerRelayAccessPoint)
-> [(Int, (PoolStake, NonEmpty LedgerRelayAccessPoint))]
-> [NonEmpty LedgerRelayAccessPoint]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int]
-> [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
-> [(Int, (PoolStake, NonEmpty LedgerRelayAccessPoint))]
forall a b. [a] -> [b] -> [(a, b)]
zip (Int -> [Int]
forall a. a -> [a]
repeat (Int
0 :: Int)) [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
relays'
      in
             Point RawBlockHash
point Point RawBlockHash -> Point RawBlockHash -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Point RawBlockHash
point'
        Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. NetworkMagic
magic NetworkMagic -> NetworkMagic -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== NetworkMagic
magic'
        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]
strippedRelays [NonEmpty LedgerRelayAccessPoint]
-> [NonEmpty LedgerRelayAccessPoint] -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== [NonEmpty LedgerRelayAccessPoint]
strippedRelays')

    nearlyEqualModuloFullyQualified SomeLedgerPeerSnapshot
_ SomeLedgerPeerSnapshot
_ = Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False

    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
           -> SomeLedgerPeerSnapshot
snapshotV2 :: SlotNo -> LedgerPools -> SomeLedgerPeerSnapshot
snapshotV2 SlotNo
slot
           (LedgerPools [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
pools) =
  LedgerPeerSnapshot BigLedgerPeers -> SomeLedgerPeerSnapshot
forall (k :: LedgerPeersKind).
LedgerPeerSnapshot k -> SomeLedgerPeerSnapshot
SomeLedgerPeerSnapshot (LedgerPeerSnapshot BigLedgerPeers -> SomeLedgerPeerSnapshot)
-> LedgerPeerSnapshot BigLedgerPeers -> SomeLedgerPeerSnapshot
forall a b. (a -> b) -> a -> b
$ (WithOrigin SlotNo,
 [(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))])
-> LedgerPeerSnapshot BigLedgerPeers
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

snapshotV3 :: SlotNo -> NetworkMagic -> LedgerPools -> Bool -> SomeLedgerPeerSnapshot
snapshotV3 :: SlotNo
-> NetworkMagic -> LedgerPools -> Bool -> SomeLedgerPeerSnapshot
snapshotV3 SlotNo
slotNo NetworkMagic
magic (LedgerPools [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
pools) Bool
big = SomeLedgerPeerSnapshot
snapshot
  where
    snapshot :: SomeLedgerPeerSnapshot
snapshot =
      if Bool
big
        then let point :: Point RawBlockHash
point = SlotNo -> HeaderHash RawBlockHash -> Point RawBlockHash
forall {k} (block :: k). SlotNo -> HeaderHash block -> Point block
BlockPoint SlotNo
slotNo (ShortByteString -> RawBlockHash
RawBlockHash (Word64 -> ShortByteString
word64ToShortBS (Word64 -> ShortByteString) -> Word64 -> ShortByteString
forall a b. (a -> b) -> a -> b
$ SlotNo -> Word64
unSlotNo SlotNo
slotNo))
                 bigPools :: [(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))]
bigPools = 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
                 lps :: LedgerPeerSnapshot BigLedgerPeers
lps  = Point RawBlockHash
-> NetworkMagic
-> [(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))]
-> LedgerPeerSnapshot BigLedgerPeers
LedgerBigPeerSnapshotV23 Point RawBlockHash
point NetworkMagic
magic [(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))]
bigPools
              in LedgerPeerSnapshot BigLedgerPeers -> SomeLedgerPeerSnapshot
forall (k :: LedgerPeersKind).
LedgerPeerSnapshot k -> SomeLedgerPeerSnapshot
SomeLedgerPeerSnapshot LedgerPeerSnapshot BigLedgerPeers
lps
        else let point :: Point RawBlockHash
point = SlotNo -> HeaderHash RawBlockHash -> Point RawBlockHash
forall {k} (block :: k). SlotNo -> HeaderHash block -> Point block
BlockPoint SlotNo
slotNo (ShortByteString -> RawBlockHash
RawBlockHash (Word64 -> ShortByteString
word64ToShortBS (Word64 -> ShortByteString) -> Word64 -> ShortByteString
forall a b. (a -> b) -> a -> b
$ SlotNo -> Word64
unSlotNo SlotNo
slotNo))
                 lps :: LedgerPeerSnapshot AllLedgerPeers
lps = Point RawBlockHash
-> NetworkMagic
-> [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
-> LedgerPeerSnapshot AllLedgerPeers
LedgerAllPeerSnapshotV23 Point RawBlockHash
point NetworkMagic
magic [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
pools
              in LedgerPeerSnapshot AllLedgerPeers -> SomeLedgerPeerSnapshot
forall (k :: LedgerPeersKind).
LedgerPeerSnapshot k -> SomeLedgerPeerSnapshot
SomeLedgerPeerSnapshot LedgerPeerSnapshot AllLedgerPeers
lps

    -- Converts Word64 of the slot number to ShortByteString using Big-Endian encoding
    word64ToShortBS :: Word64 -> ShortByteString
    word64ToShortBS :: Word64 -> ShortByteString
word64ToShortBS = SRVPrefix -> ShortByteString
toShort (SRVPrefix -> ShortByteString)
-> (Word64 -> SRVPrefix) -> Word64 -> ShortByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LazyByteString -> SRVPrefix
BL.toStrict (LazyByteString -> SRVPrefix)
-> (Word64 -> LazyByteString) -> Word64 -> SRVPrefix
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> LazyByteString
toLazyByteString (Builder -> LazyByteString)
-> (Word64 -> Builder) -> Word64 -> LazyByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Builder
word64BE


-- 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