From 081578d1424d0c36f95ceab49947c849c86ccd8a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Matthias=20G=C3=BCdemann?= Date: Fri, 12 Jul 2019 16:27:30 +0200 Subject: [PATCH 01/15] Add `MultiSig` module - MultiSignatureScript typeclass - simple native script multi-sig implementation --- .../executable-spec/delegation.cabal | 1 + .../executable-spec/src/MultiSig.hs | 79 +++++++++++++++++++ 2 files changed, 80 insertions(+) create mode 100644 shelley/chain-and-ledger/executable-spec/src/MultiSig.hs diff --git a/shelley/chain-and-ledger/executable-spec/delegation.cabal b/shelley/chain-and-ledger/executable-spec/delegation.cabal index 09d2b2ed34b..28681e5c63e 100644 --- a/shelley/chain-and-ledger/executable-spec/delegation.cabal +++ b/shelley/chain-and-ledger/executable-spec/delegation.cabal @@ -26,6 +26,7 @@ library PParams EpochBoundary LedgerState + MultiSig Delegation.PoolParams Delegation.Certificates OCert diff --git a/shelley/chain-and-ledger/executable-spec/src/MultiSig.hs b/shelley/chain-and-ledger/executable-spec/src/MultiSig.hs new file mode 100644 index 00000000000..ae537576227 --- /dev/null +++ b/shelley/chain-and-ledger/executable-spec/src/MultiSig.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module MultiSig + ( MultiSig(..) + , toCBOR + , fromCBOR + , evalNativeMultiSigScript + , MultiSignatureScript + , validateScript + ) +where + +import UTxO (Tx(..), Wit(..)) + +import qualified Data.Set as Set + +import Keys + +import Cardano.Binary ( ToCBOR(toCBOR) + , FromCBOR(fromCBOR) + , encodeListLen + , encodeWord + , decodeListLen + , decodeWord) + +import Cardano.Crypto.Hash ( HashAlgorithm) +import Cardano.Crypto.DSIGN ( DSIGNAlgorithm) + +data MultiSig hashAlgo dsignAlgo = + SingleSig (KeyHash hashAlgo dsignAlgo) + | MultiSig Int [MultiSig hashAlgo dsignAlgo] + +instance (DSIGNAlgorithm dsignAlgo, HashAlgorithm hashAlgo) => + ToCBOR (MultiSig hashAlgo dsignAlgo) where + toCBOR (SingleSig hk) = encodeListLen 2 <> encodeWord 0 <> toCBOR hk + toCBOR (MultiSig th msigs) = + encodeListLen 3 <> encodeWord 1 <> toCBOR th <> toCBOR msigs + +instance (DSIGNAlgorithm dsignAlgo, HashAlgorithm hashAlgo) => + FromCBOR (MultiSig hashAlgo dsignAlgo) where + fromCBOR = do + _ <- decodeListLen + ctor <- decodeWord + if ctor == 0 + then do + hk <- KeyHash <$> fromCBOR + pure $ SingleSig hk + else do + th <- fromCBOR + msigs <- fromCBOR + pure $ MultiSig th msigs + +evalNativeMultiSigScript + :: MultiSig hashAlgo dsignAlgo + -> Set.Set (KeyHash hashAlgo dsignAlgo) + -> Bool + +evalNativeMultiSigScript (SingleSig hk) vhks = Set.member hk vhks +evalNativeMultiSigScript (MultiSig th msigs) vhks = + th <= sum [if evalNativeMultiSigScript msig vhks then 1 else 0 | msig <- msigs] + +class (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo) => + MultiSignatureScript a hashAlgo dsignAlgo where + validateScript :: a -> Tx hashAlgo dsignAlgo -> Bool + +validateNativeMultiSigScript + :: (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo) + => MultiSig hashAlgo dsignAlgo + -> Tx hashAlgo dsignAlgo + -> Bool +validateNativeMultiSigScript msig tx = + evalNativeMultiSigScript msig vhks + where witsSet = _witnessSet tx + vhks = Set.map (\(Wit vk _) -> hashKey vk) witsSet + +instance (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo) => + MultiSignatureScript (MultiSig hashAlgo dsignAlgo) hashAlgo dsignAlgo where + validateScript = validateNativeMultiSigScript From 0815dbbdc26def379e6293d3f9fad9e5ecee8be4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Matthias=20G=C3=BCdemann?= Date: Fri, 12 Jul 2019 17:16:47 +0200 Subject: [PATCH 02/15] Rename `Wit` to `WitnessVKey` as first step in multi-sig integration --- .../executable-spec/src/LedgerState.hs | 4 +- .../executable-spec/src/MultiSig.hs | 4 +- .../executable-spec/src/STS/Utxow.hs | 2 +- .../executable-spec/src/UTxO.hs | 45 +++++++++++-------- .../executable-spec/test/Generator.hs | 4 +- .../executable-spec/test/PropertyTests.hs | 8 ++-- .../executable-spec/test/UnitTests.hs | 24 +++++----- 7 files changed, 50 insertions(+), 41 deletions(-) diff --git a/shelley/chain-and-ledger/executable-spec/src/LedgerState.hs b/shelley/chain-and-ledger/executable-spec/src/LedgerState.hs index 732ff1c28e3..2c1339898d4 100644 --- a/shelley/chain-and-ledger/executable-spec/src/LedgerState.hs +++ b/shelley/chain-and-ledger/executable-spec/src/LedgerState.hs @@ -583,7 +583,7 @@ verifiedWits => Tx hashAlgo dsignAlgo -> Validity verifiedWits (Tx tx wits) = - if all (verifyWit tx) wits + if all (verifyWitVKey tx) wits then Valid else Invalid [InvalidWitness] @@ -603,7 +603,7 @@ enoughWits tx@(Tx _ wits) d u = then Valid else Invalid [MissingWitnesses] where - signers = Set.map (\(Wit vkey _) -> hashKey vkey) wits + signers = Set.map (\(WitVKey vkey _) -> hashKey vkey) wits validRuleUTXO :: (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo) diff --git a/shelley/chain-and-ledger/executable-spec/src/MultiSig.hs b/shelley/chain-and-ledger/executable-spec/src/MultiSig.hs index ae537576227..a20b9fc7df9 100644 --- a/shelley/chain-and-ledger/executable-spec/src/MultiSig.hs +++ b/shelley/chain-and-ledger/executable-spec/src/MultiSig.hs @@ -11,7 +11,7 @@ module MultiSig ) where -import UTxO (Tx(..), Wit(..)) +import UTxO (Tx(..), WitVKey(..)) import qualified Data.Set as Set @@ -72,7 +72,7 @@ validateNativeMultiSigScript validateNativeMultiSigScript msig tx = evalNativeMultiSigScript msig vhks where witsSet = _witnessSet tx - vhks = Set.map (\(Wit vk _) -> hashKey vk) witsSet + vhks = Set.map (\(WitVKey vk _) -> hashKey vk) witsSet instance (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo) => MultiSignatureScript (MultiSig hashAlgo dsignAlgo) hashAlgo dsignAlgo where diff --git a/shelley/chain-and-ledger/executable-spec/src/STS/Utxow.hs b/shelley/chain-and-ledger/executable-spec/src/STS/Utxow.hs index 0a36692c2ec..1963a36afd7 100644 --- a/shelley/chain-and-ledger/executable-spec/src/STS/Utxow.hs +++ b/shelley/chain-and-ledger/executable-spec/src/STS/Utxow.hs @@ -72,7 +72,7 @@ utxoWitnessed = do TRC ((slot, pp, stakeKeys, stakePools, _dms), u, tx@(Tx _ wits)) <- judgmentContext verifiedWits tx == Valid ?! InvalidWitnessesUTXOW - let witnessKeys = Set.map (\(Wit vk _) -> hashKey vk) wits + let witnessKeys = Set.map (\(WitVKey vk _) -> hashKey vk) wits witsNeeded (_utxo u) tx _dms == witnessKeys ?! MissingWitnessesUTXOW trans @(UTXO hashAlgo dsignAlgo) $ TRC ((slot, pp, stakeKeys, stakePools, _dms), u, tx) diff --git a/shelley/chain-and-ledger/executable-spec/src/UTxO.hs b/shelley/chain-and-ledger/executable-spec/src/UTxO.hs index 2ab6d3e3aff..376aca8656e 100644 --- a/shelley/chain-and-ledger/executable-spec/src/UTxO.hs +++ b/shelley/chain-and-ledger/executable-spec/src/UTxO.hs @@ -38,9 +38,10 @@ module UTxO , ( ToCBOR (Wit hashAlgo dsignAlgo) + => ToCBOR (WitVKey hashAlgo dsignAlgo) where - toCBOR (Wit vk sig) = + toCBOR (WitVKey vk sig) = encodeListLen 2 <> toCBOR vk <> toCBOR sig -- |Verify a transaction body witness -verifyWit +verifyWitVKey :: ( HashAlgorithm hashAlgo , DSIGNAlgorithm dsignAlgo , Signable dsignAlgo (TxBody hashAlgo dsignAlgo) ) => TxBody hashAlgo dsignAlgo - -> Wit hashAlgo dsignAlgo + -> WitVKey hashAlgo dsignAlgo -> Bool -verifyWit tx (Wit vkey sig) = verify vkey tx sig +verifyWitVKey tx (WitVKey vkey sig) = verify vkey tx sig -- |A fully formed transaction. data Tx hashAlgo dsignAlgo = Tx { _body :: !(TxBody hashAlgo dsignAlgo) - , _witnessSet :: !(Set (Wit hashAlgo dsignAlgo)) + , _witnessSet :: !(Set (WitVKey hashAlgo dsignAlgo)) } deriving (Show, Eq, Ord) makeLenses ''Tx @@ -267,26 +268,34 @@ instance <> toCBOR (_witnessSet tx) -- |Create a witness for transaction -makeWitness +makeWitnessVKey :: ( HashAlgorithm hashAlgo , DSIGNAlgorithm dsignAlgo , Signable dsignAlgo (TxBody hashAlgo dsignAlgo) ) => TxBody hashAlgo dsignAlgo -> KeyPair dsignAlgo - -> Wit hashAlgo dsignAlgo -makeWitness tx keys = Wit (vKey keys) (sign (sKey keys) tx) + -> WitVKey hashAlgo dsignAlgo +makeWitnessVKey tx keys = WitVKey (vKey keys) (sign (sKey keys) tx) -- |Create witnesses for transaction -makeWitnesses +makeWitnessesVKey :: ( HashAlgorithm hashAlgo , DSIGNAlgorithm dsignAlgo , Signable dsignAlgo (TxBody hashAlgo dsignAlgo) ) => TxBody hashAlgo dsignAlgo -> [KeyPair dsignAlgo] - -> Set (Wit hashAlgo dsignAlgo) -makeWitnesses tx = Set.fromList . fmap (makeWitness tx) + -> Set (WitVKey hashAlgo dsignAlgo) +makeWitnessesVKey tx = Set.fromList . fmap (makeWitnessVKey tx) + +-- | Witness accessor function for Transactions +txwitsVKey + :: (DSIGNAlgorithm dsignAlgo) + => Tx hashAlgo dsignAlgo + -> Map.Map (VKey dsignAlgo) (Sig dsignAlgo (TxBody hashAlgo dsignAlgo)) +txwitsVKey tx = + Map.fromList $ map (\(WitVKey vk sig) -> (vk, sig)) (Set.toList $ _witnessSet tx) -- |Domain restriction (<|) diff --git a/shelley/chain-and-ledger/executable-spec/test/Generator.hs b/shelley/chain-and-ledger/executable-spec/test/Generator.hs index 72ce97dbe90..f4cd00864cb 100644 --- a/shelley/chain-and-ledger/executable-spec/test/Generator.hs +++ b/shelley/chain-and-ledger/executable-spec/test/Generator.hs @@ -43,7 +43,7 @@ import LedgerState (pattern LedgerValidation, ValidationError (..), import Slot import Updates import UTxO (pattern AddrTxin, pattern Tx, pattern TxBody, - pattern TxOut, pattern UTxO, balance, makeWitness) + pattern TxOut, pattern UTxO, balance, makeWitnessVKey) import PParams (PParams(..), emptyPParams) import Delegation.Certificates (pattern Delegate, pattern DeRegKey, pattern RegKey, pattern RegPool, pattern RetirePool, @@ -154,7 +154,7 @@ genTx keyList (UTxO m) cslot = do txfee' (cslot + (Slot txttl)) emptyUpdate - let !txwit = makeWitness txbody selectedKeyPair + let !txwit = makeWitnessVKey txbody selectedKeyPair pure (txfee', Tx txbody $ Set.fromList [txwit]) where utxoInputs = Map.keys m addr inp = getTxOutAddr $ m Map.! inp diff --git a/shelley/chain-and-ledger/executable-spec/test/PropertyTests.hs b/shelley/chain-and-ledger/executable-spec/test/PropertyTests.hs index 08f6fcaaf89..4c3d0c90a63 100644 --- a/shelley/chain-and-ledger/executable-spec/test/PropertyTests.hs +++ b/shelley/chain-and-ledger/executable-spec/test/PropertyTests.hs @@ -22,8 +22,8 @@ import LedgerState hiding (dms) import Slot import PParams import UTxO (pattern TxIn, pattern TxOut, (<|), _body, _witnessSet, - balance, body, certs, deposits, inputs, makeWitness, - outputs, txid, txins, txouts, verifyWit, witnessSet) + balance, body, certs, deposits, inputs, makeWitnessVKey, + outputs, txid, txins, txouts, verifyWitVKey, witnessSet) import Generator import MockTypes @@ -232,7 +232,7 @@ propCheckRedundantWitnessSet = property $ do (l, steps, _, txwits, _, keyPairs) <- forAll genValidStateTxKeys let keyPair = fst $ head keyPairs let tx = txwits ^. body - let witness = makeWitness tx keyPair + let witness = makeWitnessVKey tx keyPair let txwits' = txwits & witnessSet %~ (Set.insert witness) let dms = _dms $ _dstate $ _delegationState l let l'' = asStateTransition (Slot (steps)) emptyPParams l txwits' dms @@ -241,7 +241,7 @@ propCheckRedundantWitnessSet = property $ do case l'' of Right _ -> True === (Set.null $ - Set.filter (\wit -> not $ verifyWit tx wit) (_witnessSet txwits')) + Set.filter (\wit -> not $ verifyWitVKey tx wit) (_witnessSet txwits')) _ -> failure -- | Check that we correctly report missing witnesses. diff --git a/shelley/chain-and-ledger/executable-spec/test/UnitTests.hs b/shelley/chain-and-ledger/executable-spec/test/UnitTests.hs index 20265f9f7a5..7317b879daf 100644 --- a/shelley/chain-and-ledger/executable-spec/test/UnitTests.hs +++ b/shelley/chain-and-ledger/executable-spec/test/UnitTests.hs @@ -34,7 +34,7 @@ import Slot import Updates import UTxO (pattern AddrTxin, pattern Ptr, pattern Tx, pattern TxBody, pattern TxIn, pattern TxOut, pattern UTxO, - body, makeWitness, makeWitnesses, mkRwdAcnt, ttl, txid) + body, makeWitnessVKey, makeWitnessesVKey, mkRwdAcnt, ttl, txid) import MockTypes @@ -154,7 +154,7 @@ testValidWithdrawal = (Coin 1000) (Slot 0) emptyUpdate - wits = makeWitnesses tx [alicePay, bobStake] + wits = makeWitnessesVKey tx [alicePay, bobStake] utxo' = Map.fromList [ (TxIn genesisId 1, TxOut bobAddr (Coin 1000)) , (TxIn (txid tx) 0, TxOut aliceAddr (Coin 6000)) @@ -180,7 +180,7 @@ testInvalidWintess = (Slot 1) emptyUpdate tx' = tx & ttl .~ Slot 2 - wits = makeWitnesses tx' [alicePay] + wits = makeWitnessesVKey tx' [alicePay] in ledgerState [Tx tx wits] @?= Left [InvalidWitness] testWithdrawalNoWit :: Assertion @@ -195,7 +195,7 @@ testWithdrawalNoWit = (Coin 1000) (Slot 0) emptyUpdate - wits = Set.singleton $ makeWitness tx alicePay + wits = Set.singleton $ makeWitnessVKey tx alicePay ls = asStateTransition (Slot 0) testPCs genesisWithReward (Tx tx wits) (Dms Map.empty) in ls @?= Left [MissingWitnesses] @@ -211,7 +211,7 @@ testWithdrawalWrongAmt = (Coin 1000) (Slot 0) emptyUpdate - wits = makeWitnesses tx [alicePay, bobStake] + wits = makeWitnessesVKey tx [alicePay, bobStake] ls = asStateTransition (Slot 0) testPCs genesisWithReward (Tx tx wits) (Dms Map.empty) in ls @?= Left [IncorrectRewards] @@ -229,7 +229,7 @@ aliceGivesBobLovelace txin coin fee txdeps txrefs cs s signers = Tx txbody wits fee s emptyUpdate - wits = makeWitnesses txbody signers + wits = makeWitnessesVKey txbody signers tx1 :: Tx tx1 = aliceGivesBobLovelace @@ -286,7 +286,7 @@ tx3Body = TxBody emptyUpdate tx3 :: Tx -tx3 = Tx tx3Body (makeWitnesses tx3Body keys) +tx3 = Tx tx3Body (makeWitnessesVKey tx3Body keys) where keys = [alicePay, aliceStake, stakePoolKey1] utxoSt3 :: UTxOState @@ -356,7 +356,7 @@ tx4Body = TxBody emptyUpdate tx4 :: Tx -tx4 = Tx tx4Body (makeWitnesses tx4Body [alicePay, stakePoolKey1]) +tx4 = Tx tx4Body (makeWitnessesVKey tx4Body [alicePay, stakePoolKey1]) utxoSt4 :: UTxOState utxoSt4 = UTxOState @@ -389,7 +389,7 @@ tx5Body e = TxBody emptyUpdate tx5 :: Epoch -> Tx -tx5 e = Tx (tx5Body e) (makeWitnesses (tx5Body e) [alicePay, stakePoolKey1]) +tx5 e = Tx (tx5Body e) (makeWitnessesVKey (tx5Body e) [alicePay, stakePoolKey1]) testsValidLedger :: TestTree @@ -451,7 +451,7 @@ testSpendNotOwnedUTxO = (Coin 768) (Slot 100) emptyUpdate - aliceWit = makeWitness txbody alicePay + aliceWit = makeWitnessVKey txbody alicePay tx = Tx txbody (Set.fromList [aliceWit]) in ledgerState [tx] @?= Left [MissingWitnesses] @@ -474,7 +474,7 @@ testWitnessWrongUTxO = (Coin 770) (Slot 101) emptyUpdate - aliceWit = makeWitness tx2body alicePay + aliceWit = makeWitnessVKey tx2body alicePay tx = Tx txbody (Set.fromList [aliceWit]) in ledgerState [tx] @?= Left [ InvalidWitness , MissingWitnesses] @@ -491,7 +491,7 @@ testEmptyInputSet = (Coin 1000) (Slot 0) emptyUpdate - wits = makeWitnesses tx [aliceStake] + wits = makeWitnessesVKey tx [aliceStake] genesisWithReward' = changeReward genesis (mkRwdAcnt aliceStake) (Coin 2000) ls = asStateTransition (Slot 0) testPCs genesisWithReward' (Tx tx wits) (Dms Map.empty) in ls @?= Left [ InputSetEmpty ] From 081530c5653d4a6aaef9943d61a13e523d930e8d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Matthias=20G=C3=BCdemann?= Date: Fri, 12 Jul 2019 17:29:36 +0200 Subject: [PATCH 03/15] Run stylish --- .../executable-spec/src/MultiSig.hs | 18 +++++++----------- 1 file changed, 7 insertions(+), 11 deletions(-) diff --git a/shelley/chain-and-ledger/executable-spec/src/MultiSig.hs b/shelley/chain-and-ledger/executable-spec/src/MultiSig.hs index a20b9fc7df9..edaf4769f77 100644 --- a/shelley/chain-and-ledger/executable-spec/src/MultiSig.hs +++ b/shelley/chain-and-ledger/executable-spec/src/MultiSig.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} module MultiSig @@ -11,21 +11,17 @@ module MultiSig ) where -import UTxO (Tx(..), WitVKey(..)) +import UTxO (Tx (..), WitVKey (..)) -import qualified Data.Set as Set +import qualified Data.Set as Set import Keys -import Cardano.Binary ( ToCBOR(toCBOR) - , FromCBOR(fromCBOR) - , encodeListLen - , encodeWord - , decodeListLen - , decodeWord) +import Cardano.Binary (FromCBOR (fromCBOR), ToCBOR (toCBOR), decodeListLen, decodeWord, + encodeListLen, encodeWord) -import Cardano.Crypto.Hash ( HashAlgorithm) -import Cardano.Crypto.DSIGN ( DSIGNAlgorithm) +import Cardano.Crypto.DSIGN (DSIGNAlgorithm) +import Cardano.Crypto.Hash (HashAlgorithm) data MultiSig hashAlgo dsignAlgo = SingleSig (KeyHash hashAlgo dsignAlgo) From 08154896385686838b537ca81fd20401d4bf3f3f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Matthias=20G=C3=BCdemann?= Date: Mon, 15 Jul 2019 14:02:47 +0200 Subject: [PATCH 04/15] Refactor `MultiSig` / `Tx` defs to `Tx` module - move transaction definitions from `UTxO` to own module - add hashScript to `MultiSignatureScript` typeclass - define first tag for native multi-signature - move address defintions to `Address module` --- .../executable-spec/delegation.cabal | 5 +- .../executable-spec/src/Address.hs | 68 +++++ .../executable-spec/src/BlockChain.hs | 38 +-- .../executable-spec/src/EpochBoundary.hs | 2 + .../executable-spec/src/LedgerState.hs | 8 +- .../executable-spec/src/MultiSig.hs | 75 ------ .../executable-spec/src/STS/Bbody.hs | 2 +- .../executable-spec/src/STS/Chain.hs | 2 +- .../executable-spec/src/STS/Deleg.hs | 2 +- .../executable-spec/src/STS/Delegs.hs | 5 +- .../executable-spec/src/STS/Delpl.hs | 2 +- .../executable-spec/src/STS/Ledger.hs | 2 +- .../executable-spec/src/STS/Ledgers.hs | 2 +- .../executable-spec/src/STS/Pool.hs | 2 +- .../executable-spec/src/STS/Utxo.hs | 1 + .../executable-spec/src/STS/Utxow.hs | 4 +- .../executable-spec/src/Tx.hs | 250 ++++++++++++++++++ .../executable-spec/src/UTxO.hs | 195 +------------- .../executable-spec/test/Generator.hs | 7 +- .../executable-spec/test/MockTypes.hs | 12 +- .../executable-spec/test/Mutator.hs | 9 +- .../executable-spec/test/PropertyTests.hs | 30 ++- .../executable-spec/test/UnitTests.hs | 31 +-- 23 files changed, 415 insertions(+), 339 deletions(-) create mode 100644 shelley/chain-and-ledger/executable-spec/src/Address.hs delete mode 100644 shelley/chain-and-ledger/executable-spec/src/MultiSig.hs create mode 100644 shelley/chain-and-ledger/executable-spec/src/Tx.hs diff --git a/shelley/chain-and-ledger/executable-spec/delegation.cabal b/shelley/chain-and-ledger/executable-spec/delegation.cabal index 28681e5c63e..69e3b8fec54 100644 --- a/shelley/chain-and-ledger/executable-spec/delegation.cabal +++ b/shelley/chain-and-ledger/executable-spec/delegation.cabal @@ -17,7 +17,8 @@ flag development manual: True library - exposed-modules: BaseTypes + exposed-modules: Address + BaseTypes BlockChain Coin Keys @@ -26,10 +27,10 @@ library PParams EpochBoundary LedgerState - MultiSig Delegation.PoolParams Delegation.Certificates OCert + Tx Updates STS.Avup STS.Bbody diff --git a/shelley/chain-and-ledger/executable-spec/src/Address.hs b/shelley/chain-and-ledger/executable-spec/src/Address.hs new file mode 100644 index 00000000000..7b8a21241b2 --- /dev/null +++ b/shelley/chain-and-ledger/executable-spec/src/Address.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE LambdaCase #-} + +module Address + ( Addr(..) + , Ix + , Ptr(..) + , mkRwdAcnt + ) +where + +import Data.Typeable (Typeable) +import Data.Word (Word8) +import Numeric.Natural (Natural) + +import Cardano.Binary (ToCBOR(toCBOR), encodeListLen) +import Cardano.Crypto.Hash (HashAlgorithm) + +import Delegation.PoolParams (RewardAcnt(..)) +import Keys +import Slot (Slot(..)) + +-- |An address for UTxO. +data Addr hashAlgo dsignAlgo + = AddrTxin + { _payHK :: KeyHash hashAlgo dsignAlgo + , _stakeHK :: KeyHash hashAlgo dsignAlgo + } + | AddrPtr + { _stakePtr :: Ptr + } + deriving (Show, Eq, Ord) + +instance + (Typeable dsignAlgo, HashAlgorithm hashAlgo) + => ToCBOR (Addr hashAlgo dsignAlgo) + where + toCBOR = \case + AddrTxin payHK stakeHK -> + encodeListLen 3 + <> toCBOR (0 :: Word8) + <> toCBOR payHK + <> toCBOR stakeHK + AddrPtr stakePtr -> + encodeListLen 2 + <> toCBOR (1 :: Word8) + <> toCBOR stakePtr + +type Ix = Natural + +-- | Pointer to a slot, transaction index and index in certificate list. +data Ptr + = Ptr Slot Ix Ix + deriving (Show, Eq, Ord) + +instance ToCBOR Ptr where + toCBOR (Ptr slot txIx certIx) = + encodeListLen 3 + <> toCBOR slot + <> toCBOR txIx + <> toCBOR certIx + +mkRwdAcnt + :: ( HashAlgorithm hashAlgo + , DSIGNAlgorithm dsignAlgo + ) + => KeyPair dsignAlgo + -> RewardAcnt hashAlgo dsignAlgo +mkRwdAcnt keys = RewardAcnt $ hashKey $ vKey keys diff --git a/shelley/chain-and-ledger/executable-spec/src/BlockChain.hs b/shelley/chain-and-ledger/executable-spec/src/BlockChain.hs index 33808543f05..071357fb5c7 100644 --- a/shelley/chain-and-ledger/executable-spec/src/BlockChain.hs +++ b/shelley/chain-and-ledger/executable-spec/src/BlockChain.hs @@ -42,7 +42,7 @@ import EpochBoundary import Keys import OCert import qualified Slot -import qualified UTxO as U +import Tx import NonIntegral ( (***) ) @@ -53,7 +53,7 @@ newtype HashHeader hashAlgo dsignAlgo kesAlgo = -- | Hash of block body newtype HashBBody hashAlgo dsignAlgo kesAlgo = - HashBBody (Hash hashAlgo [U.Tx hashAlgo dsignAlgo]) + HashBBody (Hash hashAlgo [Tx hashAlgo dsignAlgo]) deriving (Show, Eq, Ord, ToCBOR) -- |Hash a given block header @@ -66,7 +66,7 @@ bhHash = HashHeader . hash -- |Hash a given block body bhbHash :: (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo) - => [U.Tx hashAlgo dsignAlgo] + => [Tx hashAlgo dsignAlgo] -> HashBBody hashAlgo dsignAlgo kesAlgo bhbHash = HashBBody . hash @@ -120,7 +120,7 @@ data BHBody hashAlgo dsignAlgo kesAlgo = BHBody -- | proof of leader election , bheaderPrfL :: Proof dsignAlgo UnitInterval -- | signature of block body - , bheaderBlockSignature :: Sig dsignAlgo [U.Tx hashAlgo dsignAlgo] + , bheaderBlockSignature :: Sig dsignAlgo [Tx hashAlgo dsignAlgo] -- | Size of the block body , bsize :: Natural -- | Hash of block body @@ -133,24 +133,24 @@ instance (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo, KESAlgorithm kesAlgo) => ToCBOR (BHBody hashAlgo dsignAlgo kesAlgo) where - toCBOR body = + toCBOR bhBody = encodeListLen 11 - <> toCBOR (bheaderPrev body) - <> toCBOR (bheaderVk body) - <> toCBOR (bheaderSlot body) - <> toCBOR (bheaderEta body) - <> toCBOR (bheaderPrfEta body) - <> toCBOR (bheaderL body) - <> toCBOR (bheaderPrfL body) - <> toCBOR (bheaderBlockSignature body) - <> toCBOR (bsize body) - <> toCBOR (bhash body) - <> toCBOR (bheaderOCert body) + <> toCBOR (bheaderPrev bhBody) + <> toCBOR (bheaderVk bhBody) + <> toCBOR (bheaderSlot bhBody) + <> toCBOR (bheaderEta bhBody) + <> toCBOR (bheaderPrfEta bhBody) + <> toCBOR (bheaderL bhBody) + <> toCBOR (bheaderPrfL bhBody) + <> toCBOR (bheaderBlockSignature bhBody) + <> toCBOR (bsize bhBody) + <> toCBOR (bhash bhBody) + <> toCBOR (bheaderOCert bhBody) data Block hashAlgo dsignAlgo kesAlgo = Block (BHeader hashAlgo dsignAlgo kesAlgo) - [U.Tx hashAlgo dsignAlgo] + [Tx hashAlgo dsignAlgo] deriving (Show, Eq) bHeaderSize @@ -159,7 +159,7 @@ bHeaderSize -> Int bHeaderSize = BS.length . BS.pack . show -bBodySize :: DSIGNAlgorithm dsignAlgo => [U.Tx hashAlgo dsignAlgo] -> Int +bBodySize :: DSIGNAlgorithm dsignAlgo => [Tx hashAlgo dsignAlgo] -> Int bBodySize txs = foldl (+) 0 (map (BS.length . BS.pack . show) txs) slotToSeed :: Slot.Slot -> Seed @@ -168,7 +168,7 @@ slotToSeed (Slot.Slot s) = mkNonce (fromIntegral s) bheader :: Block hashAlgo dsignAlgo kesAlgo -> BHeader hashAlgo dsignAlgo kesAlgo bheader (Block bh _) = bh -bbody :: Block hashAlgo dsignAlgo kesAlgo -> [U.Tx hashAlgo dsignAlgo] +bbody :: Block hashAlgo dsignAlgo kesAlgo -> [Tx hashAlgo dsignAlgo] bbody (Block _ txs) = txs bhbody :: BHeader hashAlgo dsignAlgo kesAlgo -> BHBody hashAlgo dsignAlgo kesAlgo diff --git a/shelley/chain-and-ledger/executable-spec/src/EpochBoundary.hs b/shelley/chain-and-ledger/executable-spec/src/EpochBoundary.hs index aac5d3a6a78..2350e8a155e 100644 --- a/shelley/chain-and-ledger/executable-spec/src/EpochBoundary.hs +++ b/shelley/chain-and-ledger/executable-spec/src/EpochBoundary.hs @@ -30,6 +30,7 @@ module EpochBoundary , groupByPool ) where +import Address import Coin import Delegation.Certificates (StakeKeys (..), StakePools (..), decayKey, decayPool, refund) @@ -37,6 +38,7 @@ import Delegation.PoolParams (RewardAcnt (..), PoolParams(..)) import Keys import PParams hiding (a0, nOpt) import Slot +import Tx import UTxO hiding (dom) import qualified Data.Map.Strict as Map diff --git a/shelley/chain-and-ledger/executable-spec/src/LedgerState.hs b/shelley/chain-and-ledger/executable-spec/src/LedgerState.hs index 2c1339898d4..4891b16aabb 100644 --- a/shelley/chain-and-ledger/executable-spec/src/LedgerState.hs +++ b/shelley/chain-and-ledger/executable-spec/src/LedgerState.hs @@ -120,12 +120,14 @@ import Numeric.Natural (Natural) import Lens.Micro ((%~), (&), (.~), (^.)) import Lens.Micro.TH (makeLenses) +import Address import Coin (Coin (..)) import EpochBoundary import Keys import PParams (PParams (..), emptyPParams, keyDecayRate, keyDeposit, keyMinRefund, minfeeA, minfeeB) import Slot (Epoch (..), Slot (..), epochFromSlot, firstSlot, slotsPerEpoch, (-*)) +import Tx import qualified Updates import UTxO @@ -553,7 +555,7 @@ witsNeeded -> Tx hashAlgo dsignAlgo -> Dms dsignAlgo -> Set (KeyHash hashAlgo dsignAlgo) -witsNeeded utxo' tx@(Tx txbody _) _dms = +witsNeeded utxo' tx@(Tx txbody _ _) _dms = inputAuthors `Set.union` wdrlAuthors `Set.union` certAuthors `Set.union` @@ -582,7 +584,7 @@ verifiedWits ) => Tx hashAlgo dsignAlgo -> Validity -verifiedWits (Tx tx wits) = +verifiedWits (Tx tx wits _) = if all (verifyWitVKey tx) wits then Valid else Invalid [InvalidWitness] @@ -598,7 +600,7 @@ enoughWits -> Dms dsignAlgo -> UTxOState hashAlgo dsignAlgo -> Validity -enoughWits tx@(Tx _ wits) d u = +enoughWits tx@(Tx _ wits _) d u = if witsNeeded (u ^. utxo) tx d `Set.isSubsetOf` signers then Valid else Invalid [MissingWitnesses] diff --git a/shelley/chain-and-ledger/executable-spec/src/MultiSig.hs b/shelley/chain-and-ledger/executable-spec/src/MultiSig.hs deleted file mode 100644 index edaf4769f77..00000000000 --- a/shelley/chain-and-ledger/executable-spec/src/MultiSig.hs +++ /dev/null @@ -1,75 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} - -module MultiSig - ( MultiSig(..) - , toCBOR - , fromCBOR - , evalNativeMultiSigScript - , MultiSignatureScript - , validateScript - ) -where - -import UTxO (Tx (..), WitVKey (..)) - -import qualified Data.Set as Set - -import Keys - -import Cardano.Binary (FromCBOR (fromCBOR), ToCBOR (toCBOR), decodeListLen, decodeWord, - encodeListLen, encodeWord) - -import Cardano.Crypto.DSIGN (DSIGNAlgorithm) -import Cardano.Crypto.Hash (HashAlgorithm) - -data MultiSig hashAlgo dsignAlgo = - SingleSig (KeyHash hashAlgo dsignAlgo) - | MultiSig Int [MultiSig hashAlgo dsignAlgo] - -instance (DSIGNAlgorithm dsignAlgo, HashAlgorithm hashAlgo) => - ToCBOR (MultiSig hashAlgo dsignAlgo) where - toCBOR (SingleSig hk) = encodeListLen 2 <> encodeWord 0 <> toCBOR hk - toCBOR (MultiSig th msigs) = - encodeListLen 3 <> encodeWord 1 <> toCBOR th <> toCBOR msigs - -instance (DSIGNAlgorithm dsignAlgo, HashAlgorithm hashAlgo) => - FromCBOR (MultiSig hashAlgo dsignAlgo) where - fromCBOR = do - _ <- decodeListLen - ctor <- decodeWord - if ctor == 0 - then do - hk <- KeyHash <$> fromCBOR - pure $ SingleSig hk - else do - th <- fromCBOR - msigs <- fromCBOR - pure $ MultiSig th msigs - -evalNativeMultiSigScript - :: MultiSig hashAlgo dsignAlgo - -> Set.Set (KeyHash hashAlgo dsignAlgo) - -> Bool - -evalNativeMultiSigScript (SingleSig hk) vhks = Set.member hk vhks -evalNativeMultiSigScript (MultiSig th msigs) vhks = - th <= sum [if evalNativeMultiSigScript msig vhks then 1 else 0 | msig <- msigs] - -class (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo) => - MultiSignatureScript a hashAlgo dsignAlgo where - validateScript :: a -> Tx hashAlgo dsignAlgo -> Bool - -validateNativeMultiSigScript - :: (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo) - => MultiSig hashAlgo dsignAlgo - -> Tx hashAlgo dsignAlgo - -> Bool -validateNativeMultiSigScript msig tx = - evalNativeMultiSigScript msig vhks - where witsSet = _witnessSet tx - vhks = Set.map (\(WitVKey vk _) -> hashKey vk) witsSet - -instance (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo) => - MultiSignatureScript (MultiSig hashAlgo dsignAlgo) hashAlgo dsignAlgo where - validateScript = validateNativeMultiSigScript diff --git a/shelley/chain-and-ledger/executable-spec/src/STS/Bbody.hs b/shelley/chain-and-ledger/executable-spec/src/STS/Bbody.hs index 112e524090d..48fb84c09d5 100644 --- a/shelley/chain-and-ledger/executable-spec/src/STS/Bbody.hs +++ b/shelley/chain-and-ledger/executable-spec/src/STS/Bbody.hs @@ -19,7 +19,7 @@ import Keys import LedgerState import PParams import Slot -import UTxO +import Tx import Control.State.Transition diff --git a/shelley/chain-and-ledger/executable-spec/src/STS/Chain.hs b/shelley/chain-and-ledger/executable-spec/src/STS/Chain.hs index eb91ca6a284..c4fde8e02b4 100644 --- a/shelley/chain-and-ledger/executable-spec/src/STS/Chain.hs +++ b/shelley/chain-and-ledger/executable-spec/src/STS/Chain.hs @@ -19,7 +19,7 @@ import Keys import LedgerState import OCert import Slot -import UTxO +import Tx import Control.State.Transition diff --git a/shelley/chain-and-ledger/executable-spec/src/STS/Deleg.hs b/shelley/chain-and-ledger/executable-spec/src/STS/Deleg.hs index eb34f36d79c..6252c273fc0 100644 --- a/shelley/chain-and-ledger/executable-spec/src/STS/Deleg.hs +++ b/shelley/chain-and-ledger/executable-spec/src/STS/Deleg.hs @@ -8,12 +8,12 @@ where import qualified Data.Map.Strict as Map +import Address import BlockChain (slotsPrior) import Delegation.Certificates import Keys import LedgerState import Slot -import UTxO import Control.State.Transition diff --git a/shelley/chain-and-ledger/executable-spec/src/STS/Delegs.hs b/shelley/chain-and-ledger/executable-spec/src/STS/Delegs.hs index 9d9832a8b87..87bc4e1170d 100644 --- a/shelley/chain-and-ledger/executable-spec/src/STS/Delegs.hs +++ b/shelley/chain-and-ledger/executable-spec/src/STS/Delegs.hs @@ -11,13 +11,14 @@ where import qualified Data.Map.Strict as Map +import Address import Delegation.Certificates import Delegation.PoolParams import Keys import LedgerState import PParams hiding (d) import Slot -import UTxO +import Tx import Control.State.Transition @@ -49,7 +50,7 @@ delegsTransition . (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo) => TransitionRule (DELEGS hashAlgo dsignAlgo) delegsTransition = do - TRC (env@(_slot, txIx, pp, Tx txbody _), dpstate, certificates) <- judgmentContext + TRC (env@(_slot, txIx, pp, Tx txbody _ _), dpstate, certificates) <- judgmentContext case certificates of [] -> do let wdrls' = _wdrls txbody diff --git a/shelley/chain-and-ledger/executable-spec/src/STS/Delpl.hs b/shelley/chain-and-ledger/executable-spec/src/STS/Delpl.hs index 873af920907..b5f023f72ec 100644 --- a/shelley/chain-and-ledger/executable-spec/src/STS/Delpl.hs +++ b/shelley/chain-and-ledger/executable-spec/src/STS/Delpl.hs @@ -9,10 +9,10 @@ module STS.Delpl ) where +import Address import Keys import LedgerState import Delegation.Certificates -import UTxO import PParams hiding (d) import Slot diff --git a/shelley/chain-and-ledger/executable-spec/src/STS/Ledger.hs b/shelley/chain-and-ledger/executable-spec/src/STS/Ledger.hs index 07be5b08d85..fa432b2eb90 100644 --- a/shelley/chain-and-ledger/executable-spec/src/STS/Ledger.hs +++ b/shelley/chain-and-ledger/executable-spec/src/STS/Ledger.hs @@ -16,7 +16,7 @@ import Keys import LedgerState import PParams hiding (d) import Slot -import UTxO +import Tx import Control.State.Transition diff --git a/shelley/chain-and-ledger/executable-spec/src/STS/Ledgers.hs b/shelley/chain-and-ledger/executable-spec/src/STS/Ledgers.hs index b4efce2fb0d..86bfc891e6a 100644 --- a/shelley/chain-and-ledger/executable-spec/src/STS/Ledgers.hs +++ b/shelley/chain-and-ledger/executable-spec/src/STS/Ledgers.hs @@ -16,7 +16,7 @@ import Keys import LedgerState import PParams import Slot -import UTxO +import Tx import Control.State.Transition diff --git a/shelley/chain-and-ledger/executable-spec/src/STS/Pool.hs b/shelley/chain-and-ledger/executable-spec/src/STS/Pool.hs index c6586cf3448..6d8bac94982 100644 --- a/shelley/chain-and-ledger/executable-spec/src/STS/Pool.hs +++ b/shelley/chain-and-ledger/executable-spec/src/STS/Pool.hs @@ -8,12 +8,12 @@ where import Lens.Micro ( (^.) ) +import Address import Delegation.Certificates import Keys import LedgerState import PParams import Slot -import UTxO import Control.State.Transition diff --git a/shelley/chain-and-ledger/executable-spec/src/STS/Utxo.hs b/shelley/chain-and-ledger/executable-spec/src/STS/Utxo.hs index a19bd1e3a75..01647380ef7 100644 --- a/shelley/chain-and-ledger/executable-spec/src/STS/Utxo.hs +++ b/shelley/chain-and-ledger/executable-spec/src/STS/Utxo.hs @@ -23,6 +23,7 @@ import Keys import LedgerState hiding (dms) import PParams import Slot +import Tx import Updates import UTxO diff --git a/shelley/chain-and-ledger/executable-spec/src/STS/Utxow.hs b/shelley/chain-and-ledger/executable-spec/src/STS/Utxow.hs index 1963a36afd7..b110132ba66 100644 --- a/shelley/chain-and-ledger/executable-spec/src/STS/Utxow.hs +++ b/shelley/chain-and-ledger/executable-spec/src/STS/Utxow.hs @@ -17,7 +17,7 @@ import Keys import LedgerState hiding (dms) import PParams import Slot -import UTxO +import Tx import Control.State.Transition @@ -69,7 +69,7 @@ utxoWitnessed ) => TransitionRule (UTXOW hashAlgo dsignAlgo) utxoWitnessed = do - TRC ((slot, pp, stakeKeys, stakePools, _dms), u, tx@(Tx _ wits)) + TRC ((slot, pp, stakeKeys, stakePools, _dms), u, tx@(Tx _ wits _)) <- judgmentContext verifiedWits tx == Valid ?! InvalidWitnessesUTXOW let witnessKeys = Set.map (\(WitVKey vk _) -> hashKey vk) wits diff --git a/shelley/chain-and-ledger/executable-spec/src/Tx.hs b/shelley/chain-and-ledger/executable-spec/src/Tx.hs new file mode 100644 index 00000000000..c5ff243f925 --- /dev/null +++ b/shelley/chain-and-ledger/executable-spec/src/Tx.hs @@ -0,0 +1,250 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} + +module Tx + ( -- transaction + Tx(..) + , TxBody(..) + , TxOut(..) + , TxIn(..) + , TxId(..) + , txUpdate + , inputs + , outputs + , certs + , wdrls + , txfee + , ttl + , body + , witnessVKeySet + , witnessMSigMap + -- witness data + , WitVKey(..) + , MultiSignatureScript + , validateScript + , hashScript + , txwitsVKey + , txwitsScripts + ) +where + + +import Keys + +import Cardano.Binary (FromCBOR (fromCBOR), ToCBOR (toCBOR), decodeListLen, decodeWord, + encodeListLen, encodeWord, encodeWord8) + +import Cardano.Crypto.Hash (Hash, HashAlgorithm, hashWithSerialiser) + +import Cardano.Crypto.DSIGN (DSIGNAlgorithm) + +import Data.Word (Word8) + +import Lens.Micro.TH (makeLenses) + +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Typeable (Typeable) +import Numeric.Natural (Natural) + +import Address +import Coin (Coin (..)) +import Delegation.Certificates (DCert (..)) +import Delegation.PoolParams (RewardAcnt (..)) +import Slot (Slot (..)) +import Updates (Update) + + +data MultiSig hashAlgo dsignAlgo = + SingleSig (KeyHash hashAlgo dsignAlgo) + | MultiSig Int [MultiSig hashAlgo dsignAlgo] + deriving (Show, Eq, Ord) + +newtype ScriptHash hashAlgo dsignAlgo = + ScriptHash (Hash hashAlgo (MultiSig hashAlgo dsignAlgo)) + deriving (Show, Eq, Ord, ToCBOR) + +type Wdrl hashAlgo dsignAlgo = Map (RewardAcnt hashAlgo dsignAlgo) Coin + +-- |A unique ID of a transaction, which is computable from the transaction. +newtype TxId hashAlgo dsignAlgo + = TxId { _TxId :: Hash hashAlgo (TxBody hashAlgo dsignAlgo) } + deriving (Show, Eq, Ord, ToCBOR) + +-- |The input of a UTxO. +data TxIn hashAlgo dsignAlgo + = TxIn (TxId hashAlgo dsignAlgo) Natural + deriving (Show, Eq, Ord) + +instance + (Typeable dsignAlgo, HashAlgorithm hashAlgo) + => ToCBOR (TxIn hashAlgo dsignAlgo) + where + toCBOR (TxIn txId index) = + encodeListLen 2 + <> toCBOR txId + <> toCBOR index + +-- |The output of a UTxO. +data TxOut hashAlgo dsignAlgo + = TxOut (Addr hashAlgo dsignAlgo) Coin + deriving (Show, Eq, Ord) + +instance + (Typeable dsignAlgo, HashAlgorithm hashAlgo) + => ToCBOR (TxOut hashAlgo dsignAlgo) + where + toCBOR (TxOut addr coin) = + encodeListLen 2 + <> toCBOR addr + <> toCBOR coin + +-- |A raw transaction +data TxBody hashAlgo dsignAlgo + = TxBody + { _inputs :: !(Set (TxIn hashAlgo dsignAlgo)) + , _outputs :: [TxOut hashAlgo dsignAlgo] + , _certs :: ![DCert hashAlgo dsignAlgo] + , _wdrls :: Wdrl hashAlgo dsignAlgo + , _txfee :: Coin + , _ttl :: Slot + , _txUpdate :: Update dsignAlgo + } deriving (Show, Eq, Ord) + +makeLenses ''TxBody + +-- |Proof/Witness that a transaction is authorized by the given key holder. +data WitVKey hashAlgo dsignAlgo + = WitVKey (VKey dsignAlgo) !(Sig dsignAlgo (TxBody hashAlgo dsignAlgo)) + deriving (Show, Eq, Ord) + +instance + (Typeable hashAlgo, DSIGNAlgorithm dsignAlgo) + => ToCBOR (WitVKey hashAlgo dsignAlgo) + where + toCBOR (WitVKey vk sig) = + encodeListLen 2 + <> toCBOR vk + <> toCBOR sig + +-- |A fully formed transaction. +data Tx hashAlgo dsignAlgo + = Tx + { _body :: !(TxBody hashAlgo dsignAlgo) + , _witnessVKeySet :: !(Set (WitVKey hashAlgo dsignAlgo)) + , _witnessMSigMap :: + Map (ScriptHash hashAlgo dsignAlgo) (MultiSig hashAlgo dsignAlgo) + } deriving (Show, Eq, Ord) + +makeLenses ''Tx + +-- | Typeclass for multis-signature script data types. Allows for script +-- validation and hashing. +class (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo, ToCBOR a) => + MultiSignatureScript a hashAlgo dsignAlgo where + validateScript :: a -> Tx hashAlgo dsignAlgo -> Bool + hashScript :: a -> ScriptHash hashAlgo dsignAlgo + +instance + (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo) + => ToCBOR (Tx hashAlgo dsignAlgo) + where + toCBOR tx = + encodeListLen 2 + <> toCBOR (_body tx) + <> toCBOR (_witnessVKeySet tx) + <> toCBOR (_witnessMSigMap tx) + +instance + (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo) + => ToCBOR (TxBody hashAlgo dsignAlgo) + where + toCBOR txbody = + encodeListLen 6 + <> toCBOR (_inputs txbody) + <> toCBOR (_outputs txbody) + <> toCBOR (_certs txbody) + <> toCBOR (_wdrls txbody) + <> toCBOR (_txfee txbody) + <> toCBOR (_ttl txbody) + <> toCBOR (_txUpdate txbody) + +instance (DSIGNAlgorithm dsignAlgo, HashAlgorithm hashAlgo) => + ToCBOR (MultiSig hashAlgo dsignAlgo) where + toCBOR (SingleSig hk) = encodeListLen 2 <> encodeWord 0 <> toCBOR hk + toCBOR (MultiSig th msigs) = + encodeListLen 3 <> encodeWord 1 <> toCBOR th <> toCBOR msigs + +instance (DSIGNAlgorithm dsignAlgo, HashAlgorithm hashAlgo) => + FromCBOR (MultiSig hashAlgo dsignAlgo) where + fromCBOR = do + _ <- decodeListLen + ctor <- decodeWord + if ctor == 0 + then do + hk <- KeyHash <$> fromCBOR + pure $ SingleSig hk + else do + th <- fromCBOR + msigs <- fromCBOR + pure $ MultiSig th msigs + +-- | Script evaluator for native multi-signature scheme. 'vhks' is the set of +-- key hashes that signed the transaction to be validated. +evalNativeMultiSigScript + :: MultiSig hashAlgo dsignAlgo + -> Set (KeyHash hashAlgo dsignAlgo) + -> Bool +evalNativeMultiSigScript (SingleSig hk) vhks = Set.member hk vhks +evalNativeMultiSigScript (MultiSig th msigs) vhks = + th <= sum [if evalNativeMultiSigScript msig vhks then 1 else 0 | msig <- msigs] + +-- | Script validator for native multi-signature scheme. +validateNativeMultiSigScript + :: (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo) + => MultiSig hashAlgo dsignAlgo + -> Tx hashAlgo dsignAlgo + -> Bool +validateNativeMultiSigScript msig tx = + evalNativeMultiSigScript msig vhks + where witsSet = _witnessVKeySet tx + vhks = Set.map (\(WitVKey vk _) -> hashKey vk) witsSet + +-- | Hashes native multi-signature script, appending the 'nativeMultiSigTag' in +-- front and then calling the script CBOR function. +hashNativeMultiSigScript + :: (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo) + => MultiSig hashAlgo dsignAlgo + -> ScriptHash hashAlgo dsignAlgo +hashNativeMultiSigScript msig = + ScriptHash $ hashWithSerialiser (\x -> encodeWord8 nativeMultiSigTag + <> toCBOR x) msig + +-- | Magic number representing the tag of the native multi-signature script +-- language. For each script language included, a new tag is chosen and the tag +-- is included in the script hash for a script. +nativeMultiSigTag :: Word8 +nativeMultiSigTag = 0 + +instance (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo) => + MultiSignatureScript (MultiSig hashAlgo dsignAlgo) hashAlgo dsignAlgo where + validateScript = validateNativeMultiSigScript + hashScript = hashNativeMultiSigScript + +-- | Witness accessor function for Transactions +txwitsVKey + :: (DSIGNAlgorithm dsignAlgo) + => Tx hashAlgo dsignAlgo + -> Map.Map (VKey dsignAlgo) (Sig dsignAlgo (TxBody hashAlgo dsignAlgo)) +txwitsVKey tx = + Map.fromList $ map (\(WitVKey vk sig) -> (vk, sig)) (Set.toList $ _witnessVKeySet tx) + +-- | Multi-signature script witness accessor function for Transactions +txwitsScripts + :: Tx hashAlgo dsignAlgo + -> Map.Map (ScriptHash hashAlgo dsignAlgo) (MultiSig hashAlgo dsignAlgo) +txwitsScripts tx = _witnessMSigMap tx diff --git a/shelley/chain-and-ledger/executable-spec/src/UTxO.hs b/shelley/chain-and-ledger/executable-spec/src/UTxO.hs index 376aca8656e..43d17604a72 100644 --- a/shelley/chain-and-ledger/executable-spec/src/UTxO.hs +++ b/shelley/chain-and-ledger/executable-spec/src/UTxO.hs @@ -15,23 +15,14 @@ as specified in /A Simplified Formal Specification of a UTxO Ledger/. module UTxO ( -- * Primitives - TxId(..) - , Addr(..) - , Ptr(..) - , Wdrl - , Ix - , mkRwdAcnt - -- * Derived Types - , TxIn(..) - , TxOut(..) - , UTxO(..) - , TxBody(..) + UTxO(..) -- * Functions , txid , txins , txinLookup , txouts , txUpdate + , txup , balance , deposits , (<|) @@ -40,162 +31,30 @@ module UTxO , union , makeWitnessVKey , makeWitnessesVKey - , WitVKey(..) - , txwitsVKey - , Tx(..) - -- lenses - -- TxBody - , inputs - , outputs - , certs - , wdrls - , txfee - , ttl - -- Tx - , body - , witnessSet , verifyWitVKey - , txup ) where +import Lens.Micro ((^.)) + import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Set (Set) import qualified Data.Set as Set -import Data.Typeable (Typeable) -import Data.Word (Word8) -import Numeric.Natural (Natural) - -import Lens.Micro ((^.)) -import Lens.Micro.TH (makeLenses) - -import Cardano.Binary (ToCBOR(toCBOR), encodeListLen) import Coin (Coin (..)) import Keys import PParams (PParams(..)) -import Slot (Slot(..)) import Updates (Update) +import Tx import Delegation.Certificates (StakePools(..), DCert (..), dvalue) -import Delegation.PoolParams (poolPubKey, RewardAcnt(..)) - --- |A unique ID of a transaction, which is computable from the transaction. -newtype TxId hashAlgo dsignAlgo - = TxId { _TxId :: Hash hashAlgo (TxBody hashAlgo dsignAlgo) } - deriving (Show, Eq, Ord, ToCBOR) - -type Ix = Natural - --- | Pointer to a slot, transaction index and index in certificate list. -data Ptr - = Ptr Slot Ix Ix - deriving (Show, Eq, Ord) - -instance ToCBOR Ptr where - toCBOR (Ptr slot txIx certIx) = - encodeListLen 3 - <> toCBOR slot - <> toCBOR txIx - <> toCBOR certIx - --- |An address for UTxO. -data Addr hashAlgo dsignAlgo - = AddrTxin - { _payHK :: KeyHash hashAlgo dsignAlgo - , _stakeHK :: KeyHash hashAlgo dsignAlgo - } - | AddrPtr - { _stakePtr :: Ptr - } - deriving (Show, Eq, Ord) - -instance - (Typeable dsignAlgo, HashAlgorithm hashAlgo) - => ToCBOR (Addr hashAlgo dsignAlgo) - where - toCBOR = \case - AddrTxin payHK stakeHK -> - encodeListLen 3 - <> toCBOR (0 :: Word8) - <> toCBOR payHK - <> toCBOR stakeHK - AddrPtr stakePtr -> - encodeListLen 2 - <> toCBOR (1 :: Word8) - <> toCBOR stakePtr - -mkRwdAcnt - :: ( HashAlgorithm hashAlgo - , DSIGNAlgorithm dsignAlgo - ) - => KeyPair dsignAlgo - -> RewardAcnt hashAlgo dsignAlgo -mkRwdAcnt keys = RewardAcnt $ hashKey $ vKey keys - --- |The input of a UTxO. -data TxIn hashAlgo dsignAlgo - = TxIn (TxId hashAlgo dsignAlgo) Natural - deriving (Show, Eq, Ord) - -instance - (Typeable dsignAlgo, HashAlgorithm hashAlgo) - => ToCBOR (TxIn hashAlgo dsignAlgo) - where - toCBOR (TxIn txId index) = - encodeListLen 2 - <> toCBOR txId - <> toCBOR index - --- |The output of a UTxO. -data TxOut hashAlgo dsignAlgo - = TxOut (Addr hashAlgo dsignAlgo) Coin - deriving (Show, Eq, Ord) - -instance - (Typeable dsignAlgo, HashAlgorithm hashAlgo) - => ToCBOR (TxOut hashAlgo dsignAlgo) - where - toCBOR (TxOut addr coin) = - encodeListLen 2 - <> toCBOR addr - <> toCBOR coin +import Delegation.PoolParams (poolPubKey) -- |The unspent transaction outputs. newtype UTxO hashAlgo dsignAlgo = UTxO (Map (TxIn hashAlgo dsignAlgo) (TxOut hashAlgo dsignAlgo)) deriving (Show, Eq, Ord) -type Wdrl hashAlgo dsignAlgo = Map (RewardAcnt hashAlgo dsignAlgo) Coin - --- |A raw transaction -data TxBody hashAlgo dsignAlgo - = TxBody - { _inputs :: !(Set (TxIn hashAlgo dsignAlgo)) - , _outputs :: [TxOut hashAlgo dsignAlgo] - , _certs :: ![DCert hashAlgo dsignAlgo] - , _wdrls :: Wdrl hashAlgo dsignAlgo - , _txfee :: Coin - , _ttl :: Slot - , _txUpdate :: Update dsignAlgo - } deriving (Show, Eq, Ord) - -makeLenses ''TxBody - -instance - (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo) - => ToCBOR (TxBody hashAlgo dsignAlgo) - where - toCBOR txbody = - encodeListLen 6 - <> toCBOR (_inputs txbody) - <> toCBOR (_outputs txbody) - <> toCBOR (_certs txbody) - <> toCBOR (_wdrls txbody) - <> toCBOR (_txfee txbody) - <> toCBOR (_ttl txbody) - <> toCBOR (_txUpdate txbody) - -- |Compute the id of a transaction. txid :: (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo) @@ -224,20 +83,6 @@ txinLookup -> Maybe (TxOut hashAlgo dsignAlgo) txinLookup txin (UTxO utxo') = Map.lookup txin utxo' --- |Proof/Witness that a transaction is authorized by the given key holder. -data WitVKey hashAlgo dsignAlgo - = WitVKey (VKey dsignAlgo) !(Sig dsignAlgo (TxBody hashAlgo dsignAlgo)) - deriving (Show, Eq, Ord) - -instance - (Typeable hashAlgo, DSIGNAlgorithm dsignAlgo) - => ToCBOR (WitVKey hashAlgo dsignAlgo) - where - toCBOR (WitVKey vk sig) = - encodeListLen 2 - <> toCBOR vk - <> toCBOR sig - -- |Verify a transaction body witness verifyWitVKey :: ( HashAlgorithm hashAlgo @@ -249,24 +94,6 @@ verifyWitVKey -> Bool verifyWitVKey tx (WitVKey vkey sig) = verify vkey tx sig --- |A fully formed transaction. -data Tx hashAlgo dsignAlgo - = Tx - { _body :: !(TxBody hashAlgo dsignAlgo) - , _witnessSet :: !(Set (WitVKey hashAlgo dsignAlgo)) - } deriving (Show, Eq, Ord) - -makeLenses ''Tx - -instance - (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo) - => ToCBOR (Tx hashAlgo dsignAlgo) - where - toCBOR tx = - encodeListLen 2 - <> toCBOR (_body tx) - <> toCBOR (_witnessSet tx) - -- |Create a witness for transaction makeWitnessVKey :: ( HashAlgorithm hashAlgo @@ -289,14 +116,6 @@ makeWitnessesVKey -> Set (WitVKey hashAlgo dsignAlgo) makeWitnessesVKey tx = Set.fromList . fmap (makeWitnessVKey tx) --- | Witness accessor function for Transactions -txwitsVKey - :: (DSIGNAlgorithm dsignAlgo) - => Tx hashAlgo dsignAlgo - -> Map.Map (VKey dsignAlgo) (Sig dsignAlgo (TxBody hashAlgo dsignAlgo)) -txwitsVKey tx = - Map.fromList $ map (\(WitVKey vk sig) -> (vk, sig)) (Set.toList $ _witnessSet tx) - -- |Domain restriction (<|) :: Set (TxIn hashAlgo dsignAlgo) @@ -347,4 +166,4 @@ deposits pc (StakePools stpools) cs = foldl f (Coin 0) cs' cs' = filter notRegisteredPool cs txup :: Tx hashAlgo dsignAlgo -> Update dsignAlgo -txup (Tx txbody _ ) = _txUpdate txbody +txup (Tx txbody _ _) = _txUpdate txbody diff --git a/shelley/chain-and-ledger/executable-spec/test/Generator.hs b/shelley/chain-and-ledger/executable-spec/test/Generator.hs index f4cd00864cb..597b72dc0d9 100644 --- a/shelley/chain-and-ledger/executable-spec/test/Generator.hs +++ b/shelley/chain-and-ledger/executable-spec/test/Generator.hs @@ -33,6 +33,7 @@ import Hedgehog import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range +import Address (pattern AddrTxin) import BaseTypes import Coin import Keys (pattern KeyPair, hashKey, vKey) @@ -42,8 +43,8 @@ import LedgerState (pattern LedgerValidation, ValidationError (..), utxo, dstate, stKeys) import Slot import Updates -import UTxO (pattern AddrTxin, pattern Tx, pattern TxBody, - pattern TxOut, pattern UTxO, balance, makeWitnessVKey) +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, @@ -155,7 +156,7 @@ genTx keyList (UTxO m) cslot = do (cslot + (Slot txttl)) emptyUpdate let !txwit = makeWitnessVKey txbody selectedKeyPair - pure (txfee', Tx txbody $ Set.fromList [txwit]) + pure (txfee', Tx txbody (Set.fromList [txwit]) Map.empty) where utxoInputs = Map.keys m addr inp = getTxOutAddr $ m Map.! inp diff --git a/shelley/chain-and-ledger/executable-spec/test/MockTypes.hs b/shelley/chain-and-ledger/executable-spec/test/MockTypes.hs index af75d8b2742..7c090470cea 100644 --- a/shelley/chain-and-ledger/executable-spec/test/MockTypes.hs +++ b/shelley/chain-and-ledger/executable-spec/test/MockTypes.hs @@ -4,6 +4,7 @@ import Cardano.Crypto.DSIGN (MockDSIGN) import Cardano.Crypto.Hash (ShortHash) import Cardano.Crypto.KES (MockKES) +import qualified Address import qualified BlockChain import qualified Delegation.Certificates import qualified Delegation.PoolParams @@ -11,6 +12,7 @@ import qualified Keys import qualified LedgerState import qualified OCert import qualified STS.Chain +import qualified Tx import qualified UTxO type DCert = Delegation.Certificates.DCert ShortHash MockDSIGN @@ -37,15 +39,15 @@ type UTxOState = LedgerState.UTxOState ShortHash MockDSIGN type DPState = LedgerState.DPState ShortHash MockDSIGN -type Addr = UTxO.Addr ShortHash MockDSIGN +type Addr = Address.Addr ShortHash MockDSIGN -type Tx = UTxO.Tx ShortHash MockDSIGN +type Tx = Tx.Tx ShortHash MockDSIGN -type TxBody = UTxO.TxBody ShortHash MockDSIGN +type TxBody = Tx.TxBody ShortHash MockDSIGN -type TxIn = UTxO.TxIn ShortHash MockDSIGN +type TxIn = Tx.TxIn ShortHash MockDSIGN -type TxOut = UTxO.TxOut ShortHash MockDSIGN +type TxOut = Tx.TxOut ShortHash MockDSIGN type UTxO = UTxO.UTxO 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 5d821270454..22b9ec79194 100644 --- a/shelley/chain-and-ledger/executable-spec/test/Mutator.hs +++ b/shelley/chain-and-ledger/executable-spec/test/Mutator.hs @@ -34,10 +34,11 @@ import Delegation.Certificates (pattern Delegate, pattern DeRegKey, import Delegation.PoolParams import Keys (vKey) import Updates -import UTxO (pattern Tx, pattern TxBody, pattern TxIn, pattern TxOut, - _body, _certs, _inputs, _outputs, _ttl, _txfee, _wdrls, - _witnessSet) + import Slot +import Tx (pattern Tx, pattern TxBody, pattern TxIn, pattern TxOut, + _body, _certs, _inputs, _outputs, _ttl, _txfee, _wdrls, + _witnessVKeySet, _witnessMSigMap) import MockTypes @@ -83,7 +84,7 @@ mutateCoin lower upper (Coin val) = Coin <$> mutateInteger lower upper val mutateTx :: Tx -> Gen Tx mutateTx txwits = do body' <- mutateTxBody $ _body txwits - pure $ Tx body' (_witnessSet txwits) + pure $ Tx body' (_witnessVKeySet txwits) (_witnessMSigMap txwits) -- | Mutator for Transaction which mutates the set of inputs and the set of -- unspent outputs. diff --git a/shelley/chain-and-ledger/executable-spec/test/PropertyTests.hs b/shelley/chain-and-ledger/executable-spec/test/PropertyTests.hs index 4c3d0c90a63..2888fb99849 100644 --- a/shelley/chain-and-ledger/executable-spec/test/PropertyTests.hs +++ b/shelley/chain-and-ledger/executable-spec/test/PropertyTests.hs @@ -21,9 +21,11 @@ import Coin import LedgerState hiding (dms) import Slot import PParams -import UTxO (pattern TxIn, pattern TxOut, (<|), _body, _witnessSet, - balance, body, certs, deposits, inputs, makeWitnessVKey, - outputs, txid, txins, txouts, verifyWitVKey, witnessSet) +import Tx (pattern TxIn, pattern TxOut, _body, _witnessVKeySet, body + , certs, inputs, outputs, witnessVKeySet) +import UTxO ( (<|), + balance, deposits, makeWitnessVKey, + txid, txins, txouts, verifyWitVKey) import Generator import MockTypes @@ -233,15 +235,15 @@ propCheckRedundantWitnessSet = property $ do let keyPair = fst $ head keyPairs let tx = txwits ^. body let witness = makeWitnessVKey tx keyPair - let txwits' = txwits & witnessSet %~ (Set.insert witness) + let txwits' = txwits & witnessVKeySet %~ (Set.insert witness) let dms = _dms $ _dstate $ _delegationState l let l'' = asStateTransition (Slot (steps)) emptyPParams l txwits' dms classify "unneeded signature added" - (not $ witness `Set.member` (txwits ^. witnessSet)) + (not $ witness `Set.member` (txwits ^. witnessVKeySet)) case l'' of Right _ -> True === (Set.null $ - Set.filter (\wit -> not $ verifyWitVKey tx wit) (_witnessSet txwits')) + Set.filter (\wit -> not $ verifyWitVKey tx wit) (_witnessVKeySet txwits')) _ -> failure -- | Check that we correctly report missing witnesses. @@ -249,18 +251,18 @@ propCheckMissingWitness :: Property propCheckMissingWitness = property $ do (l, steps, _, txwits, _) <- forAll genValidStateTx witnessList <- forAll (Gen.subsequence $ - Set.toList (txwits ^. witnessSet)) - let witnessSet'' = txwits ^. witnessSet - let witnessSet' = Set.fromList witnessList + Set.toList (txwits ^. witnessVKeySet)) + let witnessVKeySet'' = txwits ^. witnessVKeySet + let witnessVKeySet' = Set.fromList witnessList let dms = _dms $ _dstate $ _delegationState l - let l' = asStateTransition (Slot steps) emptyPParams l (txwits & witnessSet .~ witnessSet') dms - let isRealSubset = witnessSet' `Set.isSubsetOf` witnessSet'' && - witnessSet' /= witnessSet'' + let l' = asStateTransition (Slot steps) emptyPParams l (txwits & witnessVKeySet .~ witnessVKeySet') dms + let isRealSubset = witnessVKeySet' `Set.isSubsetOf` witnessVKeySet'' && + witnessVKeySet' /= witnessVKeySet'' classify "real subset" (isRealSubset) - label $ LabelName ("witnesses:" ++ show (Set.size witnessSet'')) + label $ LabelName ("witnesses:" ++ show (Set.size witnessVKeySet'')) case l' of Left [MissingWitnesses] -> isRealSubset === True - Right _ -> (witnessSet' == witnessSet'') === True + Right _ -> (witnessVKeySet' == witnessVKeySet'') === True _ -> failure -- | Property (Preserve Balance) diff --git a/shelley/chain-and-ledger/executable-spec/test/UnitTests.hs b/shelley/chain-and-ledger/executable-spec/test/UnitTests.hs index 7317b879daf..eebb6a67910 100644 --- a/shelley/chain-and-ledger/executable-spec/test/UnitTests.hs +++ b/shelley/chain-and-ledger/executable-spec/test/UnitTests.hs @@ -14,6 +14,7 @@ import Lens.Micro ((^.), (&), (.~)) import Test.Tasty import Test.Tasty.HUnit +import Address (pattern AddrTxin, pattern Ptr, mkRwdAcnt) import BaseTypes import Coin import Delegation.Certificates (pattern Delegate, pattern RegKey, @@ -32,9 +33,9 @@ import LedgerState (pattern LedgerState, pattern UTxOState, import PParams import Slot import Updates -import UTxO (pattern AddrTxin, pattern Ptr, pattern Tx, - pattern TxBody, pattern TxIn, pattern TxOut, pattern UTxO, - body, makeWitnessVKey, makeWitnessesVKey, mkRwdAcnt, ttl, txid) +import UTxO + (pattern UTxO, makeWitnessVKey, makeWitnessesVKey, txid) +import Tx (pattern TxBody, pattern TxIn, pattern TxOut, pattern Tx, body, ttl) import MockTypes @@ -159,7 +160,7 @@ testValidWithdrawal = [ (TxIn genesisId 1, TxOut bobAddr (Coin 1000)) , (TxIn (txid tx) 0, TxOut aliceAddr (Coin 6000)) , (TxIn (txid tx) 1, TxOut bobAddr (Coin 3010)) ] - ls = asStateTransition (Slot 0) testPCs genesisWithReward (Tx tx wits) (Dms Map.empty) + ls = asStateTransition (Slot 0) testPCs genesisWithReward (Tx tx wits Map.empty) (Dms Map.empty) expectedDS = LedgerState.emptyDelegation & dstate . rewards .~ Map.singleton (mkRwdAcnt bobStake) (Coin 0) in ls @?= Right (LedgerState @@ -181,7 +182,7 @@ testInvalidWintess = emptyUpdate tx' = tx & ttl .~ Slot 2 wits = makeWitnessesVKey tx' [alicePay] - in ledgerState [Tx tx wits] @?= Left [InvalidWitness] + in ledgerState [Tx tx wits Map.empty] @?= Left [InvalidWitness] testWithdrawalNoWit :: Assertion testWithdrawalNoWit = @@ -196,7 +197,7 @@ testWithdrawalNoWit = (Slot 0) emptyUpdate wits = Set.singleton $ makeWitnessVKey tx alicePay - ls = asStateTransition (Slot 0) testPCs genesisWithReward (Tx tx wits) (Dms Map.empty) + ls = asStateTransition (Slot 0) testPCs genesisWithReward (Tx tx wits Map.empty) (Dms Map.empty) in ls @?= Left [MissingWitnesses] testWithdrawalWrongAmt :: Assertion @@ -212,12 +213,12 @@ testWithdrawalWrongAmt = (Slot 0) emptyUpdate wits = makeWitnessesVKey tx [alicePay, bobStake] - ls = asStateTransition (Slot 0) testPCs genesisWithReward (Tx tx wits) (Dms Map.empty) + ls = asStateTransition (Slot 0) testPCs genesisWithReward (Tx tx wits Map.empty) (Dms Map.empty) in ls @?= Left [IncorrectRewards] aliceGivesBobLovelace :: TxIn -> Coin -> Coin -> Coin -> Coin -> [DCert] -> Slot -> [KeyPair] -> Tx -aliceGivesBobLovelace txin coin fee txdeps txrefs cs s signers = Tx txbody wits +aliceGivesBobLovelace txin coin fee txdeps txrefs cs s signers = Tx txbody wits Map.empty where aliceCoin = aliceInitCoin + txrefs - (coin + fee + txdeps) txbody = TxBody @@ -286,7 +287,7 @@ tx3Body = TxBody emptyUpdate tx3 :: Tx -tx3 = Tx tx3Body (makeWitnessesVKey tx3Body keys) +tx3 = Tx tx3Body (makeWitnessesVKey tx3Body keys) Map.empty where keys = [alicePay, aliceStake, stakePoolKey1] utxoSt3 :: UTxOState @@ -356,7 +357,7 @@ tx4Body = TxBody emptyUpdate tx4 :: Tx -tx4 = Tx tx4Body (makeWitnessesVKey tx4Body [alicePay, stakePoolKey1]) +tx4 = Tx tx4Body (makeWitnessesVKey tx4Body [alicePay, stakePoolKey1]) Map.empty utxoSt4 :: UTxOState utxoSt4 = UTxOState @@ -389,7 +390,7 @@ tx5Body e = TxBody emptyUpdate tx5 :: Epoch -> Tx -tx5 e = Tx (tx5Body e) (makeWitnessesVKey (tx5Body e) [alicePay, stakePoolKey1]) +tx5 e = Tx (tx5Body e) (makeWitnessesVKey (tx5Body e) [alicePay, stakePoolKey1]) Map.empty testsValidLedger :: TestTree @@ -437,7 +438,7 @@ testWitnessNotIncluded = (Coin 596) (Slot 100) emptyUpdate - tx = Tx txbody Set.empty + tx = Tx txbody Set.empty Map.empty in ledgerState [tx] @?= Left [MissingWitnesses] testSpendNotOwnedUTxO :: Assertion @@ -452,7 +453,7 @@ testSpendNotOwnedUTxO = (Slot 100) emptyUpdate aliceWit = makeWitnessVKey txbody alicePay - tx = Tx txbody (Set.fromList [aliceWit]) + tx = Tx txbody (Set.fromList [aliceWit]) Map.empty in ledgerState [tx] @?= Left [MissingWitnesses] testWitnessWrongUTxO :: Assertion @@ -475,7 +476,7 @@ testWitnessWrongUTxO = (Slot 101) emptyUpdate aliceWit = makeWitnessVKey tx2body alicePay - tx = Tx txbody (Set.fromList [aliceWit]) + tx = Tx txbody (Set.fromList [aliceWit]) Map.empty in ledgerState [tx] @?= Left [ InvalidWitness , MissingWitnesses] @@ -493,7 +494,7 @@ testEmptyInputSet = emptyUpdate wits = makeWitnessesVKey tx [aliceStake] genesisWithReward' = changeReward genesis (mkRwdAcnt aliceStake) (Coin 2000) - ls = asStateTransition (Slot 0) testPCs genesisWithReward' (Tx tx wits) (Dms Map.empty) + ls = asStateTransition (Slot 0) testPCs genesisWithReward' (Tx tx wits Map.empty) (Dms Map.empty) in ls @?= Left [ InputSetEmpty ] testFeeTooSmall :: Assertion From 08157318f606bf31d1b03a525c9c5d640dd43a33 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Matthias=20G=C3=BCdemann?= Date: Mon, 15 Jul 2019 15:44:44 +0200 Subject: [PATCH 05/15] Pass `Tx` in `DELPL` environment --- shelley/chain-and-ledger/executable-spec/src/STS/Delegs.hs | 4 ++-- shelley/chain-and-ledger/executable-spec/src/STS/Delpl.hs | 6 ++++-- 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/shelley/chain-and-ledger/executable-spec/src/STS/Delegs.hs b/shelley/chain-and-ledger/executable-spec/src/STS/Delegs.hs index 87bc4e1170d..58a9dae6386 100644 --- a/shelley/chain-and-ledger/executable-spec/src/STS/Delegs.hs +++ b/shelley/chain-and-ledger/executable-spec/src/STS/Delegs.hs @@ -50,7 +50,7 @@ delegsTransition . (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo) => TransitionRule (DELEGS hashAlgo dsignAlgo) delegsTransition = do - TRC (env@(_slot, txIx, pp, Tx txbody _ _), dpstate, certificates) <- judgmentContext + TRC (env@(_slot, txIx, pp, tx@(Tx txbody _ _)), dpstate, certificates) <- judgmentContext case certificates of [] -> do let wdrls' = _wdrls txbody @@ -83,7 +83,7 @@ delegsTransition = do trans @(DELEGS hashAlgo dsignAlgo) $ TRC (env, dpstate, _certs) dpstate'' <- trans @(DELPL hashAlgo dsignAlgo) - $ TRC ((_slot, ptr, pp), dpstate', cert) + $ TRC ((_slot, ptr, pp, tx), dpstate', cert) pure dpstate'' instance diff --git a/shelley/chain-and-ledger/executable-spec/src/STS/Delpl.hs b/shelley/chain-and-ledger/executable-spec/src/STS/Delpl.hs index b5f023f72ec..be5422edd7f 100644 --- a/shelley/chain-and-ledger/executable-spec/src/STS/Delpl.hs +++ b/shelley/chain-and-ledger/executable-spec/src/STS/Delpl.hs @@ -15,6 +15,7 @@ import LedgerState import Delegation.Certificates import PParams hiding (d) import Slot +import Tx import Control.State.Transition @@ -29,7 +30,8 @@ instance where type State (DELPL hashAlgo dsignAlgo) = DPState hashAlgo dsignAlgo type Signal (DELPL hashAlgo dsignAlgo) = DCert hashAlgo dsignAlgo - type Environment (DELPL hashAlgo dsignAlgo) = (Slot, Ptr, PParams) + type Environment (DELPL hashAlgo dsignAlgo) = + (Slot, Ptr, PParams, Tx hashAlgo dsignAlgo) data PredicateFailure (DELPL hashAlgo dsignAlgo) = PoolFailure (PredicateFailure (POOL hashAlgo dsignAlgo)) | DelegFailure (PredicateFailure (DELEG hashAlgo dsignAlgo)) @@ -43,7 +45,7 @@ delplTransition . (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo) => TransitionRule (DELPL hashAlgo dsignAlgo) delplTransition = do - TRC ((slotIx, ptr, pp), d, c) <- judgmentContext + TRC ((slotIx, ptr, pp, _), d, c) <- judgmentContext case c of RegPool _ -> do ps <- From 0815ec3ba41ac1769d9450ed15a52923bdf84890 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Matthias=20G=C3=BCdemann?= Date: Tue, 16 Jul 2019 11:19:40 +0200 Subject: [PATCH 06/15] Move datatype to `TxData` to solve circular module dependency --- .../executable-spec/delegation.cabal | 1 + .../src/Delegation/Certificates.hs | 66 +---- .../executable-spec/src/Tx.hs | 147 +---------- .../executable-spec/src/TxData.hs | 228 ++++++++++++++++++ 4 files changed, 235 insertions(+), 207 deletions(-) create mode 100644 shelley/chain-and-ledger/executable-spec/src/TxData.hs diff --git a/shelley/chain-and-ledger/executable-spec/delegation.cabal b/shelley/chain-and-ledger/executable-spec/delegation.cabal index 69e3b8fec54..7375bf1be2e 100644 --- a/shelley/chain-and-ledger/executable-spec/delegation.cabal +++ b/shelley/chain-and-ledger/executable-spec/delegation.cabal @@ -31,6 +31,7 @@ library Delegation.Certificates OCert Tx + TxData Updates STS.Avup STS.Bbody diff --git a/shelley/chain-and-ledger/executable-spec/src/Delegation/Certificates.hs b/shelley/chain-and-ledger/executable-spec/src/Delegation/Certificates.hs index 6b8d7da75d5..ae3d65f06cd 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Delegation/Certificates.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Delegation/Certificates.hs @@ -17,13 +17,12 @@ module Delegation.Certificates , decayPool ) where -import Cardano.Binary (ToCBOR(toCBOR), encodeListLen) - import Coin (Coin (..)) import Keys import PParams (PParams (..), keyDecayRate, keyDeposit, keyMinRefund, poolDecayRate, poolDeposit, poolMinRefund) -import Slot (Duration (..), Epoch (..), Slot (..)) +import Slot (Duration (..)) +import TxData import Delegation.PoolParams @@ -32,70 +31,9 @@ import NonIntegral (exp') import qualified Data.Map.Strict as Map import Data.Ratio (approxRational) -import Data.Word (Word8) import Lens.Micro ((^.)) -newtype StakeKeys hashAlgo dsignAlgo = - StakeKeys (Map.Map (KeyHash hashAlgo dsignAlgo) Slot) - deriving (Show, Eq) - -newtype StakePools hashAlgo dsignAlgo = - StakePools (Map.Map (KeyHash hashAlgo dsignAlgo) Slot) - deriving (Show, Eq) - --- | A heavyweight certificate. -data DCert hashAlgo dsignAlgo - -- | A stake key registration certificate. - = RegKey (VKey dsignAlgo) - -- | A stake key deregistration certificate. - | DeRegKey (VKey dsignAlgo) --TODO this is actually KeyHash on page 13, is that what we want? - -- | A stake pool registration certificate. - | RegPool (PoolParams hashAlgo dsignAlgo) - -- | A stake pool retirement certificate. - | RetirePool (VKey dsignAlgo) Epoch - -- | A stake delegation certificate. - | Delegate (Delegation dsignAlgo) - -- | Genesis key delegation certificate - | GenesisDelegate (VKeyGenesis dsignAlgo, VKey dsignAlgo) - deriving (Show, Eq, Ord) - -instance - (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo) - => ToCBOR (DCert hashAlgo dsignAlgo) - where - toCBOR = \case - RegKey vk -> - encodeListLen 2 - <> toCBOR (0 :: Word8) - <> toCBOR vk - - DeRegKey vk -> - encodeListLen 2 - <> toCBOR (1 :: Word8) - <> toCBOR vk - - RegPool poolParams -> - encodeListLen 2 - <> toCBOR (2 :: Word8) - <> toCBOR poolParams - - RetirePool vk epoch -> - encodeListLen 3 - <> toCBOR (3 :: Word8) - <> toCBOR vk - <> toCBOR epoch - - Delegate delegation -> - encodeListLen 2 - <> toCBOR (4 :: Word8) - <> toCBOR delegation - - GenesisDelegate keys -> - encodeListLen 2 - <> toCBOR (5 :: Word8) - <> toCBOR keys - -- |Determine the certificate author cwitness :: (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo) diff --git a/shelley/chain-and-ledger/executable-spec/src/Tx.hs b/shelley/chain-and-ledger/executable-spec/src/Tx.hs index c5ff243f925..d78e486968a 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Tx.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Tx.hs @@ -33,114 +33,19 @@ where import Keys -import Cardano.Binary (FromCBOR (fromCBOR), ToCBOR (toCBOR), decodeListLen, decodeWord, - encodeListLen, encodeWord, encodeWord8) +import Cardano.Binary (ToCBOR (toCBOR), encodeWord8) -import Cardano.Crypto.Hash (Hash, HashAlgorithm, hashWithSerialiser) +import Cardano.Crypto.Hash (HashAlgorithm, hashWithSerialiser) import Cardano.Crypto.DSIGN (DSIGNAlgorithm) import Data.Word (Word8) -import Lens.Micro.TH (makeLenses) - -import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Set (Set) import qualified Data.Set as Set -import Data.Typeable (Typeable) -import Numeric.Natural (Natural) - -import Address -import Coin (Coin (..)) -import Delegation.Certificates (DCert (..)) -import Delegation.PoolParams (RewardAcnt (..)) -import Slot (Slot (..)) -import Updates (Update) - - -data MultiSig hashAlgo dsignAlgo = - SingleSig (KeyHash hashAlgo dsignAlgo) - | MultiSig Int [MultiSig hashAlgo dsignAlgo] - deriving (Show, Eq, Ord) - -newtype ScriptHash hashAlgo dsignAlgo = - ScriptHash (Hash hashAlgo (MultiSig hashAlgo dsignAlgo)) - deriving (Show, Eq, Ord, ToCBOR) - -type Wdrl hashAlgo dsignAlgo = Map (RewardAcnt hashAlgo dsignAlgo) Coin - --- |A unique ID of a transaction, which is computable from the transaction. -newtype TxId hashAlgo dsignAlgo - = TxId { _TxId :: Hash hashAlgo (TxBody hashAlgo dsignAlgo) } - deriving (Show, Eq, Ord, ToCBOR) - --- |The input of a UTxO. -data TxIn hashAlgo dsignAlgo - = TxIn (TxId hashAlgo dsignAlgo) Natural - deriving (Show, Eq, Ord) - -instance - (Typeable dsignAlgo, HashAlgorithm hashAlgo) - => ToCBOR (TxIn hashAlgo dsignAlgo) - where - toCBOR (TxIn txId index) = - encodeListLen 2 - <> toCBOR txId - <> toCBOR index - --- |The output of a UTxO. -data TxOut hashAlgo dsignAlgo - = TxOut (Addr hashAlgo dsignAlgo) Coin - deriving (Show, Eq, Ord) - -instance - (Typeable dsignAlgo, HashAlgorithm hashAlgo) - => ToCBOR (TxOut hashAlgo dsignAlgo) - where - toCBOR (TxOut addr coin) = - encodeListLen 2 - <> toCBOR addr - <> toCBOR coin - --- |A raw transaction -data TxBody hashAlgo dsignAlgo - = TxBody - { _inputs :: !(Set (TxIn hashAlgo dsignAlgo)) - , _outputs :: [TxOut hashAlgo dsignAlgo] - , _certs :: ![DCert hashAlgo dsignAlgo] - , _wdrls :: Wdrl hashAlgo dsignAlgo - , _txfee :: Coin - , _ttl :: Slot - , _txUpdate :: Update dsignAlgo - } deriving (Show, Eq, Ord) - -makeLenses ''TxBody - --- |Proof/Witness that a transaction is authorized by the given key holder. -data WitVKey hashAlgo dsignAlgo - = WitVKey (VKey dsignAlgo) !(Sig dsignAlgo (TxBody hashAlgo dsignAlgo)) - deriving (Show, Eq, Ord) - -instance - (Typeable hashAlgo, DSIGNAlgorithm dsignAlgo) - => ToCBOR (WitVKey hashAlgo dsignAlgo) - where - toCBOR (WitVKey vk sig) = - encodeListLen 2 - <> toCBOR vk - <> toCBOR sig - --- |A fully formed transaction. -data Tx hashAlgo dsignAlgo - = Tx - { _body :: !(TxBody hashAlgo dsignAlgo) - , _witnessVKeySet :: !(Set (WitVKey hashAlgo dsignAlgo)) - , _witnessMSigMap :: - Map (ScriptHash hashAlgo dsignAlgo) (MultiSig hashAlgo dsignAlgo) - } deriving (Show, Eq, Ord) - -makeLenses ''Tx + +import TxData -- | Typeclass for multis-signature script data types. Allows for script -- validation and hashing. @@ -149,50 +54,6 @@ class (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo, ToCBOR a) => validateScript :: a -> Tx hashAlgo dsignAlgo -> Bool hashScript :: a -> ScriptHash hashAlgo dsignAlgo -instance - (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo) - => ToCBOR (Tx hashAlgo dsignAlgo) - where - toCBOR tx = - encodeListLen 2 - <> toCBOR (_body tx) - <> toCBOR (_witnessVKeySet tx) - <> toCBOR (_witnessMSigMap tx) - -instance - (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo) - => ToCBOR (TxBody hashAlgo dsignAlgo) - where - toCBOR txbody = - encodeListLen 6 - <> toCBOR (_inputs txbody) - <> toCBOR (_outputs txbody) - <> toCBOR (_certs txbody) - <> toCBOR (_wdrls txbody) - <> toCBOR (_txfee txbody) - <> toCBOR (_ttl txbody) - <> toCBOR (_txUpdate txbody) - -instance (DSIGNAlgorithm dsignAlgo, HashAlgorithm hashAlgo) => - ToCBOR (MultiSig hashAlgo dsignAlgo) where - toCBOR (SingleSig hk) = encodeListLen 2 <> encodeWord 0 <> toCBOR hk - toCBOR (MultiSig th msigs) = - encodeListLen 3 <> encodeWord 1 <> toCBOR th <> toCBOR msigs - -instance (DSIGNAlgorithm dsignAlgo, HashAlgorithm hashAlgo) => - FromCBOR (MultiSig hashAlgo dsignAlgo) where - fromCBOR = do - _ <- decodeListLen - ctor <- decodeWord - if ctor == 0 - then do - hk <- KeyHash <$> fromCBOR - pure $ SingleSig hk - else do - th <- fromCBOR - msigs <- fromCBOR - pure $ MultiSig th msigs - -- | Script evaluator for native multi-signature scheme. 'vhks' is the set of -- key hashes that signed the transaction to be validated. evalNativeMultiSigScript diff --git a/shelley/chain-and-ledger/executable-spec/src/TxData.hs b/shelley/chain-and-ledger/executable-spec/src/TxData.hs new file mode 100644 index 00000000000..603dec3b53a --- /dev/null +++ b/shelley/chain-and-ledger/executable-spec/src/TxData.hs @@ -0,0 +1,228 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TemplateHaskell #-} + +module TxData + where + +import Cardano.Binary (FromCBOR (fromCBOR), ToCBOR (toCBOR), decodeListLen, decodeWord, + encodeListLen, encodeWord) + +import Lens.Micro.TH (makeLenses) + +import Data.Map.Strict (Map) +import Data.Set (Set) +import Data.Typeable (Typeable) +import Data.Word (Word8) +import Numeric.Natural (Natural) + +import Address +import Coin +import Delegation.PoolParams +import Keys +import Slot +import Updates + +data MultiSig hashAlgo dsignAlgo = + SingleSig (KeyHash hashAlgo dsignAlgo) + | MultiSig Int [MultiSig hashAlgo dsignAlgo] + deriving (Show, Eq, Ord) + +newtype ScriptHash hashAlgo dsignAlgo = + ScriptHash (Hash hashAlgo (MultiSig hashAlgo dsignAlgo)) + deriving (Show, Eq, Ord, ToCBOR) + +type Wdrl hashAlgo dsignAlgo = Map (RewardAcnt hashAlgo dsignAlgo) Coin + +-- |A unique ID of a transaction, which is computable from the transaction. +newtype TxId hashAlgo dsignAlgo + = TxId { _TxId :: Hash hashAlgo (TxBody hashAlgo dsignAlgo) } + deriving (Show, Eq, Ord, ToCBOR) + +-- |The input of a UTxO. +data TxIn hashAlgo dsignAlgo + = TxIn (TxId hashAlgo dsignAlgo) Natural + deriving (Show, Eq, Ord) + +-- |The output of a UTxO. +data TxOut hashAlgo dsignAlgo + = TxOut (Addr hashAlgo dsignAlgo) Coin + deriving (Show, Eq, Ord) + +-- | A heavyweight certificate. +data DCert hashAlgo dsignAlgo + -- | A stake key registration certificate. + = RegKey (VKey dsignAlgo) + -- | A stake key deregistration certificate. + | DeRegKey (VKey dsignAlgo) --TODO this is actually KeyHash on page 13, is that what we want? + -- | A stake pool registration certificate. + | RegPool (PoolParams hashAlgo dsignAlgo) + -- | A stake pool retirement certificate. + | RetirePool (VKey dsignAlgo) Epoch + -- | A stake delegation certificate. + | Delegate (Delegation dsignAlgo) + -- | Genesis key delegation certificate + | GenesisDelegate (VKeyGenesis dsignAlgo, VKey dsignAlgo) + deriving (Show, Eq, Ord) + +-- |A raw transaction +data TxBody hashAlgo dsignAlgo + = TxBody + { _inputs :: !(Set (TxIn hashAlgo dsignAlgo)) + , _outputs :: [TxOut hashAlgo dsignAlgo] + , _certs :: ![DCert hashAlgo dsignAlgo] + , _wdrls :: Wdrl hashAlgo dsignAlgo + , _txfee :: Coin + , _ttl :: Slot + , _txUpdate :: Update dsignAlgo + } deriving (Show, Eq, Ord) + +makeLenses ''TxBody + +-- |Proof/Witness that a transaction is authorized by the given key holder. +data WitVKey hashAlgo dsignAlgo + = WitVKey (VKey dsignAlgo) !(Sig dsignAlgo (TxBody hashAlgo dsignAlgo)) + deriving (Show, Eq, Ord) + +-- |A fully formed transaction. +data Tx hashAlgo dsignAlgo + = Tx + { _body :: !(TxBody hashAlgo dsignAlgo) + , _witnessVKeySet :: !(Set (WitVKey hashAlgo dsignAlgo)) + , _witnessMSigMap :: + Map (ScriptHash hashAlgo dsignAlgo) (MultiSig hashAlgo dsignAlgo) + } deriving (Show, Eq, Ord) + +makeLenses ''Tx + +data StakeObject hashAlgo dsignAlgo = + KeyHashStake (KeyHash hashAlgo dsignAlgo) + | ScriptHashStake (ScriptHash hashAlgo dsignAlgo) + deriving (Show, Eq, Ord) + +-- newtype StakePools hashAlgo dsignAlgo = +-- StakePools (Map (KeyHash hashAlgo dsignAlgo) Slot) +-- deriving (Show, Eq) + +-- newtype StakeKeys hashAlgo dsignAlgo = +-- StakeKeys (Map (StakeObject hashAlgo dsignAlgo) Slot) +-- deriving (Show, Eq) + +newtype StakeKeys hashAlgo dsignAlgo = + StakeKeys (Map (KeyHash hashAlgo dsignAlgo) Slot) + deriving (Show, Eq) + +newtype StakePools hashAlgo dsignAlgo = + StakePools (Map (KeyHash hashAlgo dsignAlgo) Slot) + deriving (Show, Eq) + + +-- CBOR + +instance + (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo) + => ToCBOR (DCert hashAlgo dsignAlgo) + where + toCBOR = \case + RegKey vk -> + encodeListLen 2 + <> toCBOR (0 :: Word8) + <> toCBOR vk + + DeRegKey vk -> + encodeListLen 2 + <> toCBOR (1 :: Word8) + <> toCBOR vk + + RegPool poolParams -> + encodeListLen 2 + <> toCBOR (2 :: Word8) + <> toCBOR poolParams + + RetirePool vk epoch -> + encodeListLen 3 + <> toCBOR (3 :: Word8) + <> toCBOR vk + <> toCBOR epoch + + Delegate delegation -> + encodeListLen 2 + <> toCBOR (4 :: Word8) + <> toCBOR delegation + + GenesisDelegate keys -> + encodeListLen 2 + <> toCBOR (5 :: Word8) + <> toCBOR keys + +instance + (Typeable dsignAlgo, HashAlgorithm hashAlgo) + => ToCBOR (TxIn hashAlgo dsignAlgo) + where + toCBOR (TxIn txId index) = + encodeListLen 2 + <> toCBOR txId + <> toCBOR index + +instance + (Typeable dsignAlgo, HashAlgorithm hashAlgo) + => ToCBOR (TxOut hashAlgo dsignAlgo) + where + toCBOR (TxOut addr coin) = + encodeListLen 2 + <> toCBOR addr + <> toCBOR coin + +instance + (Typeable hashAlgo, DSIGNAlgorithm dsignAlgo) + => ToCBOR (WitVKey hashAlgo dsignAlgo) + where + toCBOR (WitVKey vk sig) = + encodeListLen 2 + <> toCBOR vk + <> toCBOR sig + + +instance + (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo) + => ToCBOR (Tx hashAlgo dsignAlgo) + where + toCBOR tx = + encodeListLen 2 + <> toCBOR (_body tx) + <> toCBOR (_witnessVKeySet tx) + <> toCBOR (_witnessMSigMap tx) + +instance + (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo) + => ToCBOR (TxBody hashAlgo dsignAlgo) + where + toCBOR txbody = + encodeListLen 6 + <> toCBOR (_inputs txbody) + <> toCBOR (_outputs txbody) + <> toCBOR (_certs txbody) + <> toCBOR (_wdrls txbody) + <> toCBOR (_txfee txbody) + <> toCBOR (_ttl txbody) + <> toCBOR (_txUpdate txbody) + +instance (DSIGNAlgorithm dsignAlgo, HashAlgorithm hashAlgo) => + ToCBOR (MultiSig hashAlgo dsignAlgo) where + toCBOR (SingleSig hk) = encodeListLen 2 <> encodeWord 0 <> toCBOR hk + toCBOR (MultiSig th msigs) = + encodeListLen 3 <> encodeWord 1 <> toCBOR th <> toCBOR msigs + +instance (DSIGNAlgorithm dsignAlgo, HashAlgorithm hashAlgo) => + FromCBOR (MultiSig hashAlgo dsignAlgo) where + fromCBOR = do + _ <- decodeListLen + ctor <- decodeWord + if ctor == 0 + then do + hk <- KeyHash <$> fromCBOR + pure $ SingleSig hk + else do + th <- fromCBOR + msigs <- fromCBOR + pure $ MultiSig th msigs From 08150c022e3567d27b956f4bb235453371160da9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Matthias=20G=C3=BCdemann?= Date: Tue, 16 Jul 2019 13:05:16 +0200 Subject: [PATCH 07/15] Move `Addr` to `TxData` --- .../executable-spec/src/Address.hs | 51 +------------------ .../executable-spec/src/EpochBoundary.hs | 2 +- .../executable-spec/src/LedgerState.hs | 2 +- .../executable-spec/src/STS/Deleg.hs | 2 +- .../executable-spec/src/STS/Delegs.hs | 2 +- .../executable-spec/src/STS/Delpl.hs | 2 +- .../executable-spec/src/STS/Pool.hs | 2 +- .../executable-spec/src/TxData.hs | 42 ++++++++++++++- 8 files changed, 48 insertions(+), 57 deletions(-) diff --git a/shelley/chain-and-ledger/executable-spec/src/Address.hs b/shelley/chain-and-ledger/executable-spec/src/Address.hs index 7b8a21241b2..ea8aecbb189 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Address.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Address.hs @@ -1,63 +1,14 @@ {-# LANGUAGE LambdaCase #-} module Address - ( Addr(..) - , Ix - , Ptr(..) - , mkRwdAcnt + ( mkRwdAcnt ) where -import Data.Typeable (Typeable) -import Data.Word (Word8) -import Numeric.Natural (Natural) - -import Cardano.Binary (ToCBOR(toCBOR), encodeListLen) import Cardano.Crypto.Hash (HashAlgorithm) import Delegation.PoolParams (RewardAcnt(..)) import Keys -import Slot (Slot(..)) - --- |An address for UTxO. -data Addr hashAlgo dsignAlgo - = AddrTxin - { _payHK :: KeyHash hashAlgo dsignAlgo - , _stakeHK :: KeyHash hashAlgo dsignAlgo - } - | AddrPtr - { _stakePtr :: Ptr - } - deriving (Show, Eq, Ord) - -instance - (Typeable dsignAlgo, HashAlgorithm hashAlgo) - => ToCBOR (Addr hashAlgo dsignAlgo) - where - toCBOR = \case - AddrTxin payHK stakeHK -> - encodeListLen 3 - <> toCBOR (0 :: Word8) - <> toCBOR payHK - <> toCBOR stakeHK - AddrPtr stakePtr -> - encodeListLen 2 - <> toCBOR (1 :: Word8) - <> toCBOR stakePtr - -type Ix = Natural - --- | Pointer to a slot, transaction index and index in certificate list. -data Ptr - = Ptr Slot Ix Ix - deriving (Show, Eq, Ord) - -instance ToCBOR Ptr where - toCBOR (Ptr slot txIx certIx) = - encodeListLen 3 - <> toCBOR slot - <> toCBOR txIx - <> toCBOR certIx mkRwdAcnt :: ( HashAlgorithm hashAlgo diff --git a/shelley/chain-and-ledger/executable-spec/src/EpochBoundary.hs b/shelley/chain-and-ledger/executable-spec/src/EpochBoundary.hs index 2350e8a155e..5875c642317 100644 --- a/shelley/chain-and-ledger/executable-spec/src/EpochBoundary.hs +++ b/shelley/chain-and-ledger/executable-spec/src/EpochBoundary.hs @@ -30,7 +30,6 @@ module EpochBoundary , groupByPool ) where -import Address import Coin import Delegation.Certificates (StakeKeys (..), StakePools (..), decayKey, decayPool, refund) @@ -39,6 +38,7 @@ import Keys import PParams hiding (a0, nOpt) import Slot import Tx +import TxData import UTxO hiding (dom) import qualified Data.Map.Strict as Map diff --git a/shelley/chain-and-ledger/executable-spec/src/LedgerState.hs b/shelley/chain-and-ledger/executable-spec/src/LedgerState.hs index 4891b16aabb..b50419557d1 100644 --- a/shelley/chain-and-ledger/executable-spec/src/LedgerState.hs +++ b/shelley/chain-and-ledger/executable-spec/src/LedgerState.hs @@ -120,7 +120,6 @@ import Numeric.Natural (Natural) import Lens.Micro ((%~), (&), (.~), (^.)) import Lens.Micro.TH (makeLenses) -import Address import Coin (Coin (..)) import EpochBoundary import Keys @@ -128,6 +127,7 @@ import PParams (PParams (..), emptyPParams, keyDecayRate, keyDeposit, minfeeA, minfeeB) import Slot (Epoch (..), Slot (..), epochFromSlot, firstSlot, slotsPerEpoch, (-*)) import Tx +import TxData import qualified Updates import UTxO diff --git a/shelley/chain-and-ledger/executable-spec/src/STS/Deleg.hs b/shelley/chain-and-ledger/executable-spec/src/STS/Deleg.hs index 6252c273fc0..069736cdd25 100644 --- a/shelley/chain-and-ledger/executable-spec/src/STS/Deleg.hs +++ b/shelley/chain-and-ledger/executable-spec/src/STS/Deleg.hs @@ -8,12 +8,12 @@ where import qualified Data.Map.Strict as Map -import Address import BlockChain (slotsPrior) import Delegation.Certificates import Keys import LedgerState import Slot +import TxData import Control.State.Transition diff --git a/shelley/chain-and-ledger/executable-spec/src/STS/Delegs.hs b/shelley/chain-and-ledger/executable-spec/src/STS/Delegs.hs index 58a9dae6386..e266d92cd80 100644 --- a/shelley/chain-and-ledger/executable-spec/src/STS/Delegs.hs +++ b/shelley/chain-and-ledger/executable-spec/src/STS/Delegs.hs @@ -11,7 +11,6 @@ where import qualified Data.Map.Strict as Map -import Address import Delegation.Certificates import Delegation.PoolParams import Keys @@ -19,6 +18,7 @@ import LedgerState import PParams hiding (d) import Slot import Tx +import TxData import Control.State.Transition diff --git a/shelley/chain-and-ledger/executable-spec/src/STS/Delpl.hs b/shelley/chain-and-ledger/executable-spec/src/STS/Delpl.hs index be5422edd7f..bdf15a7506e 100644 --- a/shelley/chain-and-ledger/executable-spec/src/STS/Delpl.hs +++ b/shelley/chain-and-ledger/executable-spec/src/STS/Delpl.hs @@ -9,13 +9,13 @@ module STS.Delpl ) where -import Address import Keys import LedgerState import Delegation.Certificates import PParams hiding (d) import Slot import Tx +import TxData import Control.State.Transition diff --git a/shelley/chain-and-ledger/executable-spec/src/STS/Pool.hs b/shelley/chain-and-ledger/executable-spec/src/STS/Pool.hs index 6d8bac94982..bf523540525 100644 --- a/shelley/chain-and-ledger/executable-spec/src/STS/Pool.hs +++ b/shelley/chain-and-ledger/executable-spec/src/STS/Pool.hs @@ -8,12 +8,12 @@ where import Lens.Micro ( (^.) ) -import Address import Delegation.Certificates import Keys import LedgerState import PParams import Slot +import TxData import Control.State.Transition diff --git a/shelley/chain-and-ledger/executable-spec/src/TxData.hs b/shelley/chain-and-ledger/executable-spec/src/TxData.hs index 603dec3b53a..1edc86d6b6e 100644 --- a/shelley/chain-and-ledger/executable-spec/src/TxData.hs +++ b/shelley/chain-and-ledger/executable-spec/src/TxData.hs @@ -16,13 +16,30 @@ import Data.Typeable (Typeable) import Data.Word (Word8) import Numeric.Natural (Natural) -import Address import Coin import Delegation.PoolParams import Keys import Slot import Updates +-- |An address for UTxO. +data Addr hashAlgo dsignAlgo + = AddrTxin + { _payHK :: KeyHash hashAlgo dsignAlgo + , _stakeHK :: KeyHash hashAlgo dsignAlgo + } + | AddrPtr + { _stakePtr :: Ptr + } + deriving (Show, Eq, Ord) + +type Ix = Natural + +-- | Pointer to a slot, transaction index and index in certificate list. +data Ptr + = Ptr Slot Ix Ix + deriving (Show, Eq, Ord) + data MultiSig hashAlgo dsignAlgo = SingleSig (KeyHash hashAlgo dsignAlgo) | MultiSig Int [MultiSig hashAlgo dsignAlgo] @@ -226,3 +243,26 @@ instance (DSIGNAlgorithm dsignAlgo, HashAlgorithm hashAlgo) => th <- fromCBOR msigs <- fromCBOR pure $ MultiSig th msigs + + +instance + (Typeable dsignAlgo, HashAlgorithm hashAlgo) + => ToCBOR (Addr hashAlgo dsignAlgo) + where + toCBOR = \case + AddrTxin payHK stakeHK -> + encodeListLen 3 + <> toCBOR (0 :: Word8) + <> toCBOR payHK + <> toCBOR stakeHK + AddrPtr stakePtr -> + encodeListLen 2 + <> toCBOR (1 :: Word8) + <> toCBOR stakePtr + +instance ToCBOR Ptr where + toCBOR (Ptr sl txIx certIx) = + encodeListLen 3 + <> toCBOR sl + <> toCBOR txIx + <> toCBOR certIx From 0815b45f0a5c68ef914373a74710e7e50b55f70a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Matthias=20G=C3=BCdemann?= Date: Tue, 16 Jul 2019 13:09:04 +0200 Subject: [PATCH 08/15] Add `AddrScr` constructor --- .../executable-spec/src/LedgerState.hs | 1 + .../chain-and-ledger/executable-spec/src/TxData.hs | 13 +++++++++++-- 2 files changed, 12 insertions(+), 2 deletions(-) diff --git a/shelley/chain-and-ledger/executable-spec/src/LedgerState.hs b/shelley/chain-and-ledger/executable-spec/src/LedgerState.hs index b50419557d1..a04bccb7a31 100644 --- a/shelley/chain-and-ledger/executable-spec/src/LedgerState.hs +++ b/shelley/chain-and-ledger/executable-spec/src/LedgerState.hs @@ -947,6 +947,7 @@ delegatedStake ls@(LedgerState _ ds _) = Map.fromListWith (+) delegatedOutputs addStake delegs (TxOut (AddrTxin _ hsk) c) = do pool <- Map.lookup hsk delegs return (pool, c) + addStake _ (TxOut (AddrScr _ _) _) = undefined -- TODO: script addresses addStake delegs (TxOut (AddrPtr ptr) c) = do key <- Map.lookup ptr $ ds ^. dstate . ptrs pool <- Map.lookup key delegs diff --git a/shelley/chain-and-ledger/executable-spec/src/TxData.hs b/shelley/chain-and-ledger/executable-spec/src/TxData.hs index 1edc86d6b6e..063e4d64a64 100644 --- a/shelley/chain-and-ledger/executable-spec/src/TxData.hs +++ b/shelley/chain-and-ledger/executable-spec/src/TxData.hs @@ -25,9 +25,13 @@ import Updates -- |An address for UTxO. data Addr hashAlgo dsignAlgo = AddrTxin - { _payHK :: KeyHash hashAlgo dsignAlgo + { _payHK :: KeyHash hashAlgo dsignAlgo , _stakeHK :: KeyHash hashAlgo dsignAlgo } + | AddrScr + { _payScr :: ScriptHash hashAlgo dsignAlgo + , _stakeScr :: ScriptHash hashAlgo dsignAlgo + } | AddrPtr { _stakePtr :: Ptr } @@ -255,9 +259,14 @@ instance <> toCBOR (0 :: Word8) <> toCBOR payHK <> toCBOR stakeHK + AddrScr payScr stakeScr -> + encodeListLen 3 + <> toCBOR (1 :: Word8) + <> toCBOR payScr + <> toCBOR stakeScr AddrPtr stakePtr -> encodeListLen 2 - <> toCBOR (1 :: Word8) + <> toCBOR (2 :: Word8) <> toCBOR stakePtr instance ToCBOR Ptr where From 0815cb01e6f747e28010febeaf400a14bf92de05 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Matthias=20G=C3=BCdemann?= Date: Tue, 16 Jul 2019 13:51:26 +0200 Subject: [PATCH 09/15] Adapt type of `DCert` --- .../src/Delegation/Certificates.hs | 8 +-- .../executable-spec/src/LedgerState.hs | 51 ++++++++----------- .../executable-spec/src/TxData.hs | 28 +++++++--- 3 files changed, 47 insertions(+), 40 deletions(-) diff --git a/shelley/chain-and-ledger/executable-spec/src/Delegation/Certificates.hs b/shelley/chain-and-ledger/executable-spec/src/Delegation/Certificates.hs index ae3d65f06cd..839b414e1e1 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Delegation/Certificates.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Delegation/Certificates.hs @@ -39,10 +39,12 @@ cwitness :: (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo) => DCert hashAlgo dsignAlgo -> KeyHash hashAlgo dsignAlgo -cwitness (RegKey k) = hashKey k -cwitness (DeRegKey k) = hashKey k +cwitness (RegKey (KeyHashStake hk)) = hk +cwitness (DeRegKey (KeyHashStake hk)) = hk +cwitness (RegKey (ScriptHashStake _)) = undefined +cwitness (DeRegKey (ScriptHashStake _)) = undefined cwitness (RegPool pool) = hashKey $ pool ^. poolPubKey -cwitness (RetirePool k _) = hashKey k +cwitness (RetirePool k _) = k cwitness (Delegate delegation) = hashKey $ delegation ^. delegator cwitness (GenesisDelegate (gk, _)) = hashGenesisKey gk diff --git a/shelley/chain-and-ledger/executable-spec/src/LedgerState.hs b/shelley/chain-and-ledger/executable-spec/src/LedgerState.hs index a04bccb7a31..5545be58284 100644 --- a/shelley/chain-and-ledger/executable-spec/src/LedgerState.hs +++ b/shelley/chain-and-ledger/executable-spec/src/LedgerState.hs @@ -444,8 +444,7 @@ produced pp stakePools tx = -- |Compute the key deregistration refunds in a transaction keyRefunds - :: (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo) - => PParams + :: PParams -> StakeKeys hashAlgo dsignAlgo -> TxBody hashAlgo dsignAlgo -> Coin @@ -455,8 +454,7 @@ keyRefunds pp stk tx = -- | Key refund for a deregistration certificate. keyRefund - :: (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo) - => Coin + :: Coin -> UnitInterval -> Rational -> StakeKeys hashAlgo dsignAlgo @@ -465,25 +463,24 @@ keyRefund -> Coin keyRefund dval dmin lambda (StakeKeys stkeys) slot c = case c of - DeRegKey key -> case Map.lookup (hashKey key) stkeys of + DeRegKey (KeyHashStake key) -> case Map.lookup key stkeys of -- TODO Nothing -> Coin 0 Just s -> refund dval dmin lambda $ slot -* s _ -> Coin 0 -- | Functions to calculate decayed deposits decayedKey - :: (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo) - => PParams + :: PParams -> StakeKeys hashAlgo dsignAlgo -> Slot -> DCert hashAlgo dsignAlgo -> Coin decayedKey pp stk@(StakeKeys stkeys) cslot cert = case cert of - DeRegKey key -> - if Map.notMember (hashKey key) stkeys + DeRegKey (KeyHashStake key) -> -- TODO + if Map.notMember key stkeys then 0 - else let created' = stkeys Map.! hashKey key in + else let created' = stkeys Map.! key in let start = max (firstSlot $ epochFromSlot cslot) created' in let dval = pp ^. keyDeposit in let dmin = pp ^. keyMinRefund in @@ -495,8 +492,7 @@ decayedKey pp stk@(StakeKeys stkeys) cslot cert = -- | Decayed deposit portions decayedTx - :: (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo) - => PParams + :: PParams -> StakeKeys hashAlgo dsignAlgo -> TxBody hashAlgo dsignAlgo -> Coin @@ -505,8 +501,7 @@ decayedTx pp stk tx = -- |Compute the lovelace which are destroyed by the transaction consumed - :: (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo) - => PParams + :: PParams -> UTxO hashAlgo dsignAlgo -> StakeKeys hashAlgo dsignAlgo -> TxBody hashAlgo dsignAlgo @@ -676,25 +671,23 @@ validTx tx d slot pp l = -- | Checks whether a key registration certificat is valid. validKeyRegistration - :: (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo) - => DCert hashAlgo dsignAlgo + :: DCert hashAlgo dsignAlgo -> DState hashAlgo dsignAlgo -> Validity validKeyRegistration cert ds = case cert of - RegKey key -> if not $ Map.member (hashKey key) stakeKeys + RegKey (KeyHashStake key) -> if not $ Map.member key stakeKeys -- TODO then Valid else Invalid [StakeKeyAlreadyRegistered] where (StakeKeys stakeKeys) = ds ^. stKeys _ -> Valid validKeyDeregistration - :: (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo) - => DCert hashAlgo dsignAlgo + :: DCert hashAlgo dsignAlgo -> DState hashAlgo dsignAlgo -> Validity validKeyDeregistration cert ds = case cert of - DeRegKey key -> if Map.member (hashKey key) stakeKeys + DeRegKey (KeyHashStake key) -> if Map.member key stakeKeys -- TODO then Valid else Invalid [StakeKeyNotRegistered] where (StakeKeys stakeKeys) = ds ^. stKeys _ -> Valid @@ -720,13 +713,12 @@ validStakePoolRegister validStakePoolRegister _ _ = Valid validStakePoolRetire - :: (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo) - => DCert hashAlgo dsignAlgo + :: DCert hashAlgo dsignAlgo -> PState hashAlgo dsignAlgo -> Validity validStakePoolRetire cert ps = case cert of - RetirePool key _ -> if Map.member (hashKey key) stakePools + RetirePool key _ -> if Map.member key stakePools then Valid else Invalid [StakePoolNotRegisteredOnKey] where (StakePools stakePools) = ps ^. stPools _ -> Valid @@ -895,20 +887,22 @@ applyDCertDState -> DCert hashAlgo dsignAlgo -> DState hashAlgo dsignAlgo -> DState hashAlgo dsignAlgo -applyDCertDState (Ptr slot txIx clx) (DeRegKey key) ds = +applyDCertDState (Ptr slot txIx clx) (DeRegKey (KeyHashStake key)) ds = -- TODO ds & stKeys .~ (StakeKeys $ Map.delete hksk stkeys') & rewards %~ Map.delete (RewardAcnt hksk) & delegations %~ Map.delete hksk & ptrs %~ Map.delete (Ptr slot txIx clx) - where hksk = hashKey key + where hksk = key (StakeKeys stkeys') = ds ^. stKeys +applyDCertDState _ (DeRegKey (ScriptHashStake _)) _ = undefined -applyDCertDState (Ptr slot txIx clx) (RegKey key) ds = +applyDCertDState (Ptr slot txIx clx) (RegKey (KeyHashStake key)) ds = -- TODO ds & stKeys .~ (StakeKeys $ Map.insert hksk slot stkeys') & rewards %~ Map.insert (RewardAcnt hksk) (Coin 0) & ptrs %~ Map.insert (Ptr slot txIx clx) hksk - where hksk = hashKey key + where hksk = key (StakeKeys stkeys') = ds ^. stKeys +applyDCertDState _ (RegKey (ScriptHashStake _)) _ = undefined applyDCertDState _ (Delegate (Delegation source target)) ds = ds & delegations %~ Map.insert (hashKey source) (hashKey target) @@ -931,8 +925,7 @@ applyDCertPState (Ptr slot _ _ ) (RegPool sp) ps = -- TODO check epoch (not in new doc atm.) applyDCertPState _ (RetirePool key epoch) ps = - ps & retiring %~ Map.insert hk_sp epoch - where hk_sp = hashKey key + ps & retiring %~ Map.insert key epoch -- | Use onlt pool registration or retirement certificates applyDCertPState _ _ ps = ps diff --git a/shelley/chain-and-ledger/executable-spec/src/TxData.hs b/shelley/chain-and-ledger/executable-spec/src/TxData.hs index 063e4d64a64..fa5b7fd7e3b 100644 --- a/shelley/chain-and-ledger/executable-spec/src/TxData.hs +++ b/shelley/chain-and-ledger/executable-spec/src/TxData.hs @@ -70,16 +70,21 @@ data TxOut hashAlgo dsignAlgo = TxOut (Addr hashAlgo dsignAlgo) Coin deriving (Show, Eq, Ord) +data StakeObject hashAlgo dsignAlgo = + KeyHashStake (KeyHash hashAlgo dsignAlgo) + | ScriptHashStake (ScriptHash hashAlgo dsignAlgo) + deriving (Show, Eq, Ord) + -- | A heavyweight certificate. data DCert hashAlgo dsignAlgo -- | A stake key registration certificate. - = RegKey (VKey dsignAlgo) + = RegKey (StakeObject hashAlgo dsignAlgo) -- | A stake key deregistration certificate. - | DeRegKey (VKey dsignAlgo) --TODO this is actually KeyHash on page 13, is that what we want? + | DeRegKey (StakeObject hashAlgo dsignAlgo) --TODO this is actually KeyHash on page 13, is that what we want? -- | A stake pool registration certificate. | RegPool (PoolParams hashAlgo dsignAlgo) -- | A stake pool retirement certificate. - | RetirePool (VKey dsignAlgo) Epoch + | RetirePool (KeyHash hashAlgo dsignAlgo) Epoch -- | A stake delegation certificate. | Delegate (Delegation dsignAlgo) -- | Genesis key delegation certificate @@ -116,11 +121,6 @@ data Tx hashAlgo dsignAlgo makeLenses ''Tx -data StakeObject hashAlgo dsignAlgo = - KeyHashStake (KeyHash hashAlgo dsignAlgo) - | ScriptHashStake (ScriptHash hashAlgo dsignAlgo) - deriving (Show, Eq, Ord) - -- newtype StakePools hashAlgo dsignAlgo = -- StakePools (Map (KeyHash hashAlgo dsignAlgo) Slot) -- deriving (Show, Eq) @@ -275,3 +275,15 @@ instance ToCBOR Ptr where <> toCBOR sl <> toCBOR txIx <> toCBOR certIx + +instance (Typeable dsignAlgo, HashAlgorithm hashAlgo) + => ToCBOR (StakeObject hashAlgo dsignAlgo) where + toCBOR = \case + KeyHashStake kh -> + encodeListLen 2 + <> toCBOR (0 :: Word8) + <> toCBOR kh + ScriptHashStake sc -> + encodeListLen 2 + <> toCBOR (1 :: Word8) + <> toCBOR sc From 08152655aff4cd8ec796ded0c831f9b5f5cd3cdc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Matthias=20G=C3=BCdemann?= Date: Tue, 16 Jul 2019 14:22:33 +0200 Subject: [PATCH 10/15] Rename `AddrTxin` to `AddrVKey` / adapt tests --- .../executable-spec/src/EpochBoundary.hs | 2 +- .../executable-spec/src/LedgerState.hs | 4 ++-- .../executable-spec/src/TxData.hs | 4 ++-- .../executable-spec/test/Generator.hs | 14 +++++++------- .../executable-spec/test/MockTypes.hs | 4 ++-- .../executable-spec/test/Mutator.hs | 11 +++++++---- .../executable-spec/test/UnitTests.hs | 15 ++++++++------- 7 files changed, 29 insertions(+), 25 deletions(-) diff --git a/shelley/chain-and-ledger/executable-spec/src/EpochBoundary.hs b/shelley/chain-and-ledger/executable-spec/src/EpochBoundary.hs index 5875c642317..509cf891f74 100644 --- a/shelley/chain-and-ledger/executable-spec/src/EpochBoundary.hs +++ b/shelley/chain-and-ledger/executable-spec/src/EpochBoundary.hs @@ -64,7 +64,7 @@ newtype Stake hashAlgo dsignAlgo -- | Extract hash of staking key from base address. getStakeHK :: Addr hashAlgo dsignAlgo -> Maybe (KeyHash hashAlgo dsignAlgo) -getStakeHK (AddrTxin _ hk) = Just hk +getStakeHK (AddrVKey _ hk) = Just hk getStakeHK _ = Nothing consolidate :: UTxO hashAlgo dsignAlgo -> Map.Map (Addr hashAlgo dsignAlgo) Coin diff --git a/shelley/chain-and-ledger/executable-spec/src/LedgerState.hs b/shelley/chain-and-ledger/executable-spec/src/LedgerState.hs index 5545be58284..9355903b0e4 100644 --- a/shelley/chain-and-ledger/executable-spec/src/LedgerState.hs +++ b/shelley/chain-and-ledger/executable-spec/src/LedgerState.hs @@ -560,7 +560,7 @@ witsNeeded utxo' tx@(Tx txbody _ _) _dms = inputAuthors = Set.foldr insertHK Set.empty (txbody ^. inputs) insertHK txin hkeys = case txinLookup txin utxo' of - Just (TxOut (AddrTxin pay _) _) -> Set.insert pay hkeys + Just (TxOut (AddrVKey pay _) _) -> Set.insert pay hkeys _ -> hkeys wdrlAuthors = Set.map getRwdHK (Map.keysSet (txbody ^. wdrls)) @@ -937,7 +937,7 @@ delegatedStake delegatedStake ls@(LedgerState _ ds _) = Map.fromListWith (+) delegatedOutputs where getOutputs (UTxO utxo') = Map.elems utxo' - addStake delegs (TxOut (AddrTxin _ hsk) c) = do + addStake delegs (TxOut (AddrVKey _ hsk) c) = do pool <- Map.lookup hsk delegs return (pool, c) addStake _ (TxOut (AddrScr _ _) _) = undefined -- TODO: script addresses diff --git a/shelley/chain-and-ledger/executable-spec/src/TxData.hs b/shelley/chain-and-ledger/executable-spec/src/TxData.hs index fa5b7fd7e3b..233f7604f64 100644 --- a/shelley/chain-and-ledger/executable-spec/src/TxData.hs +++ b/shelley/chain-and-ledger/executable-spec/src/TxData.hs @@ -24,7 +24,7 @@ import Updates -- |An address for UTxO. data Addr hashAlgo dsignAlgo - = AddrTxin + = AddrVKey { _payHK :: KeyHash hashAlgo dsignAlgo , _stakeHK :: KeyHash hashAlgo dsignAlgo } @@ -254,7 +254,7 @@ instance => ToCBOR (Addr hashAlgo dsignAlgo) where toCBOR = \case - AddrTxin payHK stakeHK -> + AddrVKey payHK stakeHK -> encodeListLen 3 <> toCBOR (0 :: Word8) <> toCBOR payHK diff --git a/shelley/chain-and-ledger/executable-spec/test/Generator.hs b/shelley/chain-and-ledger/executable-spec/test/Generator.hs index 597b72dc0d9..a7f9294ad27 100644 --- a/shelley/chain-and-ledger/executable-spec/test/Generator.hs +++ b/shelley/chain-and-ledger/executable-spec/test/Generator.hs @@ -33,7 +33,7 @@ import Hedgehog import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range -import Address (pattern AddrTxin) +import TxData (pattern AddrVKey, StakeObject(..)) import BaseTypes import Coin import Keys (pattern KeyPair, hashKey, vKey) @@ -86,7 +86,7 @@ hashKeyPairs keyPairs = -- | Transforms list of keypairs into 'Addr' types of the form 'AddrTxin pay -- stake' addrTxins :: KeyPairs -> [Addr] -addrTxins keyPairs = uncurry AddrTxin <$> hashKeyPairs keyPairs +addrTxins keyPairs = uncurry AddrVKey <$> hashKeyPairs keyPairs genBool :: Gen Bool genBool = Gen.enumBounded @@ -145,7 +145,7 @@ genTx keyList (UTxO m) cslot = do let realN = length receipients let (perReceipient, txfee') = splitCoin selectedBalance (fromIntegral realN) let !receipientAddrs = fmap - (\(p, d) -> AddrTxin (hashKey $ vKey p) (hashKey $ vKey d)) receipients + (\(p, d) -> AddrVKey (hashKey $ vKey p) (hashKey $ vKey d)) receipients txttl <- genNatural 1 100 let !txbody = TxBody (Map.keysSet selectedUTxO) @@ -235,7 +235,7 @@ repeatCollectTx' n keyPairs fees ls txs validationErrors -- | Find first matching key pair for address. Returns the matching key pair -- where the first element of the pair matched the hash in 'addr'. findPayKeyPair :: Addr -> KeyPairs -> KeyPair -findPayKeyPair (AddrTxin addr _) keyList = +findPayKeyPair (AddrVKey addr _) keyList = fst $ head $ filter (\(pay, _) -> addr == (hashKey $ vKey pay)) keyList findPayKeyPair _ _ = error "currently no such keys should be generated" @@ -304,16 +304,16 @@ genDelegationData keys epoch = genDCertRegKey :: KeyPairs -> Gen DCert genDCertRegKey keys = - RegKey <$> getAnyStakeKey keys + RegKey <$> (KeyHashStake . hashKey) <$> getAnyStakeKey keys genDCertDeRegKey :: KeyPairs -> Gen DCert genDCertDeRegKey keys = - DeRegKey <$> getAnyStakeKey keys + DeRegKey <$> (KeyHashStake . hashKey) <$> getAnyStakeKey keys genDCertRetirePool :: KeyPairs -> Epoch -> Gen DCert genDCertRetirePool keys epoch = do key <- getAnyStakeKey keys - pure $ RetirePool key epoch + pure $ RetirePool (hashKey key) epoch genStakePool :: KeyPairs -> Gen PoolParams genStakePool keys = do diff --git a/shelley/chain-and-ledger/executable-spec/test/MockTypes.hs b/shelley/chain-and-ledger/executable-spec/test/MockTypes.hs index 7c090470cea..36179f89389 100644 --- a/shelley/chain-and-ledger/executable-spec/test/MockTypes.hs +++ b/shelley/chain-and-ledger/executable-spec/test/MockTypes.hs @@ -4,7 +4,6 @@ import Cardano.Crypto.DSIGN (MockDSIGN) import Cardano.Crypto.Hash (ShortHash) import Cardano.Crypto.KES (MockKES) -import qualified Address import qualified BlockChain import qualified Delegation.Certificates import qualified Delegation.PoolParams @@ -13,6 +12,7 @@ import qualified LedgerState import qualified OCert import qualified STS.Chain import qualified Tx +import qualified TxData import qualified UTxO type DCert = Delegation.Certificates.DCert ShortHash MockDSIGN @@ -39,7 +39,7 @@ type UTxOState = LedgerState.UTxOState ShortHash MockDSIGN type DPState = LedgerState.DPState ShortHash MockDSIGN -type Addr = Address.Addr ShortHash MockDSIGN +type Addr = TxData.Addr ShortHash MockDSIGN type Tx = Tx.Tx 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 22b9ec79194..32562f58132 100644 --- a/shelley/chain-and-ledger/executable-spec/test/Mutator.hs +++ b/shelley/chain-and-ledger/executable-spec/test/Mutator.hs @@ -32,13 +32,14 @@ import Delegation.Certificates (pattern Delegate, pattern DeRegKey, pattern GenesisDelegate, pattern RegKey, pattern RegPool, pattern RetirePool) import Delegation.PoolParams -import Keys (vKey) +import Keys (vKey, hashKey) import Updates 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 MockTypes @@ -154,14 +155,16 @@ mutateEpoch lower upper (Epoch val) = Epoch <$> mutateNat lower upper val -- A 'Delegate' certificates selects randomly keys for delegator and delegatee -- from the supplied list of keypairs. mutateDCert :: KeyPairs -> DPState -> DCert -> Gen DCert -mutateDCert keys _ (RegKey _) = RegKey . vKey . snd <$> Gen.element keys +mutateDCert keys _ (RegKey _) = + RegKey . KeyHashStake . hashKey . vKey . snd <$> Gen.element keys -mutateDCert keys _ (DeRegKey _) = DeRegKey . vKey . snd <$> Gen.element keys +mutateDCert keys _ (DeRegKey _) = + DeRegKey . KeyHashStake . hashKey . vKey . snd <$> Gen.element keys mutateDCert keys _ (RetirePool _ epoch@(Epoch e)) = do epoch' <- mutateEpoch 0 e epoch key' <- getAnyStakeKey keys - pure $ RetirePool key' epoch' + pure $ RetirePool (hashKey key') epoch' mutateDCert keys _ (RegPool (PoolParams _ pledge pledges cost margin altacnt rwdacnt owners)) = do key' <- 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 eebb6a67910..555f85a4665 100644 --- a/shelley/chain-and-ledger/executable-spec/test/UnitTests.hs +++ b/shelley/chain-and-ledger/executable-spec/test/UnitTests.hs @@ -14,7 +14,8 @@ import Lens.Micro ((^.), (&), (.~)) import Test.Tasty import Test.Tasty.HUnit -import Address (pattern AddrTxin, pattern Ptr, mkRwdAcnt) +import Address +import TxData (pattern AddrVKey, pattern Ptr, StakeObject(..)) import BaseTypes import Coin import Delegation.Certificates (pattern Delegate, pattern RegKey, @@ -46,7 +47,7 @@ aliceStake :: KeyPair aliceStake = KeyPair 2 2 aliceAddr :: Addr -aliceAddr = AddrTxin (hashKey (vKey alicePay)) (hashKey (vKey aliceStake)) +aliceAddr = AddrVKey (hashKey (vKey alicePay)) (hashKey (vKey aliceStake)) bobPay :: KeyPair bobPay = KeyPair 3 3 @@ -55,7 +56,7 @@ bobStake :: KeyPair bobStake = KeyPair 4 4 bobAddr :: Addr -bobAddr = AddrTxin (hashKey (vKey bobPay)) (hashKey (vKey bobStake)) +bobAddr = AddrVKey (hashKey (vKey bobPay)) (hashKey (vKey bobStake)) testPCs :: PParams testPCs = emptyPParams { @@ -258,9 +259,9 @@ tx2 :: Tx tx2 = aliceGivesBobLovelace (TxIn genesisId 0) (Coin 3000) (Coin 1300) (Coin 3*100) (Coin 0) - [ RegKey $ vKey aliceStake - , RegKey $ vKey bobStake - , RegKey $ vKey stakePoolKey1] + [ RegKey $ (KeyHashStake . hashKey) $ vKey aliceStake + , RegKey $ (KeyHashStake . hashKey) $ vKey bobStake + , RegKey $ (KeyHashStake . hashKey) $ vKey stakePoolKey1] (Slot 100) [alicePay, aliceStake, bobStake, stakePoolKey1] @@ -383,7 +384,7 @@ tx5Body :: Epoch -> TxBody tx5Body e = TxBody (Set.fromList [TxIn (txid $ tx3 ^. body) 0]) [ TxOut aliceAddr (Coin 2950) ] - [ RetirePool (vKey stakePoolKey1) e ] + [ RetirePool (hashKey $ vKey stakePoolKey1) e ] Map.empty (Coin 1000) (Slot 100) From 0815915ef98c73f0c527ae394b0afaddeb22af08 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Matthias=20G=C3=BCdemann?= Date: Tue, 16 Jul 2019 15:37:43 +0200 Subject: [PATCH 11/15] Use `StakeObject` in delegation - also fix use of `stPools` / `stkeys` which was used in reverse --- .../executable-spec/src/Address.hs | 4 +- .../src/Delegation/Certificates.hs | 18 ++-- .../src/Delegation/PoolParams.hs | 76 +---------------- .../executable-spec/src/EpochBoundary.hs | 22 ++--- .../executable-spec/src/LedgerState.hs | 55 ++++++------ .../executable-spec/src/STS/Deleg.hs | 4 +- .../executable-spec/src/STS/Delegs.hs | 3 +- .../executable-spec/src/Tx.hs | 8 ++ .../executable-spec/src/TxData.hs | 84 +++++++++++++++---- .../executable-spec/src/UTxO.hs | 2 +- 10 files changed, 127 insertions(+), 149 deletions(-) diff --git a/shelley/chain-and-ledger/executable-spec/src/Address.hs b/shelley/chain-and-ledger/executable-spec/src/Address.hs index ea8aecbb189..76f7cfcadbf 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Address.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Address.hs @@ -7,8 +7,8 @@ where import Cardano.Crypto.Hash (HashAlgorithm) -import Delegation.PoolParams (RewardAcnt(..)) import Keys +import TxData mkRwdAcnt :: ( HashAlgorithm hashAlgo @@ -16,4 +16,4 @@ mkRwdAcnt ) => KeyPair dsignAlgo -> RewardAcnt hashAlgo dsignAlgo -mkRwdAcnt keys = RewardAcnt $ hashKey $ vKey keys +mkRwdAcnt keys = RewardAcnt $ KeyHashStake (hashKey $ vKey keys) diff --git a/shelley/chain-and-ledger/executable-spec/src/Delegation/Certificates.hs b/shelley/chain-and-ledger/executable-spec/src/Delegation/Certificates.hs index 839b414e1e1..bd719f82adb 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Delegation/Certificates.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Delegation/Certificates.hs @@ -24,8 +24,6 @@ import PParams (PParams (..), keyDecayRate, keyDeposit, keyMinRefund, import Slot (Duration (..)) import TxData -import Delegation.PoolParams - import BaseTypes import NonIntegral (exp') @@ -38,15 +36,13 @@ import Lens.Micro ((^.)) cwitness :: (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo) => DCert hashAlgo dsignAlgo - -> KeyHash hashAlgo dsignAlgo -cwitness (RegKey (KeyHashStake hk)) = hk -cwitness (DeRegKey (KeyHashStake hk)) = hk -cwitness (RegKey (ScriptHashStake _)) = undefined -cwitness (DeRegKey (ScriptHashStake _)) = undefined -cwitness (RegPool pool) = hashKey $ pool ^. poolPubKey -cwitness (RetirePool k _) = k -cwitness (Delegate delegation) = hashKey $ delegation ^. delegator -cwitness (GenesisDelegate (gk, _)) = hashGenesisKey gk + -> StakeObject hashAlgo dsignAlgo +cwitness (RegKey hk) = hk +cwitness (DeRegKey hk) = hk +cwitness (RegPool pool) = KeyHashStake $ hashKey $ pool ^. poolPubKey +cwitness (RetirePool k _) = KeyHashStake k +cwitness (Delegate delegation) = delegation ^. delegator +cwitness (GenesisDelegate (gk, _)) = KeyHashStake $ hashGenesisKey gk -- |Retrieve the deposit amount for a certificate dvalue :: DCert hashAlgo dsignAlgo -> PParams -> Coin diff --git a/shelley/chain-and-ledger/executable-spec/src/Delegation/PoolParams.hs b/shelley/chain-and-ledger/executable-spec/src/Delegation/PoolParams.hs index f20897bd110..78bf25d74b7 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Delegation/PoolParams.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Delegation/PoolParams.hs @@ -3,86 +3,14 @@ {-# LANGUAGE TemplateHaskell #-} module Delegation.PoolParams - ( PoolParams(..) - , Delegation(..) - , RewardAcnt(..) - -- lenses - , poolPubKey - , poolPledge - , poolPledges - , poolCost - , poolMargin - , poolAltAcnt - , poolSpec - , poolRAcnt - , poolOwners - -- Delegation - , delegator - , delegatee + ( poolSpec ) where -import Data.Map.Strict (Map) -import Data.Set (Set) - import Lens.Micro ((^.)) -import Lens.Micro.TH (makeLenses) - -import Cardano.Binary (ToCBOR(toCBOR), encodeListLen) import BaseTypes import Coin (Coin) -import Keys - --- |An account based address for a rewards -newtype RewardAcnt hashAlgo signAlgo = RewardAcnt - { getRwdHK :: KeyHash hashAlgo signAlgo - } deriving (Show, Eq, Ord, ToCBOR) - - --- |A stake pool. -data PoolParams hashAlgo dsignAlgo = - PoolParams - { _poolPubKey :: VKey dsignAlgo - , _poolPledge :: Coin - , _poolPledges :: Map (VKey dsignAlgo) Coin -- TODO not updated currently - , _poolCost :: Coin - , _poolMargin :: UnitInterval - , _poolAltAcnt :: Maybe (KeyHash hashAlgo dsignAlgo) - , _poolRAcnt :: RewardAcnt hashAlgo dsignAlgo - , _poolOwners :: Set (KeyHash hashAlgo dsignAlgo) - } deriving (Show, Eq, Ord) - -makeLenses ''PoolParams - -instance - (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo) - => ToCBOR (PoolParams hashAlgo dsignAlgo) - where - toCBOR poolParams = - encodeListLen 8 - <> toCBOR (_poolPubKey poolParams) - <> toCBOR (_poolPledge poolParams) - <> toCBOR (_poolPledges poolParams) - <> toCBOR (_poolCost poolParams) - <> toCBOR (_poolMargin poolParams) - <> toCBOR (_poolAltAcnt poolParams) - <> toCBOR (_poolRAcnt poolParams) - <> toCBOR (_poolOwners poolParams) - +import TxData poolSpec :: PoolParams hashAlgo dsignAlgo -> (Coin, UnitInterval, Coin) poolSpec pool = (pool ^. poolCost, pool ^. poolMargin, pool ^. poolPledge) - --- |The delegation of one stake key to another. -data Delegation dsignAlgo = Delegation - { _delegator :: VKey dsignAlgo - , _delegatee :: VKey dsignAlgo - } deriving (Show, Eq, Ord) - -instance DSIGNAlgorithm dsignAlgo => ToCBOR (Delegation dsignAlgo) where - toCBOR delegation = - encodeListLen 2 - <> toCBOR (_delegator delegation) - <> toCBOR (_delegatee delegation) - -makeLenses ''Delegation diff --git a/shelley/chain-and-ledger/executable-spec/src/EpochBoundary.hs b/shelley/chain-and-ledger/executable-spec/src/EpochBoundary.hs index 509cf891f74..b803100f9af 100644 --- a/shelley/chain-and-ledger/executable-spec/src/EpochBoundary.hs +++ b/shelley/chain-and-ledger/executable-spec/src/EpochBoundary.hs @@ -33,7 +33,6 @@ module EpochBoundary import Coin import Delegation.Certificates (StakeKeys (..), StakePools (..), decayKey, decayPool, refund) -import Delegation.PoolParams (RewardAcnt (..), PoolParams(..)) import Keys import PParams hiding (a0, nOpt) import Slot @@ -59,12 +58,13 @@ newtype BlocksMade hashAlgo dsignAlgo -- | Type of stake as map from hash key to coins associated. newtype Stake hashAlgo dsignAlgo - = Stake (Map.Map (KeyHash hashAlgo dsignAlgo) Coin) + = Stake (Map.Map (StakeObject hashAlgo dsignAlgo) Coin) deriving (Show, Eq, Ord) -- | Extract hash of staking key from base address. -getStakeHK :: Addr hashAlgo dsignAlgo -> Maybe (KeyHash hashAlgo dsignAlgo) -getStakeHK (AddrVKey _ hk) = Just hk +getStakeHK :: Addr hashAlgo dsignAlgo -> Maybe (StakeObject hashAlgo dsignAlgo) +getStakeHK (AddrVKey _ hk) = Just $ KeyHashStake hk +getStakeHK (AddrScr _ hs) = Just $ ScriptHashStake hs getStakeHK _ = Nothing consolidate :: UTxO hashAlgo dsignAlgo -> Map.Map (Addr hashAlgo dsignAlgo) Coin @@ -78,7 +78,7 @@ baseStake vals = where convert :: (Addr hashAlgo dsignAlgo, Coin) - -> Maybe (KeyHash hashAlgo dsignAlgo, Coin) + -> Maybe (StakeObject hashAlgo dsignAlgo, Coin) convert (a, c) = (,c) <$> getStakeHK a @@ -91,14 +91,14 @@ getStakePtr _ = Nothing ptrStake :: forall hashAlgo dsignAlgo . Map.Map (Addr hashAlgo dsignAlgo) Coin - -> Map.Map Ptr (KeyHash hashAlgo dsignAlgo) + -> Map.Map Ptr (StakeObject hashAlgo dsignAlgo) -> Stake hashAlgo dsignAlgo ptrStake vals pointers = Stake $ Map.fromListWith (+) (mapMaybe convert $ Map.toList vals) where convert :: (Addr hashAlgo dsignAlgo, Coin) - -> Maybe (KeyHash hashAlgo dsignAlgo, Coin) + -> Maybe (StakeObject hashAlgo dsignAlgo, Coin) convert (a, c) = case getStakePtr a of Nothing -> Nothing @@ -117,7 +117,7 @@ rewardStake rewards = -- | Get stake of one pool poolStake :: KeyHash hashAlgo dsignAlgo - -> Map.Map (KeyHash hashAlgo dsignAlgo) (KeyHash hashAlgo dsignAlgo) + -> Map.Map (StakeObject hashAlgo dsignAlgo) (KeyHash hashAlgo dsignAlgo) -> Stake hashAlgo dsignAlgo -> Stake hashAlgo dsignAlgo poolStake hk delegs (Stake stake) = @@ -183,15 +183,15 @@ data SnapShots hashAlgo dsignAlgo = SnapShots { _pstakeMark :: ( Stake hashAlgo dsignAlgo - , Map.Map (KeyHash hashAlgo dsignAlgo) (KeyHash hashAlgo dsignAlgo) + , Map.Map (StakeObject hashAlgo dsignAlgo) (KeyHash hashAlgo dsignAlgo) ) , _pstakeSet :: ( Stake hashAlgo dsignAlgo - , Map.Map (KeyHash hashAlgo dsignAlgo) (KeyHash hashAlgo dsignAlgo) + , Map.Map (StakeObject hashAlgo dsignAlgo) (KeyHash hashAlgo dsignAlgo) ) , _pstakeGo :: ( Stake hashAlgo dsignAlgo - , Map.Map (KeyHash hashAlgo dsignAlgo) (KeyHash hashAlgo dsignAlgo) + , Map.Map (StakeObject hashAlgo dsignAlgo) (KeyHash hashAlgo dsignAlgo) ) , _poolsSS :: Map.Map (KeyHash hashAlgo dsignAlgo) (PoolParams hashAlgo dsignAlgo) diff --git a/shelley/chain-and-ledger/executable-spec/src/LedgerState.hs b/shelley/chain-and-ledger/executable-spec/src/LedgerState.hs index 9355903b0e4..94db4ea6bb1 100644 --- a/shelley/chain-and-ledger/executable-spec/src/LedgerState.hs +++ b/shelley/chain-and-ledger/executable-spec/src/LedgerState.hs @@ -133,8 +133,7 @@ import UTxO import Delegation.Certificates (DCert (..), PoolDistr (..), StakeKeys (..), StakePools (..), cwitness, decayKey, refund) -import Delegation.PoolParams (Delegation (..), PoolParams (..), RewardAcnt (..), - poolOwners, poolPledge, poolPubKey, poolRAcnt, poolSpec) +import Delegation.PoolParams import BaseTypes @@ -214,9 +213,9 @@ data DState hashAlgo dsignAlgo = DState -- |The active accounts. , _rewards :: RewardAccounts hashAlgo dsignAlgo -- |The current delegations. - , _delegations :: Map.Map (KeyHash hashAlgo dsignAlgo) (KeyHash hashAlgo dsignAlgo) + , _delegations :: Map.Map (StakeObject hashAlgo dsignAlgo) (KeyHash hashAlgo dsignAlgo) -- |The pointed to hash keys. - , _ptrs :: Map.Map Ptr (KeyHash hashAlgo dsignAlgo) + , _ptrs :: Map.Map Ptr (StakeObject hashAlgo dsignAlgo) -- | future genesis key delegations , _fdms :: Map.Map (Slot, VKeyGenesis dsignAlgo) (VKey dsignAlgo) -- |Genesis key delegations @@ -463,7 +462,7 @@ keyRefund -> Coin keyRefund dval dmin lambda (StakeKeys stkeys) slot c = case c of - DeRegKey (KeyHashStake key) -> case Map.lookup key stkeys of -- TODO + DeRegKey key -> case Map.lookup key stkeys of Nothing -> Coin 0 Just s -> refund dval dmin lambda $ slot -* s _ -> Coin 0 @@ -477,7 +476,7 @@ decayedKey -> Coin decayedKey pp stk@(StakeKeys stkeys) cslot cert = case cert of - DeRegKey (KeyHashStake key) -> -- TODO + DeRegKey key -> if Map.notMember key stkeys then 0 else let created' = stkeys Map.! key in @@ -563,10 +562,11 @@ witsNeeded utxo' tx@(Tx txbody _ _) _dms = Just (TxOut (AddrVKey pay _) _) -> Set.insert pay hkeys _ -> hkeys - wdrlAuthors = Set.map getRwdHK (Map.keysSet (txbody ^. wdrls)) + wdrlAuthors = + Set.fromList $ extractKeyHash $ map getRwdHK (Map.keys (txbody ^. wdrls)) owners = foldl Set.union Set.empty [pool ^. poolOwners | RegPool pool <- txbody ^. certs] - certAuthors = Set.fromList (fmap getCertHK (txbody ^. certs)) + certAuthors = Set.fromList $ extractKeyHash (fmap getCertHK (txbody ^. certs)) getCertHK cert = cwitness cert updateKeys = propWits (txup tx) _dms @@ -676,7 +676,7 @@ validKeyRegistration -> Validity validKeyRegistration cert ds = case cert of - RegKey (KeyHashStake key) -> if not $ Map.member key stakeKeys -- TODO + RegKey key -> if not $ Map.member key stakeKeys then Valid else Invalid [StakeKeyAlreadyRegistered] where (StakeKeys stakeKeys) = ds ^. stKeys _ -> Valid @@ -687,20 +687,19 @@ validKeyDeregistration -> Validity validKeyDeregistration cert ds = case cert of - DeRegKey (KeyHashStake key) -> if Map.member key stakeKeys -- TODO + DeRegKey key -> if Map.member key stakeKeys then Valid else Invalid [StakeKeyNotRegistered] where (StakeKeys stakeKeys) = ds ^. stKeys _ -> Valid validStakeDelegation - :: (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo) - => DCert hashAlgo dsignAlgo + :: DCert hashAlgo dsignAlgo -> DState hashAlgo dsignAlgo -> Validity validStakeDelegation cert ds = case cert of Delegate (Delegation source _) - -> if Map.member (hashKey source) stakeKeys + -> if Map.member source stakeKeys then Valid else Invalid [StakeDelegationImpossible] where (StakeKeys stakeKeys) = ds ^. stKeys _ -> Valid @@ -724,8 +723,7 @@ validStakePoolRetire cert ps = _ -> Valid validDelegation - :: (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo) - => DCert hashAlgo dsignAlgo + :: DCert hashAlgo dsignAlgo -> DPState hashAlgo dsignAlgo -> Validity validDelegation cert ds = @@ -882,30 +880,27 @@ applyDCert ptr dcert@(Delegate _) ds = ds & dstate %~ (applyDCertDState ptr dcert) applyDCertDState - :: (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo) - => Ptr + :: Ptr -> DCert hashAlgo dsignAlgo -> DState hashAlgo dsignAlgo -> DState hashAlgo dsignAlgo -applyDCertDState (Ptr slot txIx clx) (DeRegKey (KeyHashStake key)) ds = -- TODO +applyDCertDState (Ptr slot txIx clx) (DeRegKey key) ds = ds & stKeys .~ (StakeKeys $ Map.delete hksk stkeys') & rewards %~ Map.delete (RewardAcnt hksk) & delegations %~ Map.delete hksk & ptrs %~ Map.delete (Ptr slot txIx clx) where hksk = key (StakeKeys stkeys') = ds ^. stKeys -applyDCertDState _ (DeRegKey (ScriptHashStake _)) _ = undefined -applyDCertDState (Ptr slot txIx clx) (RegKey (KeyHashStake key)) ds = -- TODO +applyDCertDState (Ptr slot txIx clx) (RegKey key) ds = ds & stKeys .~ (StakeKeys $ Map.insert hksk slot stkeys') & rewards %~ Map.insert (RewardAcnt hksk) (Coin 0) & ptrs %~ Map.insert (Ptr slot txIx clx) hksk where hksk = key (StakeKeys stkeys') = ds ^. stKeys -applyDCertDState _ (RegKey (ScriptHashStake _)) _ = undefined applyDCertDState _ (Delegate (Delegation source target)) ds = - ds & delegations %~ Map.insert (hashKey source) (hashKey target) + ds & delegations %~ Map.insert source target applyDCertDState _ _ ds = ds @@ -938,7 +933,7 @@ delegatedStake ls@(LedgerState _ ds _) = Map.fromListWith (+) delegatedOutputs where getOutputs (UTxO utxo') = Map.elems utxo' addStake delegs (TxOut (AddrVKey _ hsk) c) = do - pool <- Map.lookup hsk delegs + pool <- Map.lookup (KeyHashStake hsk) delegs return (pool, c) addStake _ (TxOut (AddrScr _ _) _) = undefined -- TODO: script addresses addStake delegs (TxOut (AddrPtr ptr) c) = do @@ -954,7 +949,7 @@ delegatedStake ls@(LedgerState _ ds _) = Map.fromListWith (+) delegatedOutputs -- | Calculate pool reward poolRewards - :: KeyHash hashAlgo dsignAlgo + :: StakeObject hashAlgo dsignAlgo -- TODO check why this paramater is not used -> UnitInterval -> Natural -> Natural @@ -1001,7 +996,7 @@ rewardOnePool -> Coin -> Natural -> Natural - -> KeyHash hashAlgo dsignAlgo + -> StakeObject hashAlgo dsignAlgo -> PoolParams hashAlgo dsignAlgo -> Stake hashAlgo dsignAlgo -> Coin @@ -1039,7 +1034,7 @@ reward -> Set.Set (RewardAcnt hashAlgo dsignAlgo) -> Map.Map (KeyHash hashAlgo dsignAlgo) (PoolParams hashAlgo dsignAlgo) -> Stake hashAlgo dsignAlgo - -> Map.Map (KeyHash hashAlgo dsignAlgo) (KeyHash hashAlgo dsignAlgo) + -> Map.Map (StakeObject hashAlgo dsignAlgo) (KeyHash hashAlgo dsignAlgo) -> Map.Map (RewardAcnt hashAlgo dsignAlgo) Coin reward pp (BlocksMade b) r addrsRew poolParams stake@(Stake stake') delegs = rewards' @@ -1055,7 +1050,7 @@ reward pp (BlocksMade b) r addrsRew poolParams stake@(Stake stake') delegs = ] results = [ ( hk - , rewardOnePool pp r n totalBlocks hk pool actgr total addrsRew) + , rewardOnePool pp r n totalBlocks (KeyHashStake hk) pool actgr total addrsRew) | (hk, (pool, n, actgr)) <- pdata ] rewards' = foldl (\m (_, r') -> Map.union m r') Map.empty results @@ -1070,13 +1065,13 @@ stakeDistr stakeDistr u ds ps = Stake $ (Map.keysSet activeDelegs) ◁ stake where DState (StakeKeys stkeys) rewards' delegs ptrs' _ _ = ds - PState (StakePools stpools) _ _ _ = ps + PState (StakePools stpools) _ _ _ = ps outs = consolidate u stake = baseStake' `Map.union` pointerStake `Map.union` rewardStake' Stake baseStake' = baseStake outs Stake pointerStake = ptrStake outs ptrs' Stake rewardStake' = rewardStake rewards' - activeDelegs = (Map.keysSet stpools) ◁ delegs ▷ (Map.keysSet stkeys) + activeDelegs = (Map.keysSet stkeys) ◁ delegs ▷ (Map.keysSet stpools) -- | Pool distribution poolDistr @@ -1084,7 +1079,7 @@ poolDistr -> DState hashAlgo dsignAlgo -> PState hashAlgo dsignAlgo -> ( Stake hashAlgo dsignAlgo - , Map.Map (KeyHash hashAlgo dsignAlgo) (KeyHash hashAlgo dsignAlgo) + , Map.Map (StakeObject hashAlgo dsignAlgo) (KeyHash hashAlgo dsignAlgo) ) poolDistr u ds ps = (stake, delegs) where diff --git a/shelley/chain-and-ledger/executable-spec/src/STS/Deleg.hs b/shelley/chain-and-ledger/executable-spec/src/STS/Deleg.hs index 069736cdd25..ac85eaa8be8 100644 --- a/shelley/chain-and-ledger/executable-spec/src/STS/Deleg.hs +++ b/shelley/chain-and-ledger/executable-spec/src/STS/Deleg.hs @@ -20,7 +20,7 @@ import Control.State.Transition data DELEG hashAlgo dsignAlgo instance - (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo) + (DSIGNAlgorithm dsignAlgo) => STS (DELEG hashAlgo dsignAlgo) where type State (DELEG hashAlgo dsignAlgo) = DState hashAlgo dsignAlgo @@ -38,7 +38,7 @@ instance transitionRules = [delegationTransition] delegationTransition - :: (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo) + :: (DSIGNAlgorithm dsignAlgo) => TransitionRule (DELEG hashAlgo dsignAlgo) delegationTransition = do TRC ((_slot, p), d@(DState _ _ _ _ genMap (Dms _dms)), c) <- judgmentContext diff --git a/shelley/chain-and-ledger/executable-spec/src/STS/Delegs.hs b/shelley/chain-and-ledger/executable-spec/src/STS/Delegs.hs index e266d92cd80..44fe1a3ebfb 100644 --- a/shelley/chain-and-ledger/executable-spec/src/STS/Delegs.hs +++ b/shelley/chain-and-ledger/executable-spec/src/STS/Delegs.hs @@ -12,7 +12,6 @@ where import qualified Data.Map.Strict as Map import Delegation.Certificates -import Delegation.PoolParams import Keys import LedgerState import PParams hiding (d) @@ -76,7 +75,7 @@ delegsTransition = do let isDelegationRegistered = case cert of Delegate deleg -> let StakePools sp = _stPools $ _pstate dpstate in - Map.member (hashKey $ _delegatee deleg) sp + Map.member (_delegatee deleg) sp _ -> True isDelegationRegistered ?! DelegateeNotRegisteredDELEG dpstate' <- diff --git a/shelley/chain-and-ledger/executable-spec/src/Tx.hs b/shelley/chain-and-ledger/executable-spec/src/Tx.hs index d78e486968a..b4ffbbfa797 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Tx.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Tx.hs @@ -27,6 +27,7 @@ module Tx , hashScript , txwitsVKey , txwitsScripts + , extractKeyHash ) where @@ -41,6 +42,7 @@ import Cardano.Crypto.DSIGN (DSIGNAlgorithm) import Data.Word (Word8) +import qualified Data.Maybe as Maybe import qualified Data.Map.Strict as Map import Data.Set (Set) import qualified Data.Set as Set @@ -109,3 +111,9 @@ txwitsScripts :: Tx hashAlgo dsignAlgo -> Map.Map (ScriptHash hashAlgo dsignAlgo) (MultiSig hashAlgo dsignAlgo) txwitsScripts tx = _witnessMSigMap tx + +extractKeyHash :: [StakeObject hashAlgo dsignAlgo] -> [KeyHash hashAlgo dsignAlgo] +extractKeyHash l = + Maybe.catMaybes $ map (\so -> case so of + KeyHashStake hk -> Just hk + _ -> Nothing) l diff --git a/shelley/chain-and-ledger/executable-spec/src/TxData.hs b/shelley/chain-and-ledger/executable-spec/src/TxData.hs index 233f7604f64..c3535d3445f 100644 --- a/shelley/chain-and-ledger/executable-spec/src/TxData.hs +++ b/shelley/chain-and-ledger/executable-spec/src/TxData.hs @@ -16,12 +16,36 @@ import Data.Typeable (Typeable) import Data.Word (Word8) import Numeric.Natural (Natural) +import BaseTypes import Coin -import Delegation.PoolParams import Keys import Slot import Updates +-- |The delegation of one stake key to another. +data Delegation hashAlgo dsignAlgo = Delegation + { _delegator :: StakeObject hashAlgo dsignAlgo + , _delegatee :: KeyHash hashAlgo dsignAlgo + } deriving (Show, Eq, Ord) + +-- |A stake pool. +data PoolParams hashAlgo dsignAlgo = + PoolParams + { _poolPubKey :: VKey dsignAlgo + , _poolPledge :: Coin + , _poolPledges :: Map (VKey dsignAlgo) Coin -- TODO not updated currently + , _poolCost :: Coin + , _poolMargin :: UnitInterval + , _poolAltAcnt :: Maybe (KeyHash hashAlgo dsignAlgo) + , _poolRAcnt :: RewardAcnt hashAlgo dsignAlgo + , _poolOwners :: Set (KeyHash hashAlgo dsignAlgo) + } deriving (Show, Eq, Ord) + +-- |An account based address for a rewards +newtype RewardAcnt hashAlgo signAlgo = RewardAcnt + { getRwdHK :: StakeObject hashAlgo signAlgo + } deriving (Show, Eq, Ord) + -- |An address for UTxO. data Addr hashAlgo dsignAlgo = AddrVKey @@ -80,13 +104,13 @@ data DCert hashAlgo dsignAlgo -- | A stake key registration certificate. = RegKey (StakeObject hashAlgo dsignAlgo) -- | A stake key deregistration certificate. - | DeRegKey (StakeObject hashAlgo dsignAlgo) --TODO this is actually KeyHash on page 13, is that what we want? + | DeRegKey (StakeObject hashAlgo dsignAlgo) -- | A stake pool registration certificate. | RegPool (PoolParams hashAlgo dsignAlgo) -- | A stake pool retirement certificate. | RetirePool (KeyHash hashAlgo dsignAlgo) Epoch -- | A stake delegation certificate. - | Delegate (Delegation dsignAlgo) + | Delegate (Delegation hashAlgo dsignAlgo) -- | Genesis key delegation certificate | GenesisDelegate (VKeyGenesis dsignAlgo, VKey dsignAlgo) deriving (Show, Eq, Ord) @@ -103,8 +127,6 @@ data TxBody hashAlgo dsignAlgo , _txUpdate :: Update dsignAlgo } deriving (Show, Eq, Ord) -makeLenses ''TxBody - -- |Proof/Witness that a transaction is authorized by the given key holder. data WitVKey hashAlgo dsignAlgo = WitVKey (VKey dsignAlgo) !(Sig dsignAlgo (TxBody hashAlgo dsignAlgo)) @@ -119,18 +141,8 @@ data Tx hashAlgo dsignAlgo Map (ScriptHash hashAlgo dsignAlgo) (MultiSig hashAlgo dsignAlgo) } deriving (Show, Eq, Ord) -makeLenses ''Tx - --- newtype StakePools hashAlgo dsignAlgo = --- StakePools (Map (KeyHash hashAlgo dsignAlgo) Slot) --- deriving (Show, Eq) - --- newtype StakeKeys hashAlgo dsignAlgo = --- StakeKeys (Map (StakeObject hashAlgo dsignAlgo) Slot) --- deriving (Show, Eq) - newtype StakeKeys hashAlgo dsignAlgo = - StakeKeys (Map (KeyHash hashAlgo dsignAlgo) Slot) + StakeKeys (Map (StakeObject hashAlgo dsignAlgo) Slot) deriving (Show, Eq) newtype StakePools hashAlgo dsignAlgo = @@ -287,3 +299,43 @@ instance (Typeable dsignAlgo, HashAlgorithm hashAlgo) encodeListLen 2 <> toCBOR (1 :: Word8) <> toCBOR sc + + +instance (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo) => + ToCBOR (Delegation hashAlgo dsignAlgo) where + toCBOR delegation = + encodeListLen 2 + <> toCBOR (_delegator delegation) + <> toCBOR (_delegatee delegation) + + +instance + (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo) + => ToCBOR (PoolParams hashAlgo dsignAlgo) + where + toCBOR poolParams = + encodeListLen 8 + <> toCBOR (_poolPubKey poolParams) + <> toCBOR (_poolPledge poolParams) + <> toCBOR (_poolPledges poolParams) + <> toCBOR (_poolCost poolParams) + <> toCBOR (_poolMargin poolParams) + <> toCBOR (_poolAltAcnt poolParams) + <> toCBOR (_poolRAcnt poolParams) + <> toCBOR (_poolOwners poolParams) + +instance (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo) + => ToCBOR (RewardAcnt hashAlgo dsignAlgo) where + toCBOR rwdAcnt = + encodeListLen 1 + <> toCBOR (getRwdHK rwdAcnt) + +-- Lenses + +makeLenses ''TxBody + +makeLenses ''Tx + +makeLenses ''Delegation + +makeLenses ''PoolParams diff --git a/shelley/chain-and-ledger/executable-spec/src/UTxO.hs b/shelley/chain-and-ledger/executable-spec/src/UTxO.hs index 43d17604a72..e74b663ca5f 100644 --- a/shelley/chain-and-ledger/executable-spec/src/UTxO.hs +++ b/shelley/chain-and-ledger/executable-spec/src/UTxO.hs @@ -46,9 +46,9 @@ import Keys import PParams (PParams(..)) import Updates (Update) import Tx +import TxData import Delegation.Certificates (StakePools(..), DCert (..), dvalue) -import Delegation.PoolParams (poolPubKey) -- |The unspent transaction outputs. newtype UTxO hashAlgo dsignAlgo From 0815d19e2df5b74dca2ebf63174a9d38278adafe Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Matthias=20G=C3=BCdemann?= Date: Tue, 16 Jul 2019 17:26:52 +0200 Subject: [PATCH 12/15] Use script validation in `DELPL` --- .../executable-spec/src/STS/Delpl.hs | 57 +++++++++++++++++-- 1 file changed, 52 insertions(+), 5 deletions(-) diff --git a/shelley/chain-and-ledger/executable-spec/src/STS/Delpl.hs b/shelley/chain-and-ledger/executable-spec/src/STS/Delpl.hs index bdf15a7506e..e3caa0b393c 100644 --- a/shelley/chain-and-ledger/executable-spec/src/STS/Delpl.hs +++ b/shelley/chain-and-ledger/executable-spec/src/STS/Delpl.hs @@ -9,6 +9,8 @@ module STS.Delpl ) where +import qualified Data.Map.Strict as Map + import Keys import LedgerState import Delegation.Certificates @@ -35,6 +37,9 @@ instance data PredicateFailure (DELPL hashAlgo dsignAlgo) = PoolFailure (PredicateFailure (POOL hashAlgo dsignAlgo)) | DelegFailure (PredicateFailure (DELEG hashAlgo dsignAlgo)) + | ScriptNotInWitnessDELPL + | ScriptHashNotMatchDELPL + | ScriptDoesNotValidateDELPL deriving (Show, Eq) initialRules = [ pure emptyDelegation ] @@ -45,7 +50,7 @@ delplTransition . (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo) => TransitionRule (DELPL hashAlgo dsignAlgo) delplTransition = do - TRC ((slotIx, ptr, pp, _), d, c) <- judgmentContext + TRC ((slotIx, ptr, pp, tx), d, c) <- judgmentContext case c of RegPool _ -> do ps <- @@ -55,22 +60,64 @@ delplTransition = do ps <- trans @(POOL hashAlgo dsignAlgo) $ TRC ((slotIx, ptr, pp), _pstate d, c) pure $ d { _pstate = ps } - RegKey _ -> do + GenesisDelegate _ -> do ds <- trans @(DELEG hashAlgo dsignAlgo) $ TRC ((slotIx, ptr), _dstate d, c) pure $ d { _dstate = ds } - DeRegKey _ -> do + + RegKey (KeyHashStake _) -> do ds <- trans @(DELEG hashAlgo dsignAlgo) $ TRC ((slotIx, ptr), _dstate d, c) pure $ d { _dstate = ds } - Delegate _ -> do + RegKey (ScriptHashStake stakeObj) -> do + let scriptWits = txwitsScripts tx + let validator' = Map.lookup stakeObj scriptWits + case validator' of + Nothing -> do + failBecause ScriptNotInWitnessDELPL + pure d + Just validator -> do + hashScript validator == stakeObj ?! ScriptHashNotMatchDELPL + validateScript validator tx ?! ScriptDoesNotValidateDELPL + ds <- + trans @(DELEG hashAlgo dsignAlgo) $ TRC ((slotIx, ptr), _dstate d, c) + pure $ d { _dstate = ds } + + DeRegKey (KeyHashStake _) -> do ds <- trans @(DELEG hashAlgo dsignAlgo) $ TRC ((slotIx, ptr), _dstate d, c) pure $ d { _dstate = ds } - GenesisDelegate _ -> do + DeRegKey (ScriptHashStake stakeObj) -> do + let scriptWits = txwitsScripts tx + let validator' = Map.lookup stakeObj scriptWits + case validator' of + Nothing -> do + failBecause ScriptNotInWitnessDELPL + pure d + Just validator -> do + hashScript validator == stakeObj ?! ScriptHashNotMatchDELPL + validateScript validator tx ?! ScriptDoesNotValidateDELPL + ds <- + trans @(DELEG hashAlgo dsignAlgo) $ TRC ((slotIx, ptr), _dstate d, c) + pure $ d { _dstate = ds } + + Delegate (Delegation (KeyHashStake _) _) -> do ds <- trans @(DELEG hashAlgo dsignAlgo) $ TRC ((slotIx, ptr), _dstate d, c) pure $ d { _dstate = ds } + Delegate (Delegation (ScriptHashStake stakeObj) _) -> do + let scriptWits = txwitsScripts tx + let validator' = Map.lookup stakeObj scriptWits + case validator' of + Nothing -> do + failBecause ScriptNotInWitnessDELPL + pure d + Just validator -> do + hashScript validator == stakeObj ?! ScriptHashNotMatchDELPL + validateScript validator tx ?! ScriptDoesNotValidateDELPL + ds <- + trans @(DELEG hashAlgo dsignAlgo) $ TRC ((slotIx, ptr), _dstate d, c) + pure $ d { _dstate = ds } instance (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo) From 08158ff51a8ed9f588238267c67ec20fd50142e6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Matthias=20G=C3=BCdemann?= Date: Tue, 16 Jul 2019 18:26:48 +0200 Subject: [PATCH 13/15] Implement `validators` --- .../executable-spec/src/TxData.hs | 3 ++- .../executable-spec/src/UTxO.hs | 21 +++++++++++++++++++ 2 files changed, 23 insertions(+), 1 deletion(-) diff --git a/shelley/chain-and-ledger/executable-spec/src/TxData.hs b/shelley/chain-and-ledger/executable-spec/src/TxData.hs index c3535d3445f..8e2605f9678 100644 --- a/shelley/chain-and-ledger/executable-spec/src/TxData.hs +++ b/shelley/chain-and-ledger/executable-spec/src/TxData.hs @@ -52,7 +52,8 @@ data Addr hashAlgo dsignAlgo { _payHK :: KeyHash hashAlgo dsignAlgo , _stakeHK :: KeyHash hashAlgo dsignAlgo } - | AddrScr + | AddrScr -- TODO generalize to any type of script + -- add `validatorHash` function { _payScr :: ScriptHash hashAlgo dsignAlgo , _stakeScr :: ScriptHash hashAlgo dsignAlgo } diff --git a/shelley/chain-and-ledger/executable-spec/src/UTxO.hs b/shelley/chain-and-ledger/executable-spec/src/UTxO.hs index e74b663ca5f..b8b59bb3641 100644 --- a/shelley/chain-and-ledger/executable-spec/src/UTxO.hs +++ b/shelley/chain-and-ledger/executable-spec/src/UTxO.hs @@ -32,6 +32,7 @@ module UTxO , makeWitnessVKey , makeWitnessesVKey , verifyWitVKey + , validators ) where import Lens.Micro ((^.)) @@ -167,3 +168,23 @@ deposits pc (StakePools stpools) cs = foldl f (Coin 0) cs' txup :: Tx hashAlgo dsignAlgo -> Update dsignAlgo txup (Tx txbody _ _) = _txUpdate txbody + +validators + :: (MultiSignatureScript a hashAlgo dsignAlgo) + => Set (TxIn hashAlgo dsignAlgo) + -> UTxO hashAlgo dsignAlgo + -> Map (ScriptHash hashAlgo dsignAlgo) a + -> Map (TxIn hashAlgo dsignAlgo) a +validators txInputs utxo scripts = + Map.mapMaybe (\(TxOut a _) -> + case a of + AddrScr hs _ -> + (let s = Map.lookup hs scripts in + case s of + Just s' -> + if hs == hashScript s' + then Just s' + else Nothing + Nothing -> Nothing) + _ -> Nothing) txInRestricted + where UTxO txInRestricted = txInputs <| utxo From 081511c6cde798851ce23ad244b14f7411e1e799 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Matthias=20G=C3=BCdemann?= Date: Tue, 16 Jul 2019 21:08:36 +0200 Subject: [PATCH 14/15] Use script validation in `UTXOW` --- .../executable-spec/src/STS/Delpl.hs | 6 ++-- .../executable-spec/src/STS/Utxow.hs | 35 +++++++++++++++++-- .../executable-spec/src/Tx.hs | 13 +++++-- .../executable-spec/src/UTxO.hs | 16 +++++++++ 4 files changed, 61 insertions(+), 9 deletions(-) diff --git a/shelley/chain-and-ledger/executable-spec/src/STS/Delpl.hs b/shelley/chain-and-ledger/executable-spec/src/STS/Delpl.hs index e3caa0b393c..947ed703876 100644 --- a/shelley/chain-and-ledger/executable-spec/src/STS/Delpl.hs +++ b/shelley/chain-and-ledger/executable-spec/src/STS/Delpl.hs @@ -70,7 +70,7 @@ delplTransition = do trans @(DELEG hashAlgo dsignAlgo) $ TRC ((slotIx, ptr), _dstate d, c) pure $ d { _dstate = ds } RegKey (ScriptHashStake stakeObj) -> do - let scriptWits = txwitsScripts tx + let scriptWits = txwitsScript tx let validator' = Map.lookup stakeObj scriptWits case validator' of Nothing -> do @@ -88,7 +88,7 @@ delplTransition = do trans @(DELEG hashAlgo dsignAlgo) $ TRC ((slotIx, ptr), _dstate d, c) pure $ d { _dstate = ds } DeRegKey (ScriptHashStake stakeObj) -> do - let scriptWits = txwitsScripts tx + let scriptWits = txwitsScript tx let validator' = Map.lookup stakeObj scriptWits case validator' of Nothing -> do @@ -106,7 +106,7 @@ delplTransition = do trans @(DELEG hashAlgo dsignAlgo) $ TRC ((slotIx, ptr), _dstate d, c) pure $ d { _dstate = ds } Delegate (Delegation (ScriptHashStake stakeObj) _) -> do - let scriptWits = txwitsScripts tx + let scriptWits = txwitsScript tx let validator' = Map.lookup stakeObj scriptWits case validator' of Nothing -> do diff --git a/shelley/chain-and-ledger/executable-spec/src/STS/Utxow.hs b/shelley/chain-and-ledger/executable-spec/src/STS/Utxow.hs index b110132ba66..caf92650fa1 100644 --- a/shelley/chain-and-ledger/executable-spec/src/STS/Utxow.hs +++ b/shelley/chain-and-ledger/executable-spec/src/STS/Utxow.hs @@ -10,7 +10,9 @@ module STS.Utxow ) where +import Data.Maybe (mapMaybe) import qualified Data.Set as Set +import qualified Data.Map.Strict as Map import Delegation.Certificates import Keys @@ -18,6 +20,8 @@ import LedgerState hiding (dms) import PParams import Slot import Tx +import TxData +import UTxO import Control.State.Transition @@ -43,7 +47,10 @@ instance ) data PredicateFailure (UTXOW hashAlgo dsignAlgo) = InvalidWitnessesUTXOW - | MissingWitnessesUTXOW + | MissingVKeyWitnessesUTXOW + | MissingScriptWitnessesUTXOW + | MissingScriptWitnessesRwdUTXOW + | ScriptWitnessNotValidatingUTXOW | UtxoFailure (PredicateFailure (UTXO hashAlgo dsignAlgo)) deriving (Eq, Show) @@ -69,11 +76,33 @@ utxoWitnessed ) => TransitionRule (UTXOW hashAlgo dsignAlgo) utxoWitnessed = do - TRC ((slot, pp, stakeKeys, stakePools, _dms), u, tx@(Tx _ wits _)) + TRC ((slot, pp, stakeKeys, stakePools, _dms), u, tx@(Tx txbody wits _)) <- judgmentContext verifiedWits tx == Valid ?! InvalidWitnessesUTXOW let witnessKeys = Set.map (\(WitVKey vk _) -> hashKey vk) wits - witsNeeded (_utxo u) tx _dms == witnessKeys ?! MissingWitnessesUTXOW + witsNeeded (_utxo u) tx _dms `Set.isSubsetOf` witnessKeys ?! MissingVKeyWitnessesUTXOW + + -- check multi-signature scripts + let utxo' = _utxo u + let scriptWits = txwitsScript tx + let scriptIns = txinsScript (txins txbody) utxo' + scriptIns == (Map.keysSet $ validators scriptIns utxo' scriptWits) + ?! MissingScriptWitnessesUTXOW + + -- script locked reward accounts + let withdrawals = _wdrls txbody + let addrRwdScr = + Map.keysSet $ Map.filterWithKey (\rwd _ -> + case getRwdHK rwd of + ScriptHashStake _ -> True + _ -> False) withdrawals + let addrRwdScrHash = extractScriptHash $ map getRwdHK $ Set.toList addrRwdScr + all (flip Map.member scriptWits) addrRwdScrHash + ?! MissingScriptWitnessesRwdUTXOW + let scriptValidators = mapMaybe (flip Map.lookup scriptWits) addrRwdScrHash + (all (\(hs, scr) -> hs == hashScript scr && validateScript scr tx) $ + zip addrRwdScrHash scriptValidators) ?! ScriptWitnessNotValidatingUTXOW + trans @(UTXO hashAlgo dsignAlgo) $ TRC ((slot, pp, stakeKeys, stakePools, _dms), u, tx) diff --git a/shelley/chain-and-ledger/executable-spec/src/Tx.hs b/shelley/chain-and-ledger/executable-spec/src/Tx.hs index b4ffbbfa797..99869d0d4b4 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Tx.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Tx.hs @@ -26,8 +26,9 @@ module Tx , validateScript , hashScript , txwitsVKey - , txwitsScripts + , txwitsScript , extractKeyHash + , extractScriptHash ) where @@ -107,13 +108,19 @@ txwitsVKey tx = Map.fromList $ map (\(WitVKey vk sig) -> (vk, sig)) (Set.toList $ _witnessVKeySet tx) -- | Multi-signature script witness accessor function for Transactions -txwitsScripts +txwitsScript :: Tx hashAlgo dsignAlgo -> Map.Map (ScriptHash hashAlgo dsignAlgo) (MultiSig hashAlgo dsignAlgo) -txwitsScripts tx = _witnessMSigMap tx +txwitsScript tx = _witnessMSigMap tx extractKeyHash :: [StakeObject hashAlgo dsignAlgo] -> [KeyHash hashAlgo dsignAlgo] extractKeyHash l = Maybe.catMaybes $ map (\so -> case so of KeyHashStake hk -> Just hk _ -> Nothing) l + +extractScriptHash :: [StakeObject hashAlgo dsignAlgo] -> [ScriptHash hashAlgo dsignAlgo] +extractScriptHash l = + Maybe.catMaybes $ map (\so -> case so of + ScriptHashStake hk -> Just hk + _ -> Nothing) l diff --git a/shelley/chain-and-ledger/executable-spec/src/UTxO.hs b/shelley/chain-and-ledger/executable-spec/src/UTxO.hs index b8b59bb3641..ee0e6901fad 100644 --- a/shelley/chain-and-ledger/executable-spec/src/UTxO.hs +++ b/shelley/chain-and-ledger/executable-spec/src/UTxO.hs @@ -33,6 +33,7 @@ module UTxO , makeWitnessesVKey , verifyWitVKey , validators + , txinsScript ) where import Lens.Micro ((^.)) @@ -169,6 +170,9 @@ deposits pc (StakePools stpools) cs = foldl f (Coin 0) cs' txup :: Tx hashAlgo dsignAlgo -> Update dsignAlgo txup (Tx txbody _ _) = _txUpdate txbody +-- | Computes the set of validator scripts that are necessary to spent the +-- 'txInputs' from the 'utxo' which are locked with scripts. 'scripts' is the +-- set of available scripts which are checkd for matching hashes and validation. validators :: (MultiSignatureScript a hashAlgo dsignAlgo) => Set (TxIn hashAlgo dsignAlgo) @@ -188,3 +192,15 @@ validators txInputs utxo scripts = Nothing -> Nothing) _ -> Nothing) txInRestricted where UTxO txInRestricted = txInputs <| utxo + +-- | Compute the subset of inputs of the set 'txInps' for which each input is +-- locked by a script in the UTxO 'u'. +txinsScript + :: Set (TxIn hashAlgo dsignAlgo) + -> UTxO hashAlgo dsignAlgo + -> Set (TxIn hashAlgo dsignAlgo) +txinsScript txInps (UTxO u) = + txInps `Set.intersection` + (Map.keysSet $ Map.filter (\(TxOut a _) -> case a of + AddrScr _ _ -> True + _ -> False) u) 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 15/15] 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 }