{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
module Test.Cardano.Ledger.Shelley.Rules.IncrementalStake (
incrStakeComputationTest,
incrStakeComparisonTest,
stakeDistr,
aggregateUtxoCoinByCredential,
) where
import Test.Cardano.Ledger.Shelley.Rules.TestChain (
TestingLedger,
forAllChainTrace,
ledgerTraceFromBlock,
longTraceLen,
traceLen,
)
import Cardano.Ledger.Address (Addr (..))
import Cardano.Ledger.Coin
import Cardano.Ledger.Compactible (fromCompact)
import Cardano.Ledger.Core
import Cardano.Ledger.Credential (Credential (..), Ptr, StakeReference (StakeRefBase, StakeRefPtr))
import Cardano.Ledger.EpochBoundary (SnapShot (..), Stake (..))
import Cardano.Ledger.Keys (KeyHash, KeyRole (StakePool, Staking))
import Cardano.Ledger.Shelley.Core
import Cardano.Ledger.Shelley.LedgerState (
CertState (..),
DState (..),
EpochState (..),
IncrementalStake (..),
LedgerState (..),
NewEpochState (..),
PState (..),
UTxOState (..),
credMap,
curPParamsEpochStateL,
incrementalStakeDistr,
ptrsMap,
)
import qualified Cardano.Ledger.UMap as UM
import Cardano.Ledger.UTxO (UTxO (..), coinBalance)
import Control.SetAlgebra (dom, eval, (▷), (◁))
import Data.Foldable (fold)
import Data.Map (Map)
import qualified Data.Map.Strict as Map
import Data.Proxy
import qualified Data.VMap as VMap
import Lens.Micro hiding (ix)
import Test.Cardano.Ledger.Shelley.Constants (defaultConstants)
import Test.Cardano.Ledger.Shelley.Generator.Core (GenEnv)
import Test.Cardano.Ledger.Shelley.Generator.EraGen (EraGen (..))
import Test.Cardano.Ledger.Shelley.Generator.ShelleyEraGen ()
import Test.Cardano.Ledger.Shelley.Rules.Chain (CHAIN, ChainState (..))
import Test.Cardano.Ledger.Shelley.Utils (
ChainProperty,
)
import Test.Cardano.Ledger.TerseTools (tersemapdiffs)
import Test.Control.State.Transition.Trace (
SourceSignalTarget (..),
sourceSignalTargets,
)
import qualified Test.Control.State.Transition.Trace.Generator.QuickCheck as QC
import Test.QuickCheck (
Property,
conjoin,
counterexample,
(===),
)
import Test.Tasty (TestTree)
import Test.Tasty.QuickCheck (testProperty)
incrStakeComputationTest ::
forall era ledger.
( EraGen era
, TestingLedger era ledger
, ChainProperty era
, QC.HasTrace (CHAIN era) (GenEnv era)
) =>
TestTree
incrStakeComputationTest :: forall era ledger.
(EraGen era, TestingLedger era ledger, ChainProperty era,
HasTrace (CHAIN era) (GenEnv era)) =>
TestTree
incrStakeComputationTest =
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"incremental stake calc" forall a b. (a -> b) -> a -> b
$
forall era prop.
(Testable prop, EraGen era, HasTrace (CHAIN era) (GenEnv era),
EraGov era) =>
Word64 -> Constants -> (Trace (CHAIN era) -> prop) -> Property
forAllChainTrace @era Word64
longTraceLen Constants
defaultConstants forall a b. (a -> b) -> a -> b
$ \Trace (CHAIN era)
tr -> do
let ssts :: [SourceSignalTarget (CHAIN era)]
ssts = forall a. Trace a -> [SourceSignalTarget a]
sourceSignalTargets Trace (CHAIN era)
tr
forall prop. Testable prop => [prop] -> Property
conjoin forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$
[
forall a b. (a -> b) -> [a] -> [b]
map (forall era ledger.
(EraSegWits era, ChainProperty era, TestingLedger era ledger) =>
SourceSignalTarget (CHAIN era) -> Property
incrStakeComp @era @ledger) [SourceSignalTarget (CHAIN era)]
ssts
]
incrStakeComp ::
forall era ledger.
(EraSegWits era, ChainProperty era, TestingLedger era ledger) =>
SourceSignalTarget (CHAIN era) ->
Property
incrStakeComp :: forall era ledger.
(EraSegWits era, ChainProperty era, TestingLedger era ledger) =>
SourceSignalTarget (CHAIN era) -> Property
incrStakeComp SourceSignalTarget {source :: forall a. SourceSignalTarget a -> State a
source = State (CHAIN era)
chainSt, signal :: forall a. SourceSignalTarget a -> Signal a
signal = Signal (CHAIN era)
block} =
forall prop. Testable prop => [prop] -> Property
conjoin forall a b. (a -> b) -> a -> b
$
forall a b. (a -> b) -> [a] -> [b]
map SourceSignalTarget ledger -> Property
checkIncrStakeComp forall a b. (a -> b) -> a -> b
$
forall a. Trace a -> [SourceSignalTarget a]
sourceSignalTargets Trace ledger
ledgerTr
where
(ChainState era
_, Trace ledger
ledgerTr) = forall era ledger.
(ChainProperty era, EraSegWits era, TestingLedger era ledger) =>
ChainState era
-> Block (BHeader (EraCrypto era)) era
-> (ChainState era, Trace ledger)
ledgerTraceFromBlock @era @ledger State (CHAIN era)
chainSt Signal (CHAIN era)
block
checkIncrStakeComp :: SourceSignalTarget ledger -> Property
checkIncrStakeComp :: SourceSignalTarget ledger -> Property
checkIncrStakeComp
SourceSignalTarget
{ source :: forall a. SourceSignalTarget a -> State a
source = LedgerState UTxOState {utxosUtxo :: forall era. UTxOState era -> UTxO era
utxosUtxo = UTxO era
u, utxosStakeDistr :: forall era. UTxOState era -> IncrementalStake (EraCrypto era)
utxosStakeDistr = IncrementalStake (EraCrypto era)
sd} CertState era
dp
, signal :: forall a. SourceSignalTarget a -> Signal a
signal = Signal ledger
tx
, target :: forall a. SourceSignalTarget a -> State a
target = LedgerState UTxOState {utxosUtxo :: forall era. UTxOState era -> UTxO era
utxosUtxo = UTxO era
u', utxosStakeDistr :: forall era. UTxOState era -> IncrementalStake (EraCrypto era)
utxosStakeDistr = IncrementalStake (EraCrypto era)
sd'} CertState era
dp'
} =
forall prop. Testable prop => TestName -> prop -> Property
counterexample
( forall a. Monoid a => [a] -> a
mconcat
( [ TestName
"\nDetails:\n"
, TestName
"\ntx\n"
, forall a. Show a => a -> TestName
show Signal ledger
tx
, TestName
"\nsize original utxo\n"
, forall a. Show a => a -> TestName
show (forall k a. Map k a -> Int
Map.size forall a b. (a -> b) -> a -> b
$ forall era. UTxO era -> Map (TxIn (EraCrypto era)) (TxOut era)
unUTxO UTxO era
u)
, TestName
"\noriginal utxo\n"
, forall a. Show a => a -> TestName
show UTxO era
u
, TestName
"\noriginal sd\n"
, forall a. Show a => a -> TestName
show IncrementalStake (EraCrypto era)
sd
, TestName
"\nfinal utxo\n"
, forall a. Show a => a -> TestName
show UTxO era
u'
, TestName
"\nfinal sd\n"
, forall a. Show a => a -> TestName
show IncrementalStake (EraCrypto era)
sd'
, TestName
"\noriginal ptrs\n"
, forall a. Show a => a -> TestName
show Map Ptr (Credential 'Staking (EraCrypto era))
ptrs
, TestName
"\nfinal ptrs\n"
, forall a. Show a => a -> TestName
show Map Ptr (Credential 'Staking (EraCrypto era))
ptrs'
]
)
)
forall a b. (a -> b) -> a -> b
$ Coin
utxoBal forall a. (Eq a, Show a) => a -> a -> Property
=== forall a. Compactible a => CompactForm a -> a
fromCompact CompactForm Coin
incrStakeBal
where
utxoBal :: Coin
utxoBal = forall era. EraTxOut era => UTxO era -> Coin
coinBalance UTxO era
u'
incrStakeBal :: CompactForm Coin
incrStakeBal = forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (forall c.
IncrementalStake c
-> Map (Credential 'Staking c) (CompactForm Coin)
credMap IncrementalStake (EraCrypto era)
sd') forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (forall c. IncrementalStake c -> Map Ptr (CompactForm Coin)
ptrMap IncrementalStake (EraCrypto era)
sd')
ptrs :: Map Ptr (Credential 'Staking (EraCrypto era))
ptrs = forall era.
DState era -> Map Ptr (Credential 'Staking (EraCrypto era))
ptrsMap forall a b. (a -> b) -> a -> b
$ forall era. CertState era -> DState era
certDState CertState era
dp
ptrs' :: Map Ptr (Credential 'Staking (EraCrypto era))
ptrs' = forall era.
DState era -> Map Ptr (Credential 'Staking (EraCrypto era))
ptrsMap forall a b. (a -> b) -> a -> b
$ forall era. CertState era -> DState era
certDState CertState era
dp'
incrStakeComparisonTest ::
forall era.
( EraGen era
, QC.HasTrace (CHAIN era) (GenEnv era)
, EraGov era
) =>
Proxy era ->
TestTree
incrStakeComparisonTest :: forall era.
(EraGen era, HasTrace (CHAIN era) (GenEnv era), EraGov era) =>
Proxy era -> TestTree
incrStakeComparisonTest Proxy era
Proxy =
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"Incremental stake distribution at epoch boundaries agrees" forall a b. (a -> b) -> a -> b
$
forall era prop.
(Testable prop, EraGen era, HasTrace (CHAIN era) (GenEnv era),
EraGov era) =>
Word64 -> Constants -> (Trace (CHAIN era) -> prop) -> Property
forAllChainTrace Word64
traceLen Constants
defaultConstants forall a b. (a -> b) -> a -> b
$ \Trace (CHAIN era)
tr ->
forall prop. Testable prop => [prop] -> Property
conjoin forall a b. (a -> b) -> a -> b
$
forall a b. (a -> b) -> [a] -> [b]
map (\(SourceSignalTarget State (CHAIN era)
_ State (CHAIN era)
target Signal (CHAIN era)
_) -> forall era.
(EraTxOut era, EraGov era) =>
EpochState era -> Property
checkIncrementalStake @era ((forall era. NewEpochState era -> EpochState era
nesEs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. ChainState era -> NewEpochState era
chainNes) State (CHAIN era)
target)) forall a b. (a -> b) -> a -> b
$
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a} {era}.
(State a ~ ChainState era) =>
SourceSignalTarget a -> Bool
sameEpoch) (forall a. Trace a -> [SourceSignalTarget a]
sourceSignalTargets Trace (CHAIN era)
tr)
where
sameEpoch :: SourceSignalTarget a -> Bool
sameEpoch SourceSignalTarget {State a
source :: State a
source :: forall a. SourceSignalTarget a -> State a
source, State a
target :: State a
target :: forall a. SourceSignalTarget a -> State a
target} = forall {era}. ChainState era -> EpochNo
epoch State a
source forall a. Eq a => a -> a -> Bool
== forall {era}. ChainState era -> EpochNo
epoch State a
target
epoch :: ChainState era -> EpochNo
epoch = forall era. NewEpochState era -> EpochNo
nesEL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. ChainState era -> NewEpochState era
chainNes
checkIncrementalStake ::
forall era.
(EraTxOut era, EraGov era) =>
EpochState era ->
Property
checkIncrementalStake :: forall era.
(EraTxOut era, EraGov era) =>
EpochState era -> Property
checkIncrementalStake EpochState era
es =
let
(LedgerState (UTxOState UTxO era
utxo Coin
_ Coin
_ GovState era
_ IncrementalStake (EraCrypto era)
incStake Coin
_) (CertState VState era
_vstate PState era
pstate DState era
dstate)) = forall era. EpochState era -> LedgerState era
esLState EpochState era
es
stake :: SnapShot (EraCrypto era)
stake = forall era.
EraTxOut era =>
UTxO era -> DState era -> PState era -> SnapShot (EraCrypto era)
stakeDistr @era UTxO era
utxo DState era
dstate PState era
pstate
istake :: SnapShot (EraCrypto era)
istake = forall era.
EraPParams era =>
PParams era
-> IncrementalStake (EraCrypto era)
-> DState era
-> PState era
-> SnapShot (EraCrypto era)
incrementalStakeDistr (EpochState era
es forall s a. s -> Getting a s a -> a
^. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL) IncrementalStake (EraCrypto era)
incStake DState era
dstate PState era
pstate
in
forall prop. Testable prop => TestName -> prop -> Property
counterexample
( TestName
"\nIncremental stake distribution does not match old style stake distribution"
forall a. [a] -> [a] -> [a]
++ forall c. TestName -> Stake c -> Stake c -> TestName
tersediffincremental TestName
"differences: Old vs Incremental" (forall c. SnapShot c -> Stake c
ssStake SnapShot (EraCrypto era)
stake) (forall c. SnapShot c -> Stake c
ssStake SnapShot (EraCrypto era)
istake)
)
(SnapShot (EraCrypto era)
stake forall a. (Eq a, Show a) => a -> a -> Property
=== SnapShot (EraCrypto era)
istake)
tersediffincremental :: String -> Stake c -> Stake c -> String
tersediffincremental :: forall c. TestName -> Stake c -> Stake c -> TestName
tersediffincremental TestName
message (Stake VMap VB VP (Credential 'Staking c) (CompactForm Coin)
a) (Stake VMap VB VP (Credential 'Staking c) (CompactForm Coin)
c) =
forall a b.
(Terse a, Terse b, Ord a, Eq b) =>
TestName -> Map a b -> Map a b -> TestName
tersemapdiffs (TestName
message forall a. [a] -> [a] -> [a]
++ TestName
" " forall a. [a] -> [a] -> [a]
++ TestName
"hashes") (VMap VB VP (Credential 'Staking c) (CompactForm Coin)
-> Map (Credential 'Staking c) Coin
mp VMap VB VP (Credential 'Staking c) (CompactForm Coin)
a) (VMap VB VP (Credential 'Staking c) (CompactForm Coin)
-> Map (Credential 'Staking c) Coin
mp VMap VB VP (Credential 'Staking c) (CompactForm Coin)
c)
where
mp :: VMap VB VP (Credential 'Staking c) (CompactForm Coin)
-> Map (Credential 'Staking c) Coin
mp = forall a b k. (a -> b) -> Map k a -> Map k b
Map.map forall a. Compactible a => CompactForm a -> a
fromCompact forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kv :: * -> *) k (vv :: * -> *) v.
(Vector kv k, Vector vv v) =>
VMap kv vv k v -> Map k v
VMap.toMap
stakeDistr ::
forall era.
EraTxOut era =>
UTxO era ->
DState era ->
PState era ->
SnapShot (EraCrypto era)
stakeDistr :: forall era.
EraTxOut era =>
UTxO era -> DState era -> PState era -> SnapShot (EraCrypto era)
stakeDistr UTxO era
u DState era
ds PState era
ps =
forall c.
Stake c
-> VMap VB VB (Credential 'Staking c) (KeyHash 'StakePool c)
-> VMap VB VB (KeyHash 'StakePool c) (PoolParams c)
-> SnapShot c
SnapShot
(forall c.
VMap VB VP (Credential 'Staking c) (CompactForm Coin) -> Stake c
Stake forall a b. (a -> b) -> a -> b
$ forall (kv :: * -> *) k (vv :: * -> *) v.
(Vector kv k, Vector vv v) =>
Map k v -> VMap kv vv k v
VMap.fromMap (HasCallStack => Coin -> CompactForm Coin
UM.compactCoinOrError forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s t. Embed s t => Exp t -> s
eval (forall k s (f :: * -> * -> *) v.
(Ord k, HasExp s (f k v)) =>
s -> Exp (Sett k ())
dom Map
(Credential 'Staking (EraCrypto era))
(KeyHash 'StakePool (EraCrypto era))
activeDelegs forall k s1 s2 (f :: * -> * -> *) v.
(Ord k, HasExp s1 (Sett k ()), HasExp s2 (f k v)) =>
s1 -> s2 -> Exp (f k v)
◁ Map (Credential 'Staking (EraCrypto era)) Coin
stakeRelation)))
(forall (kv :: * -> *) k (vv :: * -> *) v.
(Vector kv k, Vector vv v) =>
Map k v -> VMap kv vv k v
VMap.fromMap Map
(Credential 'Staking (EraCrypto era))
(KeyHash 'StakePool (EraCrypto era))
delegs)
(forall (kv :: * -> *) k (vv :: * -> *) v.
(Vector kv k, Vector vv v) =>
Map k v -> VMap kv vv k v
VMap.fromMap Map
(KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
poolParams)
where
rewards' :: Map.Map (Credential 'Staking (EraCrypto era)) Coin
rewards' :: Map (Credential 'Staking (EraCrypto era)) Coin
rewards' = forall c. UMap c -> Map (Credential 'Staking c) Coin
UM.rewardMap (forall era. DState era -> UMap (EraCrypto era)
dsUnified DState era
ds)
delegs :: Map.Map (Credential 'Staking (EraCrypto era)) (KeyHash 'StakePool (EraCrypto era))
delegs :: Map
(Credential 'Staking (EraCrypto era))
(KeyHash 'StakePool (EraCrypto era))
delegs = forall c.
UMap c -> Map (Credential 'Staking c) (KeyHash 'StakePool c)
UM.sPoolMap (forall era. DState era -> UMap (EraCrypto era)
dsUnified DState era
ds)
ptrs' :: Map Ptr (Credential 'Staking (EraCrypto era))
ptrs' = forall era.
DState era -> Map Ptr (Credential 'Staking (EraCrypto era))
ptrsMap DState era
ds
PState {psStakePoolParams :: forall era.
PState era
-> Map
(KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
psStakePoolParams = Map
(KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
poolParams} = PState era
ps
stakeRelation :: Map (Credential 'Staking (EraCrypto era)) Coin
stakeRelation :: Map (Credential 'Staking (EraCrypto era)) Coin
stakeRelation = forall era.
EraTxOut era =>
Map Ptr (Credential 'Staking (EraCrypto era))
-> UTxO era
-> Map (Credential 'Staking (EraCrypto era)) Coin
-> Map (Credential 'Staking (EraCrypto era)) Coin
aggregateUtxoCoinByCredential Map Ptr (Credential 'Staking (EraCrypto era))
ptrs' UTxO era
u Map (Credential 'Staking (EraCrypto era)) Coin
rewards'
activeDelegs :: Map.Map (Credential 'Staking (EraCrypto era)) (KeyHash 'StakePool (EraCrypto era))
activeDelegs :: Map
(Credential 'Staking (EraCrypto era))
(KeyHash 'StakePool (EraCrypto era))
activeDelegs = forall s t. Embed s t => Exp t -> s
eval ((forall k s (f :: * -> * -> *) v.
(Ord k, HasExp s (f k v)) =>
s -> Exp (Sett k ())
dom Map (Credential 'Staking (EraCrypto era)) Coin
rewards' forall k s1 s2 (f :: * -> * -> *) v.
(Ord k, HasExp s1 (Sett k ()), HasExp s2 (f k v)) =>
s1 -> s2 -> Exp (f k v)
◁ Map
(Credential 'Staking (EraCrypto era))
(KeyHash 'StakePool (EraCrypto era))
delegs) forall k (g :: * -> * -> *) v s1 (f :: * -> * -> *) s2.
(Ord k, Iter g, Ord v, HasExp s1 (f k v), HasExp s2 (g v ())) =>
s1 -> s2 -> Exp (f k v)
▷ forall k s (f :: * -> * -> *) v.
(Ord k, HasExp s (f k v)) =>
s -> Exp (Sett k ())
dom Map
(KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
poolParams)
aggregateUtxoCoinByCredential ::
forall era.
EraTxOut era =>
Map Ptr (Credential 'Staking (EraCrypto era)) ->
UTxO era ->
Map (Credential 'Staking (EraCrypto era)) Coin ->
Map (Credential 'Staking (EraCrypto era)) Coin
aggregateUtxoCoinByCredential :: forall era.
EraTxOut era =>
Map Ptr (Credential 'Staking (EraCrypto era))
-> UTxO era
-> Map (Credential 'Staking (EraCrypto era)) Coin
-> Map (Credential 'Staking (EraCrypto era)) Coin
aggregateUtxoCoinByCredential Map Ptr (StakeCredential (EraCrypto era))
ptrs (UTxO Map (TxIn (EraCrypto era)) (TxOut era)
u) Map (StakeCredential (EraCrypto era)) Coin
initial =
forall a b k. (a -> b -> a) -> a -> Map k b -> a
Map.foldl' Map (StakeCredential (EraCrypto era)) Coin
-> TxOut era -> Map (StakeCredential (EraCrypto era)) Coin
accum Map (StakeCredential (EraCrypto era)) Coin
initial Map (TxIn (EraCrypto era)) (TxOut era)
u
where
accum :: Map (StakeCredential (EraCrypto era)) Coin
-> TxOut era -> Map (StakeCredential (EraCrypto era)) Coin
accum Map (StakeCredential (EraCrypto era)) Coin
ans TxOut era
out =
let c :: Coin
c = TxOut era
out forall s a. s -> Getting a s a -> a
^. forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
coinTxOutL
in case TxOut era
out forall s a. s -> Getting a s a -> a
^. forall era.
EraTxOut era =>
Lens' (TxOut era) (Addr (EraCrypto era))
addrTxOutL of
Addr Network
_ PaymentCredential (EraCrypto era)
_ (StakeRefPtr Ptr
p)
| Just StakeCredential (EraCrypto era)
cred <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Ptr
p Map Ptr (StakeCredential (EraCrypto era))
ptrs -> forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith forall a. Semigroup a => a -> a -> a
(<>) StakeCredential (EraCrypto era)
cred Coin
c Map (StakeCredential (EraCrypto era)) Coin
ans
Addr Network
_ PaymentCredential (EraCrypto era)
_ (StakeRefBase StakeCredential (EraCrypto era)
hk) -> forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith forall a. Semigroup a => a -> a -> a
(<>) StakeCredential (EraCrypto era)
hk Coin
c Map (StakeCredential (EraCrypto era)) Coin
ans
Addr (EraCrypto era)
_other -> Map (StakeCredential (EraCrypto era)) Coin
ans