From 0815a1be345b9ab890e061c5894fe441d3fa1f34 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Matthias=20G=C3=BCdemann?= Date: Tue, 16 Jul 2019 22:12:53 +0200 Subject: [PATCH] Adapt test to new data types --- .../executable-spec/test/Generator.hs | 21 ++++++----- .../executable-spec/test/MockTypes.hs | 9 ++--- .../executable-spec/test/Mutator.hs | 5 ++- .../executable-spec/test/UnitTests.hs | 36 ++++++++++--------- 4 files changed, 37 insertions(+), 34 deletions(-) diff --git a/shelley/chain-and-ledger/executable-spec/test/Generator.hs b/shelley/chain-and-ledger/executable-spec/test/Generator.hs index a7f9294ad27..313fc02886d 100644 --- a/shelley/chain-and-ledger/executable-spec/test/Generator.hs +++ b/shelley/chain-and-ledger/executable-spec/test/Generator.hs @@ -33,7 +33,10 @@ import Hedgehog import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range -import TxData (pattern AddrVKey, StakeObject(..)) +import TxData (pattern AddrVKey, pattern KeyHashStake, pattern Delegation, + pattern PoolParams, RewardAcnt(..), pattern Delegate, + pattern DeRegKey, pattern RegKey, pattern RegPool, + pattern RetirePool, StakeKeys(..)) import BaseTypes import Coin import Keys (pattern KeyPair, hashKey, vKey) @@ -46,11 +49,6 @@ import Updates import Tx(pattern Tx, pattern TxBody, pattern TxOut) import UTxO (pattern UTxO, balance, makeWitnessVKey) import PParams (PParams(..), emptyPParams) -import Delegation.Certificates (pattern Delegate, pattern DeRegKey, - pattern RegKey, pattern RegPool, pattern RetirePool, - StakeKeys(..)) -import Delegation.PoolParams (pattern Delegation, pattern PoolParams, - RewardAcnt(..)) import MockTypes import Mutator @@ -240,9 +238,10 @@ findPayKeyPair (AddrVKey addr _) keyList = findPayKeyPair _ _ = error "currently no such keys should be generated" -- | Find first matching key pair for stake key in 'AddrTxin'. -findStakeKeyPair :: KeyHash -> KeyPairs -> KeyPair -findStakeKeyPair addr keyList = - snd $ head $ filter (\(_, stake) -> addr == (hashKey $ vKey stake)) keyList +findStakeKeyPair :: StakeObject -> KeyPairs -> KeyPair +findStakeKeyPair (KeyHashStake hk) keyList = + snd $ head $ filter (\(_, stake) -> hk == (hashKey $ vKey stake)) keyList +findStakeKeyPair _ _ = undefined -- TODO treat script case -- | Returns the hashed 'addr' part of a 'TxOut'. getTxOutAddr :: TxOut -> Addr @@ -325,13 +324,13 @@ genStakePool keys = do let interval = case mkUnitInterval $ fromIntegral marginPercent % 100 of Just i -> i Nothing -> interval0 - pure $ PoolParams poolKey pledge Map.empty cost interval Nothing (RewardAcnt $ hashKey acntKey) Set.empty + pure $ PoolParams poolKey pledge Map.empty cost interval Nothing (RewardAcnt $ KeyHashStake $ hashKey acntKey) Set.empty genDelegation :: KeyPairs -> DPState -> Gen Delegation genDelegation keys d = do poolKey <- Gen.element $ Map.keys stKeys' delegatorKey <- getAnyStakeKey keys - pure $ Delegation delegatorKey $ (vKey $ findStakeKeyPair poolKey keys) + pure $ Delegation (KeyHashStake $ hashKey delegatorKey) $ (hashKey $ vKey $ findStakeKeyPair poolKey keys) where (StakeKeys stKeys') = d ^. dstate . stKeys genDCertRegPool :: KeyPairs -> Gen DCert diff --git a/shelley/chain-and-ledger/executable-spec/test/MockTypes.hs b/shelley/chain-and-ledger/executable-spec/test/MockTypes.hs index 36179f89389..024197f0af1 100644 --- a/shelley/chain-and-ledger/executable-spec/test/MockTypes.hs +++ b/shelley/chain-and-ledger/executable-spec/test/MockTypes.hs @@ -6,7 +6,6 @@ import Cardano.Crypto.KES (MockKES) import qualified BlockChain import qualified Delegation.Certificates -import qualified Delegation.PoolParams import qualified Keys import qualified LedgerState import qualified OCert @@ -17,11 +16,11 @@ import qualified UTxO type DCert = Delegation.Certificates.DCert ShortHash MockDSIGN -type Delegation = Delegation.PoolParams.Delegation MockDSIGN +type Delegation = TxData.Delegation ShortHash MockDSIGN -type PoolParams = Delegation.PoolParams.PoolParams ShortHash MockDSIGN +type PoolParams = TxData.PoolParams ShortHash MockDSIGN -type RewardAcnt = Delegation.PoolParams.RewardAcnt ShortHash MockDSIGN +type RewardAcnt = TxData.RewardAcnt ShortHash MockDSIGN type KeyHash = Keys.KeyHash ShortHash MockDSIGN @@ -74,3 +73,5 @@ type HashHeader = BlockChain.HashHeader ShortHash MockDSIGN MockKES type NewEpochState = LedgerState.NewEpochState ShortHash MockDSIGN type CHAIN = STS.Chain.CHAIN ShortHash MockDSIGN MockKES + +type StakeObject = TxData.StakeObject ShortHash MockDSIGN diff --git a/shelley/chain-and-ledger/executable-spec/test/Mutator.hs b/shelley/chain-and-ledger/executable-spec/test/Mutator.hs index 32562f58132..2523f3bb942 100644 --- a/shelley/chain-and-ledger/executable-spec/test/Mutator.hs +++ b/shelley/chain-and-ledger/executable-spec/test/Mutator.hs @@ -31,7 +31,6 @@ import Coin import Delegation.Certificates (pattern Delegate, pattern DeRegKey, pattern GenesisDelegate, pattern RegKey, pattern RegPool, pattern RetirePool) -import Delegation.PoolParams import Keys (vKey, hashKey) import Updates @@ -39,7 +38,7 @@ import Slot import Tx (pattern Tx, pattern TxBody, pattern TxIn, pattern TxOut, _body, _certs, _inputs, _outputs, _ttl, _txfee, _wdrls, _witnessVKeySet, _witnessMSigMap) -import TxData (StakeObject(..)) +import TxData (StakeObject(..), PoolParams(..), pattern Delegation) import MockTypes @@ -176,7 +175,7 @@ mutateDCert keys _ (RegPool (PoolParams _ pledge pledges cost margin altacnt rwd mutateDCert keys _ (Delegate (Delegation _ _)) = do delegator' <- getAnyStakeKey keys delegatee' <- getAnyStakeKey keys - pure $ Delegate $ Delegation delegator' delegatee' + pure $ Delegate $ Delegation (KeyHashStake $ hashKey delegator') (hashKey delegatee') mutateDCert keys _ (GenesisDelegate (gk, _)) = do _delegatee <- getAnyStakeKey keys diff --git a/shelley/chain-and-ledger/executable-spec/test/UnitTests.hs b/shelley/chain-and-ledger/executable-spec/test/UnitTests.hs index 555f85a4665..d735e58935e 100644 --- a/shelley/chain-and-ledger/executable-spec/test/UnitTests.hs +++ b/shelley/chain-and-ledger/executable-spec/test/UnitTests.hs @@ -15,16 +15,16 @@ import Test.Tasty import Test.Tasty.HUnit import Address -import TxData (pattern AddrVKey, pattern Ptr, StakeObject(..)) +import TxData (pattern AddrVKey, pattern Ptr, StakeObject(..), + Delegation (..), pattern PoolParams, pattern RewardAcnt, + _poolAltAcnt, _poolCost, _poolMargin, _poolOwners, + _poolPubKey, _poolPledge, _poolPledges, _poolRAcnt) import BaseTypes import Coin import Delegation.Certificates (pattern Delegate, pattern RegKey, pattern RegPool, pattern RetirePool, StakePools(..), StakeKeys(..)) -import Delegation.PoolParams (Delegation (..), pattern PoolParams, - pattern RewardAcnt, _poolAltAcnt, _poolCost, _poolMargin, - _poolOwners, _poolPubKey, _poolPledge, _poolPledges, - _poolRAcnt) + import Keys (pattern Dms, pattern KeyPair, hashKey, vKey) import LedgerState (pattern LedgerState, pattern UTxOState, ValidationError(..), _delegationState, _dms, _dstate, @@ -117,7 +117,8 @@ testValidDelegation txs utxoState' stakeKeyRegistration pool = (LedgerState utxoState' (stakeKeyRegistration - & dstate . delegations .~ Map.fromList [(hashKey $ vKey aliceStake, poolhk)] + & dstate . delegations .~ + Map.fromList [(KeyHashStake $ hashKey $ vKey aliceStake, poolhk)] & pstate . stPools .~ (StakePools $ Map.fromList [(poolhk, Slot 0)]) & pstate . pParams .~ Map.fromList [(poolhk, pool)]) (fromIntegral $ length txs)) @@ -132,7 +133,8 @@ testValidRetirement txs utxoState' stakeKeyRegistration e pool = (LedgerState utxoState' (stakeKeyRegistration - & dstate . delegations .~ Map.fromList [(hashKey $ vKey aliceStake, poolhk)] + & dstate . delegations .~ + Map.fromList [(KeyHashStake $ hashKey $ vKey aliceStake, poolhk)] & pstate . stPools .~ (StakePools $ Map.fromList [(poolhk, Slot 0)]) & pstate . pParams .~ Map.fromList [(poolhk, pool)] & pstate . retiring .~ Map.fromList [(poolhk, e)]) @@ -281,7 +283,9 @@ tx3Body = TxBody (Set.fromList [TxIn (txid $ tx2 ^. body) 0]) [ TxOut aliceAddr (Coin 3950) ] [ RegPool stakePool - , Delegate (Delegation (vKey aliceStake) (vKey stakePoolKey1))] + , Delegate (Delegation + (KeyHashStake $ hashKey $ vKey aliceStake) + (hashKey $ vKey stakePoolKey1))] Map.empty (Coin 1200) (Slot 100) @@ -308,13 +312,13 @@ stakeKeyRegistration1 = LedgerState.emptyDelegation , (mkRwdAcnt bobStake, Coin 0) , (mkRwdAcnt stakePoolKey1, Coin 0)] & dstate . stKeys .~ (StakeKeys $ - Map.fromList [ (hashKey $ vKey aliceStake, Slot 0) - , (hashKey $ vKey bobStake, Slot 0) - , (hashKey $ vKey stakePoolKey1, Slot 0)]) + Map.fromList [ (KeyHashStake $ hashKey $ vKey aliceStake, Slot 0) + , (KeyHashStake $ hashKey $ vKey bobStake, Slot 0) + , (KeyHashStake $ hashKey $ vKey stakePoolKey1, Slot 0)]) & dstate . ptrs .~ - Map.fromList [ (Ptr (Slot 0) 0 0, hashKey $ vKey aliceStake) - , (Ptr (Slot 0) 0 1, hashKey $ vKey bobStake) - , (Ptr (Slot 0) 0 2, hashKey $ vKey stakePoolKey1) + Map.fromList [ (Ptr (Slot 0) 0 0, KeyHashStake $ hashKey $ vKey aliceStake) + , (Ptr (Slot 0) 0 1, KeyHashStake $ hashKey $ vKey bobStake) + , (Ptr (Slot 0) 0 2, KeyHashStake $ hashKey $ vKey stakePoolKey1) ] stakePool :: PoolParams @@ -326,7 +330,7 @@ stakePool = PoolParams , _poolCost = Coin 0 -- TODO: what is a sensible value? , _poolMargin = interval0 -- or here? , _poolAltAcnt = Nothing -- or here? - , _poolRAcnt = RewardAcnt (hashKey . vKey $ stakePoolKey1) + , _poolRAcnt = RewardAcnt (KeyHashStake . hashKey . vKey $ stakePoolKey1) , _poolOwners = Set.empty } @@ -343,7 +347,7 @@ stakePoolUpdate = PoolParams , _poolCost = Coin 100 -- TODO: what is a sensible value? , _poolMargin = halfInterval -- or here? , _poolAltAcnt = Nothing -- or here? - , _poolRAcnt = RewardAcnt (hashKey . vKey $ stakePoolKey1) + , _poolRAcnt = RewardAcnt (KeyHashStake . hashKey . vKey $ stakePoolKey1) , _poolOwners = Set.empty }