{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE DerivingVia         #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE NumericUnderscores  #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE PatternSynonyms     #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# 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.Char8 qualified as BS
import Data.IP qualified as IP
import Data.List as List (foldl', intercalate, isPrefixOf, nub, sortOn)
import Data.List.NonEmpty qualified as NonEmpty
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Monoid (Sum (..))
import Data.Ord (Down (..))
import Data.Proxy
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
    -> LedgerPeersKind
    -> MockRoots
    -> DelayAndTimeoutScripts
    -> SlotNo
    -> Property)
-> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"Pick 100%" Word16
-> NonNegative Int
-> LedgerPeersKind
-> MockRoots
-> DelayAndTimeoutScripts
-> SlotNo
-> Property
prop_pick100
  , String
-> (LedgerPools
    -> LedgerPeersKind
    -> Word16
    -> Word16
    -> MockRoots
    -> Script DNSLookupDelay
    -> SlotNo
    -> Property)
-> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"Pick" LedgerPools
-> LedgerPeersKind
-> Word16
-> Word16
-> MockRoots
-> Script DNSLookupDelay
-> SlotNo
-> Property
prop_pick
  , String -> (LedgerPools -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"accumulateBigLedgerStake" LedgerPools -> Property
prop_accumulateBigLedgerStake
  , String -> (LedgerPools -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"recomputeRelativeStake" LedgerPools -> Property
prop_recomputeRelativeStake
  , String -> (SlotNo -> LedgerPools -> SlotNo -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"getLedgerPeers invariants" SlotNo -> LedgerPools -> SlotNo -> Property
prop_getLedgerPeers
  , String
-> (LedgerPeerSnapshotSRVSupport
    -> SlotNo -> LedgerPools -> Property)
-> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"LedgerPeerSnapshot CBOR version 2" LedgerPeerSnapshotSRVSupport -> SlotNo -> LedgerPools -> Property
prop_ledgerPeerSnapshotCBORV2
  , String
-> (SlotNo -> 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 LedgerPeersKind where
    arbitrary :: Gen LedgerPeersKind
arbitrary =  [LedgerPeersKind] -> Gen LedgerPeersKind
forall a. HasCallStack => [a] -> Gen a
elements [LedgerPeersKind
AllLedgerPeers, LedgerPeersKind
BigLedgerPeers]
    shrink :: LedgerPeersKind -> [LedgerPeersKind]
shrink LedgerPeersKind
AllLedgerPeers = [LedgerPeersKind
BigLedgerPeers]
    shrink LedgerPeersKind
BigLedgerPeers = []

instance Arbitrary StakeMapOverSource where
  arbitrary :: Gen StakeMapOverSource
arbitrary = do
    peerSnapshot <-
      [Gen (Maybe (LedgerPeerSnapshot '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
             -> LedgerPeersKind
             -> MockRoots
             -> DelayAndTimeoutScripts
             -> SlotNo
             -> Property
prop_pick100 :: Word16
-> NonNegative Int
-> LedgerPeersKind
-> MockRoots
-> DelayAndTimeoutScripts
-> SlotNo
-> Property
prop_pick100 Word16
seed (NonNegative Int
n) LedgerPeersKind
ledgerPeersKind (MockRoots [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig ()))]
_ Script MockDNSMap
dnsMapScript Map RelayAccessPoint PeerAdvertise
_ Script MockDNSMap
_)
             (DelayAndTimeoutScripts Script DNSLookupDelay
dnsLookupDelayScript Script DNSTimeout
dnsTimeoutScript)
             SlotNo
slot =
    let rng :: StdGen
rng = Int -> StdGen
mkStdGen (Int -> StdGen) -> Int -> StdGen
forall a b. (a -> b) -> a -> b
$ Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
seed
        sps :: [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
sps = [ (PoolStake
0, IP -> PortNumber -> LedgerRelayAccessPoint
LedgerRelayAccessAddress (String -> IP
forall a. Read a => String -> a
read (String -> IP) -> String -> IP
forall a b. (a -> b) -> a -> b
$ String
"0.0.0." String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
a) PortNumber
1 LedgerRelayAccessPoint
-> [LedgerRelayAccessPoint] -> NonEmpty LedgerRelayAccessPoint
forall a. a -> [a] -> NonEmpty a
:| [])
              | Int
a <- [Int
0..Int
n]
              ]
           [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
-> [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
-> [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
forall a. [a] -> [a] -> [a]
++ [ (PoolStake
1, IP -> PortNumber -> LedgerRelayAccessPoint
LedgerRelayAccessAddress (String -> IP
forall a. Read a => String -> a
read String
"1.1.1.1") PortNumber
1  LedgerRelayAccessPoint
-> [LedgerRelayAccessPoint] -> NonEmpty LedgerRelayAccessPoint
forall a. a -> [a] -> NonEmpty a
:| []) ]

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

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

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

          dnsSemaphore <- newLedgerAndPublicRootDNSSemaphore

          withLedgerPeers
                PeerActionsDNS { paToPeerAddr = curry IP.toSockAddr,
                                 paDnsActions = mockDNSActions
                                                   (Tracer traceM)
                                                   LookupReqAOnly
                                                   (curry IP.toSockAddr)
                                                   dnsMapVar
                                                   dnsTimeoutScriptVar
                                                   dnsLookupDelayScriptVar }
                WithLedgerPeersArgs { wlpRng = rng,
                                      wlpConsensusInterface = interface,
                                      wlpTracer = verboseTracer,
                                      wlpGetUseLedgerPeers = pure $ UseLedgerPeers Always,
                                      wlpGetLedgerPeerSnapshot = pure Nothing,
                                      wlpSemaphore = dnsSemaphore,
                                      wlpSRVPrefix = cardanoSRVPrefix
                                    }
                (\NumberOfPeers
-> LedgerPeersKind -> IOSim s (Maybe (Set SockAddr, DiffTime))
request Async (IOSim s) Void
_ -> do
                  DiffTime -> IOSim s ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
1900 -- we need to invalidate ledger peer's cache
                  resp <- NumberOfPeers
-> LedgerPeersKind -> IOSim s (Maybe (Set SockAddr, DiffTime))
request (Word16 -> NumberOfPeers
NumberOfPeers Word16
1) LedgerPeersKind
ledgerPeersKind
                  pure $ case resp of
                    Maybe (Set SockAddr, DiffTime)
Nothing          -> []
                    Just (Set SockAddr
peers, DiffTime
_)  -> [ IP -> PortNumber -> RelayAccessPoint
RelayAccessAddress IP
ip PortNumber
port
                                        | Just (IP
ip, PortNumber
port) <- SockAddr -> Maybe (IP, PortNumber)
IP.fromSockAddr
                                                         (SockAddr -> Maybe (IP, PortNumber))
-> [SockAddr] -> [Maybe (IP, PortNumber)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set SockAddr -> [SockAddr]
forall a. Set a -> [a]
Set.toList Set SockAddr
peers
                                        ]
                )
          where
            interface :: LedgerPeersConsensusInterface () (IOSim s)
interface =
              STM (IOSim s) (WithOrigin SlotNo)
-> STM (IOSim s) [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
-> ()
-> LedgerPeersConsensusInterface () (IOSim s)
forall extraAPI (m :: * -> *).
STM m (WithOrigin SlotNo)
-> STM m [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
-> extraAPI
-> LedgerPeersConsensusInterface extraAPI m
LedgerPeersConsensusInterface
                (WithOrigin SlotNo -> STM (IOSim s) (WithOrigin SlotNo)
forall a. a -> STM (IOSim s) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WithOrigin SlotNo -> STM (IOSim s) (WithOrigin SlotNo))
-> WithOrigin SlotNo -> STM (IOSim s) (WithOrigin SlotNo)
forall a b. (a -> b) -> a -> b
$ SlotNo -> WithOrigin SlotNo
forall t. t -> WithOrigin t
At SlotNo
slot)
                ([(PoolStake, NonEmpty LedgerRelayAccessPoint)]
-> STM 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
          -> LedgerPeersKind
          -> Word16
          -> Word16
          -> MockRoots
          -> Script DNSLookupDelay
          -> SlotNo
          -> Property
prop_pick :: LedgerPools
-> LedgerPeersKind
-> Word16
-> Word16
-> MockRoots
-> Script DNSLookupDelay
-> SlotNo
-> Property
prop_pick (LedgerPools [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
lps) LedgerPeersKind
ledgerPeersKind Word16
count Word16
seed (MockRoots [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig ()))]
_ Script MockDNSMap
dnsMapScript Map RelayAccessPoint PeerAdvertise
_ Script MockDNSMap
_)
          Script DNSLookupDelay
dnsLookupDelayScript SlotNo
slot =
    let rng :: StdGen
rng = Int -> StdGen
mkStdGen (Int -> StdGen) -> Int -> StdGen
forall a b. (a -> b) -> a -> b
$ Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
seed

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

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

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

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

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



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


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

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

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

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


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

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

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

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

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

-- | Checks validity of LedgerPeerSnapshot CBOR encoding, and whether
--   round trip cycle is the identity function
--
-- TODO: move to `ouroboros-network-api:test`
prop_ledgerPeerSnapshotCBORV2 :: LedgerPeerSnapshotSRVSupport
                              -> SlotNo
                              -> LedgerPools
                              -> Property
prop_ledgerPeerSnapshotCBORV2 :: LedgerPeerSnapshotSRVSupport -> SlotNo -> LedgerPools -> Property
prop_ledgerPeerSnapshotCBORV2 LedgerPeerSnapshotSRVSupport
srvSupport SlotNo
slotNo
                              LedgerPools
ledgerPools =
  String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (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
<> FlatTerm -> String
forall a. Show a => a -> String
show FlatTerm
encoded)
                        (FlatTerm -> Bool
validFlatTerm FlatTerm
encoded)
    Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. (String -> Property)
-> (LedgerPeerSnapshot 'BigLedgerPeers -> Property)
-> Either String (LedgerPeerSnapshot 'BigLedgerPeers)
-> Property
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ((String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
`counterexample` Bool
False) (String -> Property) -> ShowS -> String -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"CBOR decode failed: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<>))
                (String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String -> Bool -> Property)
-> (LedgerPeerSnapshot 'BigLedgerPeers -> String)
-> LedgerPeerSnapshot 'BigLedgerPeers
-> Bool
-> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"CBOR round trip failed: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<>) ShowS
-> (LedgerPeerSnapshot 'BigLedgerPeers -> String)
-> LedgerPeerSnapshot 'BigLedgerPeers
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerPeerSnapshot 'BigLedgerPeers -> String
forall a. Show a => a -> String
show (LedgerPeerSnapshot 'BigLedgerPeers -> Bool -> Property)
-> (LedgerPeerSnapshot 'BigLedgerPeers -> Bool)
-> LedgerPeerSnapshot 'BigLedgerPeers
-> Property
forall a b.
(LedgerPeerSnapshot 'BigLedgerPeers -> a -> b)
-> (LedgerPeerSnapshot 'BigLedgerPeers -> a)
-> LedgerPeerSnapshot 'BigLedgerPeers
-> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (LedgerPeerSnapshot 'BigLedgerPeers
result LedgerPeerSnapshot 'BigLedgerPeers
-> LedgerPeerSnapshot 'BigLedgerPeers -> Bool
forall a. Eq a => a -> a -> Bool
==))
                Either String (LedgerPeerSnapshot 'BigLedgerPeers)
decoded
  where
    someSnapshot :: SomeLedgerPeerSnapshot
someSnapshot = SlotNo -> LedgerPools -> SomeLedgerPeerSnapshot
snapshotV2 SlotNo
slotNo LedgerPools
ledgerPools
    encoded :: FlatTerm
encoded = Encoding -> FlatTerm
toFlatTerm (Encoding -> FlatTerm)
-> (SomeLedgerPeerSnapshot -> Encoding)
-> SomeLedgerPeerSnapshot
-> FlatTerm
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerPeerSnapshotSRVSupport -> SomeLedgerPeerSnapshot -> Encoding
encodeLedgerPeerSnapshot' LedgerPeerSnapshotSRVSupport
srvSupport (SomeLedgerPeerSnapshot -> FlatTerm)
-> SomeLedgerPeerSnapshot -> FlatTerm
forall a b. (a -> b) -> a -> b
$ SomeLedgerPeerSnapshot
someSnapshot
    decoded :: Either String (LedgerPeerSnapshot 'BigLedgerPeers)
decoded = SomeLedgerPeerSnapshot -> LedgerPeerSnapshot 'BigLedgerPeers
unwrap (SomeLedgerPeerSnapshot -> LedgerPeerSnapshot 'BigLedgerPeers)
-> Either String SomeLedgerPeerSnapshot
-> Either String (LedgerPeerSnapshot 'BigLedgerPeers)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall s. Decoder s SomeLedgerPeerSnapshot)
-> FlatTerm -> Either String SomeLedgerPeerSnapshot
forall a. (forall s. Decoder s a) -> FlatTerm -> Either String a
fromFlatTerm (Proxy MockBlock -> Decoder s SomeLedgerPeerSnapshot
forall s blk.
(FromCBOR (HeaderHash blk), ToCBOR (HeaderHash blk),
 ToJSON (HeaderHash blk), StandardHash blk, Typeable blk) =>
Proxy blk -> Decoder s SomeLedgerPeerSnapshot
decodeLedgerPeerSnapshot (Proxy MockBlock
forall {k} (t :: k). Proxy t
Proxy :: Proxy MockBlock)) FlatTerm
encoded
    unwrap :: SomeLedgerPeerSnapshot -> LedgerPeerSnapshot BigLedgerPeers
    unwrap :: SomeLedgerPeerSnapshot -> LedgerPeerSnapshot 'BigLedgerPeers
unwrap = \case
      SomeLedgerPeerSnapshot Proxy k
_ lps :: LedgerPeerSnapshot k
lps@LedgerPeerSnapshotV2{} -> LedgerPeerSnapshot k
LedgerPeerSnapshot 'BigLedgerPeers
lps
      SomeLedgerPeerSnapshot
_otherwise -> String -> LedgerPeerSnapshot 'BigLedgerPeers
forall a. HasCallStack => String -> a
error String
"impossible"

    result :: LedgerPeerSnapshot 'BigLedgerPeers
result = case SomeLedgerPeerSnapshot
someSnapshot of
      SomeLedgerPeerSnapshot Proxy k
_ lps :: LedgerPeerSnapshot k
lps@(LedgerPeerSnapshotV2 (WithOrigin SlotNo
slotNo', [(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))]
peers)) ->
        case LedgerPeerSnapshotSRVSupport
srvSupport of
          LedgerPeerSnapshotSRVSupport
LedgerPeerSnapshotSupportsSRV      -> LedgerPeerSnapshot k
LedgerPeerSnapshot 'BigLedgerPeers
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 -> LedgerPeerSnapshot 'BigLedgerPeers
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
<> FlatTerm -> String
forall a. Show a => a -> String
show FlatTerm
encoded)
                        (FlatTerm -> Bool
validFlatTerm FlatTerm
encoded)
    Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. (String -> Property)
-> (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 -> Bool
cmp)
                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 :: FlatTerm
encoded = Encoding -> FlatTerm
toFlatTerm (Encoding -> FlatTerm)
-> (SomeLedgerPeerSnapshot -> Encoding)
-> SomeLedgerPeerSnapshot
-> FlatTerm
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerPeerSnapshotSRVSupport -> SomeLedgerPeerSnapshot -> Encoding
encodeLedgerPeerSnapshot' LedgerPeerSnapshotSRVSupport
LedgerPeerSnapshotSupportsSRV (SomeLedgerPeerSnapshot -> FlatTerm)
-> SomeLedgerPeerSnapshot -> FlatTerm
forall a b. (a -> b) -> a -> b
$ SomeLedgerPeerSnapshot
someSnapshot
    decoded :: Either String SomeLedgerPeerSnapshot
decoded = (forall s. Decoder s SomeLedgerPeerSnapshot)
-> FlatTerm -> Either String SomeLedgerPeerSnapshot
forall a. (forall s. Decoder s a) -> FlatTerm -> Either String a
fromFlatTerm (Proxy MockBlock -> Decoder s SomeLedgerPeerSnapshot
forall s blk.
(FromCBOR (HeaderHash blk), ToCBOR (HeaderHash blk),
 ToJSON (HeaderHash blk), StandardHash blk, Typeable blk) =>
Proxy blk -> Decoder s SomeLedgerPeerSnapshot
decodeLedgerPeerSnapshot (Proxy MockBlock
forall {k} (t :: k). Proxy t
Proxy :: Proxy MockBlock)) FlatTerm
encoded
    cmp :: SomeLedgerPeerSnapshot -> Bool
cmp SomeLedgerPeerSnapshot
decoded' = case (SomeLedgerPeerSnapshot
someSnapshot, SomeLedgerPeerSnapshot
decoded') of
      (SomeLedgerPeerSnapshot Proxy k
_ LedgerPeerSnapshot k
someSnapshot',
       SomeLedgerPeerSnapshot Proxy k
_ LedgerPeerSnapshot k
decoded'')-> case (LedgerPeerSnapshot k
someSnapshot', LedgerPeerSnapshot k
decoded'') of
        (lps :: LedgerPeerSnapshot k
lps@LedgerBigPeerSnapshotV23{}, lps' :: LedgerPeerSnapshot k
lps'@LedgerBigPeerSnapshotV23{}) -> LedgerPeerSnapshot k
lps LedgerPeerSnapshot k -> LedgerPeerSnapshot k -> Bool
forall a. Eq a => a -> a -> Bool
== LedgerPeerSnapshot k
LedgerPeerSnapshot k
lps'
        (lps :: LedgerPeerSnapshot k
lps@LedgerAllPeerSnapshotV23{}, lps' :: LedgerPeerSnapshot k
lps'@LedgerAllPeerSnapshotV23{}) -> LedgerPeerSnapshot k
lps LedgerPeerSnapshot k -> LedgerPeerSnapshot k -> Bool
forall a. Eq a => a -> a -> Bool
== LedgerPeerSnapshot k
LedgerPeerSnapshot k
lps'
        (LedgerPeerSnapshot k, LedgerPeerSnapshot k)
_otherwise -> Bool
False


-- | 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 Proxy k
_ 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 Proxy k
_ LedgerPeerSnapshot k
lps -> case LedgerPeerSnapshot k
lps of
        lps' :: LedgerPeerSnapshot k
lps'@LedgerBigPeerSnapshotV23{} ->
          Proxy 'BigLedgerPeers
-> LedgerPeerSnapshot 'BigLedgerPeers -> SomeLedgerPeerSnapshot
forall (k :: LedgerPeersKind).
Typeable k =>
Proxy k -> LedgerPeerSnapshot k -> SomeLedgerPeerSnapshot
SomeLedgerPeerSnapshot Proxy 'BigLedgerPeers
forall {k} (t :: k). Proxy t
Proxy (LedgerPeerSnapshot 'BigLedgerPeers -> SomeLedgerPeerSnapshot)
-> Result (LedgerPeerSnapshot 'BigLedgerPeers)
-> Result SomeLedgerPeerSnapshot
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            ((LedgerPeerSnapshotWithBlock MockBlock 'BigLedgerPeers
 -> LedgerPeerSnapshot 'BigLedgerPeers)
-> Result (LedgerPeerSnapshotWithBlock MockBlock 'BigLedgerPeers)
-> Result (LedgerPeerSnapshot 'BigLedgerPeers)
forall a b. (a -> b) -> Result a -> Result b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall blk (a :: LedgerPeersKind).
LedgerPeerSnapshotWithBlock blk a -> LedgerPeerSnapshot a
parseLedgerPeerSnapshotWithBlock @MockBlock @BigLedgerPeers) (Result (LedgerPeerSnapshotWithBlock MockBlock 'BigLedgerPeers)
 -> Result (LedgerPeerSnapshot 'BigLedgerPeers))
-> (LedgerPeerSnapshot k
    -> Result (LedgerPeerSnapshotWithBlock MockBlock 'BigLedgerPeers))
-> LedgerPeerSnapshot k
-> Result (LedgerPeerSnapshot 'BigLedgerPeers)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value
-> Result (LedgerPeerSnapshotWithBlock MockBlock 'BigLedgerPeers)
forall a. FromJSON a => Value -> Result a
fromJSON (Value
 -> Result (LedgerPeerSnapshotWithBlock MockBlock 'BigLedgerPeers))
-> (LedgerPeerSnapshot k -> Value)
-> LedgerPeerSnapshot k
-> Result (LedgerPeerSnapshotWithBlock MockBlock '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{} ->
          Proxy 'AllLedgerPeers
-> LedgerPeerSnapshot 'AllLedgerPeers -> SomeLedgerPeerSnapshot
forall (k :: LedgerPeersKind).
Typeable k =>
Proxy k -> LedgerPeerSnapshot k -> SomeLedgerPeerSnapshot
SomeLedgerPeerSnapshot Proxy 'AllLedgerPeers
forall {k} (t :: k). Proxy t
Proxy (LedgerPeerSnapshot 'AllLedgerPeers -> SomeLedgerPeerSnapshot)
-> Result (LedgerPeerSnapshot 'AllLedgerPeers)
-> Result SomeLedgerPeerSnapshot
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            ((LedgerPeerSnapshotWithBlock MockBlock 'AllLedgerPeers
 -> LedgerPeerSnapshot 'AllLedgerPeers)
-> Result (LedgerPeerSnapshotWithBlock MockBlock 'AllLedgerPeers)
-> Result (LedgerPeerSnapshot 'AllLedgerPeers)
forall a b. (a -> b) -> Result a -> Result b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall blk (a :: LedgerPeersKind).
LedgerPeerSnapshotWithBlock blk a -> LedgerPeerSnapshot a
parseLedgerPeerSnapshotWithBlock @MockBlock @AllLedgerPeers) (Result (LedgerPeerSnapshotWithBlock MockBlock 'AllLedgerPeers)
 -> Result (LedgerPeerSnapshot 'AllLedgerPeers))
-> (LedgerPeerSnapshot k
    -> Result (LedgerPeerSnapshotWithBlock MockBlock 'AllLedgerPeers))
-> LedgerPeerSnapshot k
-> Result (LedgerPeerSnapshot 'AllLedgerPeers)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value
-> Result (LedgerPeerSnapshotWithBlock MockBlock 'AllLedgerPeers)
forall a. FromJSON a => Value -> Result a
fromJSON (Value
 -> Result (LedgerPeerSnapshotWithBlock MockBlock 'AllLedgerPeers))
-> (LedgerPeerSnapshot k -> Value)
-> LedgerPeerSnapshot k
-> Result (LedgerPeerSnapshotWithBlock MockBlock '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{}     ->
          Proxy 'BigLedgerPeers
-> LedgerPeerSnapshot 'BigLedgerPeers -> SomeLedgerPeerSnapshot
forall (k :: LedgerPeersKind).
Typeable k =>
Proxy k -> LedgerPeerSnapshot k -> SomeLedgerPeerSnapshot
SomeLedgerPeerSnapshot Proxy 'BigLedgerPeers
forall {k} (t :: k). Proxy t
Proxy (LedgerPeerSnapshot 'BigLedgerPeers -> SomeLedgerPeerSnapshot)
-> Result (LedgerPeerSnapshot 'BigLedgerPeers)
-> Result SomeLedgerPeerSnapshot
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            ((LedgerPeerSnapshotWithBlock MockBlock 'BigLedgerPeers
 -> LedgerPeerSnapshot 'BigLedgerPeers)
-> Result (LedgerPeerSnapshotWithBlock MockBlock 'BigLedgerPeers)
-> Result (LedgerPeerSnapshot 'BigLedgerPeers)
forall a b. (a -> b) -> Result a -> Result b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall blk (a :: LedgerPeersKind).
LedgerPeerSnapshotWithBlock blk a -> LedgerPeerSnapshot a
parseLedgerPeerSnapshotWithBlock @MockBlock @BigLedgerPeers) (Result (LedgerPeerSnapshotWithBlock MockBlock 'BigLedgerPeers)
 -> Result (LedgerPeerSnapshot 'BigLedgerPeers))
-> (LedgerPeerSnapshot k
    -> Result (LedgerPeerSnapshotWithBlock MockBlock 'BigLedgerPeers))
-> LedgerPeerSnapshot k
-> Result (LedgerPeerSnapshot 'BigLedgerPeers)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value
-> Result (LedgerPeerSnapshotWithBlock MockBlock 'BigLedgerPeers)
forall a. FromJSON a => Value -> Result a
fromJSON (Value
 -> Result (LedgerPeerSnapshotWithBlock MockBlock 'BigLedgerPeers))
-> (LedgerPeerSnapshot k -> Value)
-> LedgerPeerSnapshot k
-> Result (LedgerPeerSnapshotWithBlock MockBlock '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 Proxy k
_
                                      (LedgerPeerSnapshotV2 (WithOrigin SlotNo
wOrigin, [(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))]
relaysWithAccStake)))
                                    (SomeLedgerPeerSnapshot Proxy k
_
                                      (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 Proxy k
_
                                      (LedgerBigPeerSnapshotV23 Point SomeHashableBlock
point NetworkMagic
magic [(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))]
relaysWithAccStake))
                                    (SomeLedgerPeerSnapshot Proxy k
_
                                      (LedgerBigPeerSnapshotV23 Point SomeHashableBlock
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 SomeHashableBlock
point Point SomeHashableBlock -> Point SomeHashableBlock -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Point SomeHashableBlock
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 Proxy k
_
                                      (LedgerAllPeerSnapshotV23 Point SomeHashableBlock
point NetworkMagic
magic [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
relays))
                                    (SomeLedgerPeerSnapshot Proxy k
_
                                      (LedgerAllPeerSnapshotV23 Point SomeHashableBlock
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 SomeHashableBlock
point Point SomeHashableBlock -> Point SomeHashableBlock -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Point SomeHashableBlock
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) =
  Proxy 'BigLedgerPeers
-> LedgerPeerSnapshot 'BigLedgerPeers -> SomeLedgerPeerSnapshot
forall (k :: LedgerPeersKind).
Typeable k =>
Proxy k -> LedgerPeerSnapshot k -> SomeLedgerPeerSnapshot
SomeLedgerPeerSnapshot Proxy 'BigLedgerPeers
forall {k} (t :: k). Proxy t
Proxy (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 SomeHashableBlock
point = SlotNo -> HeaderHash SomeHashableBlock -> Point SomeHashableBlock
forall {k} (block :: k). SlotNo -> HeaderHash block -> Point block
BlockPoint SlotNo
slotNo (Proxy MockBlock -> HeaderHash MockBlock -> SomeHashableBlock
forall blk.
(StandardHash blk, ToCBOR (HeaderHash blk),
 FromCBOR (HeaderHash blk), ToJSON (HeaderHash blk),
 Typeable blk) =>
Proxy blk -> HeaderHash blk -> SomeHashableBlock
SomeHashableBlock (Proxy MockBlock
forall {k} (t :: k). Proxy t
Proxy :: Proxy MockBlock) (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 SomeHashableBlock
-> NetworkMagic
-> [(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))]
-> LedgerPeerSnapshot 'BigLedgerPeers
LedgerBigPeerSnapshotV23 Point SomeHashableBlock
point NetworkMagic
magic [(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))]
bigPools
              in Proxy 'BigLedgerPeers
-> LedgerPeerSnapshot 'BigLedgerPeers -> SomeLedgerPeerSnapshot
forall (k :: LedgerPeersKind).
Typeable k =>
Proxy k -> LedgerPeerSnapshot k -> SomeLedgerPeerSnapshot
SomeLedgerPeerSnapshot Proxy 'BigLedgerPeers
forall {k} (t :: k). Proxy t
Proxy LedgerPeerSnapshot 'BigLedgerPeers
lps
        else let point :: Point SomeHashableBlock
point = SlotNo -> HeaderHash SomeHashableBlock -> Point SomeHashableBlock
forall {k} (block :: k). SlotNo -> HeaderHash block -> Point block
BlockPoint SlotNo
slotNo (Proxy MockBlock -> HeaderHash MockBlock -> SomeHashableBlock
forall blk.
(StandardHash blk, ToCBOR (HeaderHash blk),
 FromCBOR (HeaderHash blk), ToJSON (HeaderHash blk),
 Typeable blk) =>
Proxy blk -> HeaderHash blk -> SomeHashableBlock
SomeHashableBlock (Proxy MockBlock
forall {k} (t :: k). Proxy t
Proxy :: Proxy MockBlock) (SlotNo -> Word64
unSlotNo SlotNo
slotNo))
                 lps :: LedgerPeerSnapshot 'AllLedgerPeers
lps = Point SomeHashableBlock
-> NetworkMagic
-> [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
-> LedgerPeerSnapshot 'AllLedgerPeers
LedgerAllPeerSnapshotV23 Point SomeHashableBlock
point NetworkMagic
magic [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
pools
              in Proxy 'AllLedgerPeers
-> LedgerPeerSnapshot 'AllLedgerPeers -> SomeLedgerPeerSnapshot
forall (k :: LedgerPeersKind).
Typeable k =>
Proxy k -> LedgerPeerSnapshot k -> SomeLedgerPeerSnapshot
SomeLedgerPeerSnapshot Proxy 'AllLedgerPeers
forall {k} (t :: k). Proxy t
Proxy LedgerPeerSnapshot 'AllLedgerPeers
lps


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