From f8b98097ea1be8f6c217606b6c05afd36b9befff Mon Sep 17 00:00:00 2001 From: drsk <827698+drsk0@users.noreply.github.com> Date: Mon, 3 Nov 2025 15:19:48 +0100 Subject: [PATCH 01/26] COR-1980: update SendBlockItemRequest::get_v0_format (#1463) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * COR-1980: update SendBlockItemRequest::get_v0_format This adds the new implementations for - BlockItem::AccountTransactionV1 - BlockItem::RawBlockItem * update CHANGELOG * Update concordium-node/src/grpc2.rs Co-authored-by: Søren Bruus Zeppelin * Update concordium-node/src/grpc2.rs Co-authored-by: Søren Bruus Zeppelin * fix compilation * simplify `TryFrom * concordium-base: update submodule * add stub for missing transaction verifier implementation * format * fix Versioned::from(0) This doesn't compile unfortunately. --------- Co-authored-by: drsk Co-authored-by: Søren Bruus Zeppelin Co-authored-by: Thomas Dinsdale-Young --- CHANGELOG.md | 1 + concordium-base | 2 +- .../GlobalState/Persistent/TreeState.hs | 2 + .../GlobalState/TransactionTable.hs | 4 ++ .../Concordium/KonsensusV1/Transactions.hs | 2 + .../KonsensusV1/TreeState/Implementation.hs | 2 + .../src/Concordium/Scheduler.hs | 4 ++ .../src/Concordium/Scheduler/Environment.hs | 2 + .../src/Concordium/Scheduler/Runner.hs | 1 + .../src/Concordium/Skov/Update.hs | 5 ++ .../src/Concordium/TransactionVerification.hs | 2 + .../ReceiveTransactionsTest.hs | 2 + concordium-node/Cargo.lock | 4 +- concordium-node/src/grpc2.rs | 70 +++++++++++++++++++ 14 files changed, 100 insertions(+), 3 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 4ac990d901..6e518a405d 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -8,6 +8,7 @@ the token module state. They are still required by the current token module implementation, and initialization without the parameters set will be rejected, so there are no observable changes to PLT behaviour. - Fixed the `build_catchup_url` in the Ubuntu build release pipeline. +- Extended the GRPC API to support submitting sponsored transactions. ## 9.0.7 diff --git a/concordium-base b/concordium-base index 73e1dad0e4..15a1ddc0cf 160000 --- a/concordium-base +++ b/concordium-base @@ -1 +1 @@ -Subproject commit 73e1dad0e423a6830d704d15adf732191a5f73df +Subproject commit 15a1ddc0cfde23a7253ad66c03f9187c976550bc diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/TreeState.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/TreeState.hs index bd373ac419..3570cb781f 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/TreeState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/TreeState.hs @@ -976,6 +976,8 @@ instance . at' uty ?= (nfcu & (nfcuMap . at' sn .~ Nothing) & (nfcuNextSequenceNumber .~ sn + 1)) return ss + finTrans WithMetadata{wmdData = ExtendedTransaction{}} = + error "TODO(SP0-10): transaction verifier support for sponsored transactions" deleteAndFinalizeStatus txHash = do status <- preuse (skovPersistentData . transactionTable . ttHashMap . ix txHash . _2) diff --git a/concordium-consensus/src/Concordium/GlobalState/TransactionTable.hs b/concordium-consensus/src/Concordium/GlobalState/TransactionTable.hs index 6f6a5d587c..6cb3062863 100644 --- a/concordium-consensus/src/Concordium/GlobalState/TransactionTable.hs +++ b/concordium-consensus/src/Concordium/GlobalState/TransactionTable.hs @@ -414,6 +414,8 @@ forwardPTT trs ptt0 = foldl' forward1 ptt0 trs assert (low == updateSeqNumber (uiHeader biUpdate)) $ assert (low <= high) $ if low == high then Nothing else Just (low + 1, high) + forward1 _ptt WithMetadata{wmdData = ExtendedTransaction{}} = + error "TODO(SPO-10): transaction verifier support for sponsored transactions" -- | Update the pending transaction table by considering the supplied 'BlockItem's -- pending again. The 'BlockItem's must be ordered correctly with respect @@ -439,6 +441,8 @@ reversePTT trs ptt0 = foldr reverse1 ptt0 trs upd (Just (low, high)) = assert (low == sn + 1) $ Just (low - 1, high) + reverse1 WithMetadata{wmdData = ExtendedTransaction{}} = + error "TODO(SPO-10): transaction verifier support for sponsored transactions" -- | Returns the next available account nonce for the -- provided account address from the perspective of the 'TransactionTable'. diff --git a/concordium-consensus/src/Concordium/KonsensusV1/Transactions.hs b/concordium-consensus/src/Concordium/KonsensusV1/Transactions.hs index 31e1c9e45a..51d20bac1f 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/Transactions.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/Transactions.hs @@ -136,6 +136,8 @@ addPendingTransaction bi = do when (nextSN <= updateSeqNumber (uiHeader cu)) $ do Impl.pendingTransactionTable %=! TT.addPendingUpdate nextSN cu Impl.purgeTransactionTable False =<< currentTime + ExtendedTransaction _tx -> + error "TODO(SP0-10): transaction verifier support for sponsored transactions" where txHash = getHash bi diff --git a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/Implementation.hs b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/Implementation.hs index e0d26eb09f..3df9af5804 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/Implementation.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/Implementation.hs @@ -896,6 +896,8 @@ finalizeTransactions = mapM_ removeTrans . TT.ttNonFinalizedChainUpdates . at' uty ?=! (nfcu & (TT.nfcuMap . at' sn .~ Nothing) & (TT.nfcuNextSequenceNumber .~ sn + 1)) + removeTrans WithMetadata{wmdData = ExtendedTransaction{}} = + error "TODO(SP0-10): transaction verifier support for sponsored transactions" -- | Mark a live transaction as committed in a particular block. -- This does nothing if the transaction is not live. diff --git a/concordium-consensus/src/Concordium/Scheduler.hs b/concordium-consensus/src/Concordium/Scheduler.hs index d32271d339..d252981735 100644 --- a/concordium-consensus/src/Concordium/Scheduler.hs +++ b/concordium-consensus/src/Concordium/Scheduler.hs @@ -3409,6 +3409,8 @@ runTransactions = go [] predispatch (WithMetadata{wmdData = NormalTransaction tr, ..}, verRes) = dispatch (WithMetadata{wmdData = tr, ..}, verRes) predispatch (WithMetadata{wmdData = CredentialDeployment cred, ..}, verRes) = handleDeployCredential (WithMetadata{wmdData = cred, ..}, verRes) wmdHash predispatch (WithMetadata{wmdData = ChainUpdate cu, ..}, verRes) = Just <$> handleChainUpdate (WithMetadata{wmdData = cu, ..}, verRes) + predispatch (WithMetadata{wmdData = ExtendedTransaction _tr}, _verRes) = + error "TODO(SPO-10): transaction verifier support for sponsored transactions" -- | Execute transactions in sequence. Like 'runTransactions' but only for side-effects on global state. -- @@ -3444,3 +3446,5 @@ execTransactions = go predispatch (WithMetadata{wmdData = NormalTransaction tr, ..}, verRes) = dispatch (WithMetadata{wmdData = tr, ..}, verRes) predispatch (WithMetadata{wmdData = CredentialDeployment cred, ..}, verRes) = handleDeployCredential (WithMetadata{wmdData = cred, ..}, verRes) wmdHash predispatch (WithMetadata{wmdData = ChainUpdate cu, ..}, verRes) = Just <$> handleChainUpdate (WithMetadata{wmdData = cu, ..}, verRes) + predispatch (WithMetadata{wmdData = ExtendedTransaction _tr}, _verRes) = + error "TODO(SPO-10): transaction verifier support for sponsored transactions" diff --git a/concordium-consensus/src/Concordium/Scheduler/Environment.hs b/concordium-consensus/src/Concordium/Scheduler/Environment.hs index 0510e69e79..ab9cd68786 100644 --- a/concordium-consensus/src/Concordium/Scheduler/Environment.hs +++ b/concordium-consensus/src/Concordium/Scheduler/Environment.hs @@ -1469,6 +1469,8 @@ logInvalidBlockItem WithMetadata{wmdData = CredentialDeployment cred} fk = logEvent Scheduler LLWarning $ "Credential with registration id " ++ (show . ID.credId . credential $ cred) ++ " was invalid with reason " ++ show fk logInvalidBlockItem WithMetadata{wmdData = ChainUpdate{}, ..} fk = logEvent Scheduler LLWarning $ "Chain update with hash " ++ show wmdHash ++ " was invalid with reason: " ++ show fk +logInvalidBlockItem WithMetadata{wmdData = ExtendedTransaction{}} _fk = + error "TODO(SPO-10): transaction verifier support for sponsored transactions" {-# INLINE logInvalidTransaction #-} logInvalidTransaction :: (SchedulerMonad m) => TVer.TransactionWithStatus -> FailureKind -> m () diff --git a/concordium-consensus/src/Concordium/Scheduler/Runner.hs b/concordium-consensus/src/Concordium/Scheduler/Runner.hs index 4525cf8a06..fa5c27c016 100644 --- a/concordium-consensus/src/Concordium/Scheduler/Runner.hs +++ b/concordium-consensus/src/Concordium/Scheduler/Runner.hs @@ -174,6 +174,7 @@ processUngroupedBlockItems inpt = do txMap (Types.NormalTransaction x) = Types.TGAccountTransactions [(Types.fromAccountTransaction 0 x, Nothing)] txMap (Types.CredentialDeployment x) = Types.TGCredentialDeployment (Types.addMetadata Types.CredentialDeployment 0 x, Nothing) txMap (Types.ChainUpdate x) = Types.TGUpdateInstructions [(Types.addMetadata Types.ChainUpdate 0 x, Nothing)] + txMap (Types.ExtendedTransaction _x) = error "TODO(SPO-10): transaction verifier support for sponsored transactions" -- | For testing purposes: process transactions in the groups in which they came -- The arrival time of all transactions is taken to be 0. diff --git a/concordium-consensus/src/Concordium/Skov/Update.hs b/concordium-consensus/src/Concordium/Skov/Update.hs index 0dbc8755fb..ad58d5fefd 100644 --- a/concordium-consensus/src/Concordium/Skov/Update.hs +++ b/concordium-consensus/src/Concordium/Skov/Update.hs @@ -834,6 +834,8 @@ doAddPreverifiedTransaction blockItem okRes = do when (nextSN <= updateSeqNumber (uiHeader cu)) $ putPendingTransactions $! addPendingUpdate nextSN cu ptrs + ExtendedTransaction _tx -> + error "TODO(SP0-10): transaction verifier support for sponsored transactions" purgeTransactionTable False =<< currentTime return $! transactionVerificationResultToUpdateResult verRes Duplicate{} -> return ResultDuplicate @@ -900,6 +902,9 @@ doReceiveTransactionInternal origin verifyBs tr ts slot = do when (nextSN <= updateSeqNumber (uiHeader cu)) $ putPendingTransactions $! addPendingUpdate nextSN cu ptrs + ExtendedTransaction _tx -> + error "TODO(SP0-10): transaction verifier support for sponsored transactions" + -- The actual verification result here is only used if the transaction was received individually. -- If the transaction was received as part of a block we don't use the result for anything. return (Just (bi, Just verRes), transactionVerificationResultToUpdateResult verRes) diff --git a/concordium-consensus/src/Concordium/TransactionVerification.hs b/concordium-consensus/src/Concordium/TransactionVerification.hs index c76be2df94..e801087e65 100644 --- a/concordium-consensus/src/Concordium/TransactionVerification.hs +++ b/concordium-consensus/src/Concordium/TransactionVerification.hs @@ -215,6 +215,8 @@ verify now bi = do verifyChainUpdate ui Tx.WithMetadata{wmdData = Tx.NormalTransaction tx} -> do verifyNormalTransaction tx + Tx.WithMetadata{wmdData = Tx.ExtendedTransaction _tx} -> + error "TODO(SPO-10): transaction verifier support for sponsored transactions" -- | Verifies a 'CredentialDeployment' transaction. -- diff --git a/concordium-consensus/tests/consensus/ConcordiumTests/ReceiveTransactionsTest.hs b/concordium-consensus/tests/consensus/ConcordiumTests/ReceiveTransactionsTest.hs index eb960ecc68..503ac8f55f 100644 --- a/concordium-consensus/tests/consensus/ConcordiumTests/ReceiveTransactionsTest.hs +++ b/concordium-consensus/tests/consensus/ConcordiumTests/ReceiveTransactionsTest.hs @@ -389,6 +389,8 @@ toBlockItem now bbi = CredentialDeployment cred -> credentialDeployment $ addMetadata (\x -> CredentialDeployment{biCred = x}) now cred ChainUpdate ui -> chainUpdate $ addMetadata (\x -> ChainUpdate{biUpdate = x}) now ui NormalTransaction tx -> normalTransaction $ addMetadata (\x -> NormalTransaction{biTransaction = x}) now tx + ExtendedTransaction _tx -> + error "TODO(SP0-10): transaction verifier support for sponsored transactions" duplicateRegId :: CredentialRegistrationID duplicateRegId = credId (makeTestCredentialFromSeed 1) diff --git a/concordium-node/Cargo.lock b/concordium-node/Cargo.lock index 7a9d4002ab..8537e6e368 100644 --- a/concordium-node/Cargo.lock +++ b/concordium-node/Cargo.lock @@ -757,7 +757,7 @@ dependencies = [ [[package]] name = "concordium_base" -version = "8.0.0" +version = "8.0.0-alpha.3" dependencies = [ "aes", "anyhow", @@ -805,7 +805,7 @@ dependencies = [ [[package]] name = "concordium_base_derive" -version = "1.1.0" +version = "1.1.0-alpha.3" dependencies = [ "convert_case 0.8.0", "darling", diff --git a/concordium-node/src/grpc2.rs b/concordium-node/src/grpc2.rs index 477738b078..1e22e61322 100644 --- a/concordium-node/src/grpc2.rs +++ b/concordium-node/src/grpc2.rs @@ -443,6 +443,39 @@ pub mod types { } } + impl TryFrom + for ( + concordium_base::transactions::TransactionHeaderV1, + concordium_base::transactions::EncodedPayload, + ) + { + type Error = tonic::Status; + + fn try_from(value: PreAccountTransactionV1) -> Result { + let header = value.header.require()?; + let payload = value.payload.require()?; + let sender = header.sender.require()?.try_into()?; + let nonce = header.sequence_number.require()?.into(); + let energy_amount = header.energy_amount.require()?.into(); + let expiry = header.expiry.require()?.into(); + let payload: concordium_base::transactions::EncodedPayload = payload.try_into()?; + let payload_size = payload.size(); + let sponsor = match header.sponsor { + Some(s) => Some(s.try_into()?), + None => None, + }; + let header = concordium_base::transactions::TransactionHeaderV1 { + sender, + nonce, + energy_amount, + payload_size, + expiry, + sponsor, + }; + Ok((header, payload)) + } + } + impl TryFrom for concordium_base::common::types::Signature { type Error = tonic::Status; @@ -484,6 +517,20 @@ pub mod types { } } + impl TryFrom + for concordium_base::common::types::TransactionSignaturesV1 + { + type Error = tonic::Status; + fn try_from(value: AccountTransactionV1Signatures) -> Result { + let sender_signatures = value.sender_signatures.require()?.try_into()?; + let sponsor_signatures = value.sponsor_signatures.map(|s| s.try_into()).transpose()?; + Ok(Self { + sender: sender_signatures, + sponsor: sponsor_signatures, + }) + } + } + impl TryFrom for concordium_base::updates::UpdateInstructionSignature { type Error = tonic::Status; @@ -575,6 +622,29 @@ pub mod types { signatures.serial(&mut data); Ok(data) } + send_block_item_request::BlockItem::AccountTransactionV1(atv1) => { + let patv1 = PreAccountTransactionV1 { + header: atv1.header, + payload: atv1.payload, + }; + let (header, payload) = patv1.try_into()?; + let signatures = atv1.signatures.require()?.try_into()?; + let atv1 = concordium_base::transactions::AccountTransactionV1 { + signatures, + header, + payload, + }; + Ok(concordium_base::common::to_bytes(&Versioned::new( + 0.into(), + concordium_base::transactions::BlockItem::AccountTransactionV1(atv1), + ))) + } + send_block_item_request::BlockItem::RawBlockItem(bytes) => { + let mut data = concordium_base::common::to_bytes(&Versioned::new(0.into(), ())); + // Add raw bytes in a separate step to avoid encoding the length + data.extend_from_slice(&bytes); + Ok(data) + } } } } From c13dbad1aa5d598abcbc7f549e886d9bcc7d0a62 Mon Sep 17 00:00:00 2001 From: Thomas Dinsdale-Young Date: Tue, 11 Nov 2025 16:08:33 +0100 Subject: [PATCH 02/26] Add transaction verification results for sponsored transactions. --- concordium-consensus/src/Concordium/Scheduler.hs | 1 + .../src/Concordium/TransactionVerification.hs | 16 ++++++++++++++-- 2 files changed, 15 insertions(+), 2 deletions(-) diff --git a/concordium-consensus/src/Concordium/Scheduler.hs b/concordium-consensus/src/Concordium/Scheduler.hs index d252981735..6ce6e93534 100644 --- a/concordium-consensus/src/Concordium/Scheduler.hs +++ b/concordium-consensus/src/Concordium/Scheduler.hs @@ -200,6 +200,7 @@ checkTransactionVerificationResult (TVer.MaybeOk (TVer.NormalTransactionInvalidN checkTransactionVerificationResult (TVer.MaybeOk TVer.NormalTransactionInvalidSignatures) = Left IncorrectSignature checkTransactionVerificationResult (TVer.MaybeOk TVer.NormalTransactionInsufficientFunds) = Left InsufficientFunds checkTransactionVerificationResult (TVer.MaybeOk TVer.NormalTransactionEnergyExceeded) = Left ExceedsMaxBlockEnergy +checkTransactionVerificationResult (TVer.MaybeOk (TVer.SponsoredTransactionInvalidSponsor aaddr)) = Left $ UnknownAccount aaddr -- 'NotOk' mappings checkTransactionVerificationResult (TVer.NotOk (TVer.CredentialDeploymentDuplicateAccountRegistrationID regId)) = Left $ DuplicateAccountRegistrationID regId checkTransactionVerificationResult (TVer.NotOk TVer.CredentialDeploymentInvalidSignatures) = Left AccountCredentialInvalid diff --git a/concordium-consensus/src/Concordium/TransactionVerification.hs b/concordium-consensus/src/Concordium/TransactionVerification.hs index e801087e65..ad4227507d 100644 --- a/concordium-consensus/src/Concordium/TransactionVerification.hs +++ b/concordium-consensus/src/Concordium/TransactionVerification.hs @@ -72,6 +72,15 @@ data OkResult { keysHash :: !Sha256.Hash, nonce :: !Types.Nonce } + | -- | The sponsored transaction passed verification. + -- The result contains the hash of the keys of the sender and of the sponsor and the transaction nonce. + -- These can be used to short-circuit signature verification when executing the transaction. + -- If the sender or sponsor keys have changed for the account then the corresponding signature(s) have to be verified again. + SponsoredTransactionSuccess + { senderKeysHash :: !Sha256.Hash, + sponsorKeysHash :: !Sha256.Hash, + nonce :: !Types.Nonce + } | -- | At start-up, the transaction was taken from a block that has already been verified, so -- we trust that it was verified correctly, but do not have the keys used to verify it. TrustedSuccess @@ -102,8 +111,8 @@ data MaybeOkResult -- The result contains the next nonce. -- Reason for 'MaybeOk': the nonce could be valid at a later point in time. NormalTransactionInvalidNonce !Types.Nonce - | -- | The sender does not have enough funds to cover the transfer. - -- Reason for 'MaybeOk': the sender could have enough funds at a later point in time. + | -- | The sender (or sponsor) does not have enough funds to cover the transfer. + -- Reason for 'MaybeOk': the sender (or sponsor) could have enough funds at a later point in time. NormalTransactionInsufficientFunds | -- | The 'NormalTransaction' contained invalid signatures. -- Reason for 'MaybeOk': the sender could've changed account information at a later point in time. @@ -114,6 +123,9 @@ data MaybeOkResult -- This is treated as a 'MaybeOk' for simplicity also for older protocol versions as the transaction will -- be rejected when executed anyhow if it is surpassing the maximum block energy limit. NormalTransactionEnergyExceeded + | -- | The sponsored transaction contained an invalid sponsor. + -- Reason for 'MaybeOk': the sponsor could exist at a later point in time. + SponsoredTransactionInvalidSponsor !Types.AccountAddress deriving (Eq, Show, Ord) -- | Verification results which always should result in a transaction being rejected. From d6e50c4f1eb55ce94ec6dbfed671a687ae0092cb Mon Sep 17 00:00:00 2001 From: Thomas Dinsdale-Young Date: Tue, 11 Nov 2025 16:24:36 +0100 Subject: [PATCH 03/26] Docs --- .../src/Concordium/TransactionVerification.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/concordium-consensus/src/Concordium/TransactionVerification.hs b/concordium-consensus/src/Concordium/TransactionVerification.hs index ad4227507d..a100287123 100644 --- a/concordium-consensus/src/Concordium/TransactionVerification.hs +++ b/concordium-consensus/src/Concordium/TransactionVerification.hs @@ -114,8 +114,8 @@ data MaybeOkResult | -- | The sender (or sponsor) does not have enough funds to cover the transfer. -- Reason for 'MaybeOk': the sender (or sponsor) could have enough funds at a later point in time. NormalTransactionInsufficientFunds - | -- | The 'NormalTransaction' contained invalid signatures. - -- Reason for 'MaybeOk': the sender could've changed account information at a later point in time. + | -- | The 'NormalTransaction' (or sponsored) contained invalid signatures. + -- Reason for 'MaybeOk': the sender/sponsor could've changed account information at a later point in time. NormalTransactionInvalidSignatures | -- | The energy requirement of the transaction exceeds the maximum allowed for a block. -- P6 makes the maxBlockEnergy configurable as a chain parameter, so it could be valid in a future block where From 4251489309ff20fb30c326d7a5f3684988a6828b Mon Sep 17 00:00:00 2001 From: Thomas Dinsdale-Young Date: Tue, 11 Nov 2025 17:08:05 +0100 Subject: [PATCH 04/26] Naming --- concordium-consensus/src/Concordium/TransactionVerification.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/concordium-consensus/src/Concordium/TransactionVerification.hs b/concordium-consensus/src/Concordium/TransactionVerification.hs index a100287123..156ae572de 100644 --- a/concordium-consensus/src/Concordium/TransactionVerification.hs +++ b/concordium-consensus/src/Concordium/TransactionVerification.hs @@ -125,7 +125,7 @@ data MaybeOkResult NormalTransactionEnergyExceeded | -- | The sponsored transaction contained an invalid sponsor. -- Reason for 'MaybeOk': the sponsor could exist at a later point in time. - SponsoredTransactionInvalidSponsor !Types.AccountAddress + ExtendedTransactionInvalidSponsor !Types.AccountAddress deriving (Eq, Show, Ord) -- | Verification results which always should result in a transaction being rejected. From 9eff3583f3af56e1d23e4e7dee595fd6a4d0c540 Mon Sep 17 00:00:00 2001 From: Thomas Dinsdale-Young Date: Wed, 12 Nov 2025 14:04:26 +0100 Subject: [PATCH 05/26] Additional results and handling. --- concordium-base | 2 +- .../src-lib/Concordium/External.hs | 12 +++++++++++- concordium-consensus/src/Concordium/Scheduler.hs | 4 +++- concordium-consensus/src/Concordium/Skov/Monad.hs | 9 +++++++++ .../src/Concordium/TransactionVerification.hs | 4 ++++ concordium-node/src/consensus_ffi/helpers.rs | 14 +++++++++++++- 6 files changed, 41 insertions(+), 4 deletions(-) diff --git a/concordium-base b/concordium-base index 15a1ddc0cf..73e0b49530 160000 --- a/concordium-base +++ b/concordium-base @@ -1 +1 @@ -Subproject commit 15a1ddc0cfde23a7253ad66c03f9187c976550bc +Subproject commit 73e0b49530ea0769f0cce970c79b6d15b1e967f6 diff --git a/concordium-consensus/src-lib/Concordium/External.hs b/concordium-consensus/src-lib/Concordium/External.hs index ef0ff94fbb..711576b429 100644 --- a/concordium-consensus/src-lib/Concordium/External.hs +++ b/concordium-consensus/src-lib/Concordium/External.hs @@ -757,6 +757,12 @@ stopBaker cptr = mask_ $ do -- +-------+---------------------------------------------+-----------------------------------------------------------------------------------------------+----------+ -- | 32 | ResultConsensusFailure | The consensus has thrown an exception and entered an unrecoverable state. | No | -- +-------+---------------------------------------------+-----------------------------------------------------------------------------------------------+----------+ +-- | 33 | ResultNonexistingSponsorAccount | No account corresponding to the transaction's sponsor exists. | No | +-- +-------+---------------------------------------------+-----------------------------------------------------------------------------------------------+----------+ +-- | 34 | ResultMissingSponsorAccount | The transaction includes a sponsor signature but no sponsor account. | No | +-- +-------+---------------------------------------------+-----------------------------------------------------------------------------------------------+----------+ +-- | 35 | ResultMissingSponsorSignature | The transaction includes a sponsor account but no sponsor signature. | No | +-- +-------+---------------------------------------------+-----------------------------------------------------------------------------------------------+----------+ type ReceiveResult = Int64 -- | Convert an 'UpdateResult' to the corresponding 'ReceiveResult' value. @@ -794,6 +800,9 @@ toReceiveResult ResultEnergyExceeded = 29 toReceiveResult ResultInsufficientFunds = 30 toReceiveResult ResultDoubleSign = 31 toReceiveResult ResultConsensusFailure = 32 +toReceiveResult ResultNonexistingSponsorAccount = 33 +toReceiveResult ResultMissingSponsorAccount = 34 +toReceiveResult ResultMissingSponsorSignature = 35 -- | Handle receipt of a block. -- The possible return codes are @ResultSuccess@, @ResultSerializationFail@, @@ -891,7 +900,8 @@ receiveFinalizationRecord bptr genIndex msg msgLen = do -- @ResultCredentialDeploymentInvalidIP@, @ResultCredentialDeploymentInvalidAR@, -- @ResultCredentialDeploymentExpired@, @ResultChainUpdateInvalidSequenceNumber@, -- @ResultChainUpdateInvalidEffectiveTime@, @ResultChainUpdateInvalidSignatures@, --- @ResultEnergyExceeded@. +-- @ResultEnergyExceeded@, @ResultNonexistingSponsorAccount@, +-- @ResultMissingSponsorAccount@, @ResultMissingSponsorSignature@. -- Additionally @ResultConsensusFailure@ is returned if an exception occurs. receiveTransaction :: StablePtr ConsensusRunner -> CString -> Int64 -> Ptr Word8 -> IO ReceiveResult receiveTransaction bptr transactionData transactionLen outPtr = do diff --git a/concordium-consensus/src/Concordium/Scheduler.hs b/concordium-consensus/src/Concordium/Scheduler.hs index 6ce6e93534..8250f25cef 100644 --- a/concordium-consensus/src/Concordium/Scheduler.hs +++ b/concordium-consensus/src/Concordium/Scheduler.hs @@ -200,7 +200,7 @@ checkTransactionVerificationResult (TVer.MaybeOk (TVer.NormalTransactionInvalidN checkTransactionVerificationResult (TVer.MaybeOk TVer.NormalTransactionInvalidSignatures) = Left IncorrectSignature checkTransactionVerificationResult (TVer.MaybeOk TVer.NormalTransactionInsufficientFunds) = Left InsufficientFunds checkTransactionVerificationResult (TVer.MaybeOk TVer.NormalTransactionEnergyExceeded) = Left ExceedsMaxBlockEnergy -checkTransactionVerificationResult (TVer.MaybeOk (TVer.SponsoredTransactionInvalidSponsor aaddr)) = Left $ UnknownAccount aaddr +checkTransactionVerificationResult (TVer.MaybeOk (TVer.ExtendedTransactionInvalidSponsor aaddr)) = Left $ UnknownAccount aaddr -- 'NotOk' mappings checkTransactionVerificationResult (TVer.NotOk (TVer.CredentialDeploymentDuplicateAccountRegistrationID regId)) = Left $ DuplicateAccountRegistrationID regId checkTransactionVerificationResult (TVer.NotOk TVer.CredentialDeploymentInvalidSignatures) = Left AccountCredentialInvalid @@ -212,6 +212,8 @@ checkTransactionVerificationResult (TVer.NotOk (TVer.NormalTransactionDuplicateN checkTransactionVerificationResult (TVer.NotOk TVer.Expired) = Left ExpiredTransaction checkTransactionVerificationResult (TVer.NotOk TVer.InvalidPayloadSize) = Left InvalidPayloadSize checkTransactionVerificationResult (TVer.NotOk TVer.ChainUpdateEffectiveTimeNonZeroForCreatePLT) = Left InvalidUpdateTime +checkTransactionVerificationResult (TVer.NotOk TVer.SponsoredTransactionMissingSponsor) = Left MissingSponsorAccount +checkTransactionVerificationResult (TVer.NotOk TVer.SponsoredTransactionMissingSponsorSignature) = Left MissingSponsorSignature -- | Execute a transaction on the current block state, charging valid accounts -- for the resulting energy cost. diff --git a/concordium-consensus/src/Concordium/Skov/Monad.hs b/concordium-consensus/src/Concordium/Skov/Monad.hs index 0f1e1b900e..232a29303f 100644 --- a/concordium-consensus/src/Concordium/Skov/Monad.hs +++ b/concordium-consensus/src/Concordium/Skov/Monad.hs @@ -113,6 +113,12 @@ data UpdateResult ResultDoubleSign | -- | The consensus has thrown an exception and entered an unrecoverable state. ResultConsensusFailure + | -- | No account corresponding to the transaction's sponsor exists. + ResultNonexistingSponsorAccount + | -- | The transaction includes a sponsor signature but no sponsor account. + ResultMissingSponsorAccount + | -- | The transaction includes a sponsor account but no sponsor signature. + ResultMissingSponsorSignature deriving (Eq, Show) -- | Maps a 'TV.VerificationResult' to the corresponding 'UpdateResult' type. @@ -130,6 +136,7 @@ transactionVerificationResultToUpdateResult (TV.MaybeOk (TV.NormalTransactionInv transactionVerificationResultToUpdateResult (TV.MaybeOk TV.NormalTransactionInvalidSignatures) = ResultVerificationFailed transactionVerificationResultToUpdateResult (TV.MaybeOk (TV.NormalTransactionInvalidNonce _)) = ResultNonceTooLarge transactionVerificationResultToUpdateResult (TV.MaybeOk TV.NormalTransactionEnergyExceeded) = ResultEnergyExceeded +transactionVerificationResultToUpdateResult (TV.MaybeOk (TV.ExtendedTransactionInvalidSponsor _)) = ResultNonexistingSponsorAccount -- 'NotOk' mappings transactionVerificationResultToUpdateResult (TV.NotOk (TV.CredentialDeploymentDuplicateAccountRegistrationID _)) = ResultDuplicateAccountRegistrationID transactionVerificationResultToUpdateResult (TV.NotOk TV.CredentialDeploymentInvalidSignatures) = ResultCredentialDeploymentInvalidSignatures @@ -141,6 +148,8 @@ transactionVerificationResultToUpdateResult (TV.NotOk (TV.NormalTransactionDupli transactionVerificationResultToUpdateResult (TV.NotOk TV.Expired) = ResultStale transactionVerificationResultToUpdateResult (TV.NotOk TV.InvalidPayloadSize) = ResultSerializationFail transactionVerificationResultToUpdateResult (TV.NotOk TV.ChainUpdateEffectiveTimeNonZeroForCreatePLT) = ResultChainUpdateInvalidEffectiveTime +transactionVerificationResultToUpdateResult (TV.NotOk TV.SponsoredTransactionMissingSponsor) = ResultSerializationFail +transactionVerificationResultToUpdateResult (TV.NotOk TV.SponsoredTransactionMissingSponsorSignature) = ResultVerificationFailed class ( Monad m, diff --git a/concordium-consensus/src/Concordium/TransactionVerification.hs b/concordium-consensus/src/Concordium/TransactionVerification.hs index 156ae572de..e4befe22f1 100644 --- a/concordium-consensus/src/Concordium/TransactionVerification.hs +++ b/concordium-consensus/src/Concordium/TransactionVerification.hs @@ -156,6 +156,10 @@ data NotOkResult Expired | -- | Transaction payload size exceeds protocol limit. InvalidPayloadSize + | -- | The transaction has a sponsor signature, but the sponsor is not specified in the header. + SponsoredTransactionMissingSponsor + | -- | The transaction has a sponsor specified in the header, but no sponsor signature. + SponsoredTransactionMissingSponsorSignature deriving (Eq, Show, Ord) -- | Type which can verify transactions in a monadic context. diff --git a/concordium-node/src/consensus_ffi/helpers.rs b/concordium-node/src/consensus_ffi/helpers.rs index f1bc5a259c..dfdf38f5b5 100644 --- a/concordium-node/src/consensus_ffi/helpers.rs +++ b/concordium-node/src/consensus_ffi/helpers.rs @@ -192,6 +192,12 @@ pub enum ConsensusFfiResponse { DoubleSign, #[error("Consensus entered an unrecoverable state")] ConsensusFailure, + #[error("Sponsor account does not exist")] + NonexistingSponsorAccount, + #[error("Sponsor account is missing")] + MissingSponsorAccount, + #[error("Sponsor signature is missing")] + MissingSponsorSignature, } impl ConsensusFfiResponse { @@ -268,7 +274,10 @@ impl ConsensusFfiResponse { | MissingImportFile | ContinueCatchUp | DoubleSign - | ConsensusFailure => false, + | ConsensusFailure + | NonexistingSponsorAccount + | MissingSponsorAccount + | MissingSponsorSignature => false, PendingBlock => packet_type != PacketType::Block, Success | PendingFinalization | Asynchronous => true, } @@ -352,6 +361,9 @@ impl TryFrom for ConsensusFfiResponse { 30 => Ok(InsufficientFunds), 31 => Ok(DoubleSign), 32 => Ok(ConsensusFailure), + 33 => Ok(NonexistingSponsorAccount), + 34 => Ok(MissingSponsorAccount), + 35 => Ok(MissingSponsorSignature), _ => Err(ConsensusFfiResponseConversionError { unknown_code: value, }), From 188d15d70a2ab83448f22d4d1203b00b9dd3e957 Mon Sep 17 00:00:00 2001 From: Thomas Dinsdale-Young Date: Wed, 12 Nov 2025 14:13:28 +0100 Subject: [PATCH 06/26] Review comment. --- .../src/Concordium/TransactionVerification.hs | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/concordium-consensus/src/Concordium/TransactionVerification.hs b/concordium-consensus/src/Concordium/TransactionVerification.hs index e4befe22f1..e6ebf17ef0 100644 --- a/concordium-consensus/src/Concordium/TransactionVerification.hs +++ b/concordium-consensus/src/Concordium/TransactionVerification.hs @@ -15,6 +15,7 @@ import qualified Concordium.ID.IdentityProvider as IP import qualified Concordium.ID.Types as ID import qualified Concordium.Types as Types import Concordium.Types.HashableTo (getHash) +import Concordium.Types.Option import qualified Concordium.Types.Parameters as Params import qualified Concordium.Types.Transactions as Tx import Concordium.Types.Updates (UpdateSequenceNumber) @@ -72,13 +73,13 @@ data OkResult { keysHash :: !Sha256.Hash, nonce :: !Types.Nonce } - | -- | The sponsored transaction passed verification. - -- The result contains the hash of the keys of the sender and of the sponsor and the transaction nonce. + | -- | The extended transaction passed verification. + -- The result contains the hash of the keys of the sender and of the sponsor (if any), and the transaction nonce. -- These can be used to short-circuit signature verification when executing the transaction. -- If the sender or sponsor keys have changed for the account then the corresponding signature(s) have to be verified again. - SponsoredTransactionSuccess + ExtendedTransactionSuccess { senderKeysHash :: !Sha256.Hash, - sponsorKeysHash :: !Sha256.Hash, + sponsorKeysHash :: !(Option Sha256.Hash), nonce :: !Types.Nonce } | -- | At start-up, the transaction was taken from a block that has already been verified, so From 40b86ff1e8e9a8eb430ffc4e70b3b3745a7914fd Mon Sep 17 00:00:00 2001 From: Thomas Dinsdale-Young Date: Wed, 12 Nov 2025 16:39:43 +0100 Subject: [PATCH 07/26] Update base after merge. --- concordium-base | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/concordium-base b/concordium-base index 73e0b49530..7b573249fa 160000 --- a/concordium-base +++ b/concordium-base @@ -1 +1 @@ -Subproject commit 73e0b49530ea0769f0cce970c79b6d15b1e967f6 +Subproject commit 7b573249fade33ead412926685156fd2a88537f3 From fa6fc9ea50e359314ab545f1810be38da83d0bde Mon Sep 17 00:00:00 2001 From: Thomas Dinsdale-Young Date: Thu, 13 Nov 2025 13:15:30 +0100 Subject: [PATCH 08/26] Roll back base --- concordium-base | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/concordium-base b/concordium-base index 7b573249fa..73e0b49530 160000 --- a/concordium-base +++ b/concordium-base @@ -1 +1 @@ -Subproject commit 7b573249fade33ead412926685156fd2a88537f3 +Subproject commit 73e0b49530ea0769f0cce970c79b6d15b1e967f6 From 81edd1fce6b611f95572582f4e6e416830ef265a Mon Sep 17 00:00:00 2001 From: drsk <827698+drsk0@users.noreply.github.com> Date: Fri, 14 Nov 2025 13:32:03 +0100 Subject: [PATCH 09/26] SPO-9: extend AccountTransactionDetails (#1464) * SPO-9: extend AccountTransactionDetails This extacts the optional sponsor from the received transaction and fills the new sponsor field of `AccountTransactionDetails`. * update CHANGELOG * concordium-base:submodule update * set TransactionSummaryVersion ~ TransactionOutcomesVersion * concordium-base: update submodule * propagate changes of concordium-base * update benchmark code * update getResults * fix assertApplied * extend hash tests for TOV3 * fix transactionOutcomesHashV1 * concordium-base: update submodule * Update concordium-consensus/benchmarks/transactions/SchedulerBench/Helpers.hs Co-authored-by: Thomas Dinsdale-Young * Update concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs Co-authored-by: Thomas Dinsdale-Young * Update concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs Co-authored-by: Thomas Dinsdale-Young * Update concordium-consensus/src/Concordium/GlobalState/BlockState.hs Co-authored-by: Thomas Dinsdale-Young * Update concordium-consensus/src/Concordium/Types/TransactionOutcomes.hs Co-authored-by: Thomas Dinsdale-Young * Update concordium-consensus/src/Concordium/Types/TransactionOutcomes.hs Co-authored-by: Thomas Dinsdale-Young * Update concordium-consensus/src/Concordium/Scheduler.hs Co-authored-by: Thomas Dinsdale-Young * Update concordium-consensus/src/Concordium/GlobalState/BlockState.hs Co-authored-by: Thomas Dinsdale-Young * remove changelog entry * format * fix tests/benchmark * drop tsSponsorField logic from scheduler * Apply suggestion from @td202 Co-authored-by: Thomas Dinsdale-Young * Apply suggestion from @td202 Co-authored-by: Thomas Dinsdale-Young * Apply suggestion from @td202 Co-authored-by: Thomas Dinsdale-Young * Apply suggestion from @td202 Co-authored-by: Thomas Dinsdale-Young * Apply suggestion from @td202 Co-authored-by: Thomas Dinsdale-Young * small fixes after suggestions * added DataKinds pragma * more review comments * format * cosmetics * format * fix a billion tests * Update concordium-consensus/src/Concordium/Scheduler/Environment.hs Co-authored-by: Thomas Dinsdale-Young * Update concordium-consensus/src/Concordium/Scheduler.hs Co-authored-by: Thomas Dinsdale-Young * remove wtcSponsorDetails field --------- Co-authored-by: drsk Co-authored-by: Thomas Dinsdale-Young --- concordium-base | 2 +- .../transactions/SchedulerBench/Helpers.hs | 18 ++--- .../transactions/TransactionsBench.hs | 2 +- .../src-lib/Concordium/External/DryRun.hs | 2 +- .../src/Concordium/Birk/Bake.hs | 2 +- .../src/Concordium/GlobalState/BlockState.hs | 17 +++-- .../GlobalState/Persistent/BlockState.hs | 48 +++++++++--- .../GlobalState/PurgeTransactions.hs | 2 +- .../src/Concordium/GlobalState/TreeState.hs | 2 +- .../src/Concordium/KonsensusV1/Scheduler.hs | 4 +- .../src/Concordium/Queries.hs | 14 ++-- .../src/Concordium/Scheduler.hs | 75 ++++++++++--------- .../src/Concordium/Scheduler/Environment.hs | 9 ++- .../Scheduler/TreeStateEnvironment.hs | 2 +- .../src/Concordium/Scheduler/Types.hs | 8 +- .../Concordium/Types/TransactionOutcomes.hs | 34 ++++++--- .../KonsensusV1/Consensus/Blocks.hs | 2 +- .../globalstate/GlobalStateTests/BlockHash.hs | 23 +++--- .../SchedulerTests/AccountTransactionSpecs.hs | 2 +- .../SchedulerTests/BakerTransactions.hs | 1 + .../SchedulerTests/BlockEnergyLimitSpec.hs | 4 +- .../scheduler/SchedulerTests/ChainMetatest.hs | 2 +- .../SchedulerTests/ConfigureBaker.hs | 28 +++---- .../scheduler/SchedulerTests/Delegation.hs | 28 +++---- .../FibonacciSelfMessageTest.hs | 2 +- .../tests/scheduler/SchedulerTests/Helpers.hs | 54 ++++++------- .../SchedulerTests/InitContextTest.hs | 2 +- .../InitialAccountCreationSpec.hs | 2 +- .../SchedulerTests/RandomBakerTransactions.hs | 2 +- .../SchedulerTests/ReceiveContextTest.hs | 2 +- .../scheduler/SchedulerTests/RejectReasons.hs | 2 +- .../RejectReasonsRustContract.hs | 2 +- .../SchedulerTests/SimpleTransferSpec.hs | 2 +- .../SchedulerTests/SimpleTransfersTest.hs | 8 +- .../SmartContracts/V0/SmartContractTests.hs | 4 +- .../SchedulerTests/StakedAmountLocked.hs | 2 +- .../scheduler/SchedulerTests/TokenModule.hs | 4 +- .../SchedulerTests/TransactionExpirySpec.hs | 2 +- .../TransactionGroupingSpec2.hs | 2 +- .../TransfersWithScheduleTest.hs | 4 +- 40 files changed, 245 insertions(+), 182 deletions(-) diff --git a/concordium-base b/concordium-base index 73e0b49530..73535c7fe6 160000 --- a/concordium-base +++ b/concordium-base @@ -1 +1 @@ -Subproject commit 73e0b49530ea0769f0cce970c79b6d15b1e967f6 +Subproject commit 73535c7fe6a692fcd69f84f9d11ba88c51e48172 diff --git a/concordium-consensus/benchmarks/transactions/SchedulerBench/Helpers.hs b/concordium-consensus/benchmarks/transactions/SchedulerBench/Helpers.hs index 80826bbdfc..fe63bbc095 100644 --- a/concordium-consensus/benchmarks/transactions/SchedulerBench/Helpers.hs +++ b/concordium-consensus/benchmarks/transactions/SchedulerBench/Helpers.hs @@ -50,7 +50,7 @@ import qualified Concordium.Scheduler.Types as Types import Concordium.TimeMonad import qualified Data.Bifunctor as Bifunctor -getResults :: [(a, Types.TransactionSummary)] -> [(a, Types.ValidResult)] +getResults :: [(a, Types.TransactionSummary tov)] -> [(a, Types.ValidResult)] getResults = map $ Bifunctor.second Types.tsResult -- | The cost for processing a simple transfer (account to account) @@ -187,9 +187,9 @@ defaultContextState = } -- | Result from running the scheduler in a test environment. -data SchedulerResult = SchedulerResult +data SchedulerResult (tov :: Types.TransactionOutcomesVersion) = SchedulerResult { -- | The outcome for constructing a block. - srTransactions :: FilteredTransactions, + srTransactions :: FilteredTransactions tov, -- | The total execution cost of the block. srExecutionCosts :: Types.Amount, -- | The total execution energy of the block. @@ -204,7 +204,7 @@ runScheduler :: TestConfig -> BS.HashedPersistentBlockState pv -> Types.GroupedTransactions -> - PersistentBSM pv (SchedulerResult, BS.PersistentBlockState pv) + PersistentBSM pv (SchedulerResult (Types.TransactionOutcomesVersionFor pv), BS.PersistentBlockState pv) runScheduler TestConfig{..} stateBefore transactions = do blockStateBefore <- BS.thawBlockState stateBefore let txs = filterTransactions tcBlockSize (Time.timestampToUTCTime tcBlockTimeout) transactions @@ -226,16 +226,16 @@ runScheduler TestConfig{..} stateBefore transactions = do -- running transactions and the extractor, meaning the result of the extractor should not retain any -- references and should be fully evaluated. runSchedulerTest :: - forall pv a. - (Types.IsProtocolVersion pv) => + forall tov pv a. + (Types.IsProtocolVersion pv, tov ~ Types.TransactionOutcomesVersionFor pv) => TestConfig -> PersistentBSM pv (BS.HashedPersistentBlockState pv) -> - (SchedulerResult -> BS.PersistentBlockState pv -> PersistentBSM pv a) -> + (SchedulerResult tov -> BS.PersistentBlockState pv -> PersistentBSM pv a) -> Types.GroupedTransactions -> - IO (SchedulerResult, a) + IO (SchedulerResult tov, a) runSchedulerTest config constructState extractor transactions = runTestBlockState computation where - computation :: PersistentBSM pv (SchedulerResult, a) + computation :: PersistentBSM pv (SchedulerResult tov, a) computation = do blockStateBefore <- constructState (result, blockStateAfter) <- runScheduler config blockStateBefore transactions diff --git a/concordium-consensus/benchmarks/transactions/TransactionsBench.hs b/concordium-consensus/benchmarks/transactions/TransactionsBench.hs index 800376c519..ae3b5eaf55 100644 --- a/concordium-consensus/benchmarks/transactions/TransactionsBench.hs +++ b/concordium-consensus/benchmarks/transactions/TransactionsBench.hs @@ -40,7 +40,7 @@ initialBlockState = Helpers.makeTestAccountFromSeed 1_000_000 1 ] -assertApplied :: Bool -> Int -> Helpers.SchedulerResult -> BS.PersistentBlockState pv -> Helpers.PersistentBSM pv () +assertApplied :: Bool -> Int -> Helpers.SchedulerResult (TransactionOutcomesVersionFor pv) -> BS.PersistentBlockState pv -> Helpers.PersistentBSM pv () assertApplied assertSuccess txnCount result _state = do let results = Helpers.getResults $ ftAdded (Helpers.srTransactions result) if length results /= txnCount diff --git a/concordium-consensus/src-lib/Concordium/External/DryRun.hs b/concordium-consensus/src-lib/Concordium/External/DryRun.hs index 095d3ac5c8..0c515ca239 100644 --- a/concordium-consensus/src-lib/Concordium/External/DryRun.hs +++ b/concordium-consensus/src-lib/Concordium/External/DryRun.hs @@ -760,7 +760,7 @@ dryRunTransaction dryRunPtr senderPtr energyLimit payloadPtr payloadLen sigPairs Nothing -> do lift . lift . liftIO $ writeIORef shiQuotaRef 0 return $ Left OutOfEnergyQuota - Just (res :: TransactionSummary' ValidResultWithReturn) -> do + Just (res :: TransactionSummary' tov ValidResultWithReturn) -> do let newQuotaRem = shiQuotaRem - tsEnergyCost res lift . lift . liftIO $ writeIORef shiQuotaRef newQuotaRem diff --git a/concordium-consensus/src/Concordium/Birk/Bake.hs b/concordium-consensus/src/Concordium/Birk/Bake.hs index 19bd7be861..0a88d6c7ab 100644 --- a/concordium-consensus/src/Concordium/Birk/Bake.hs +++ b/concordium-consensus/src/Concordium/Birk/Bake.hs @@ -57,7 +57,7 @@ processTransactions :: BlockPointerType m -> Maybe FinalizerInfo -> BakerId -> - m (FilteredTransactions, ExecutionResult m) + m (FilteredTransactions (TransactionOutcomesVersionFor (MPV m)), ExecutionResult m) processTransactions slot ss bh mfinInfo bid = do -- update the focus block to the parent block (establish invariant needed by constructBlock) updateFocusBlockTo bh diff --git a/concordium-consensus/src/Concordium/GlobalState/BlockState.hs b/concordium-consensus/src/Concordium/GlobalState/BlockState.hs index b7f49d4b8d..f64c31df5f 100644 --- a/concordium-consensus/src/Concordium/GlobalState/BlockState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/BlockState.hs @@ -441,7 +441,9 @@ class (Monad m, BlockStateTypes m) => ModuleQuery m where -- | We create a wrapper here so we can -- derive another 'HashableTo' instance which omits -- the exact 'RejectReason' in the resulting hash. -newtype TransactionSummaryV1 = TransactionSummaryV1 {_transactionSummaryV1 :: TransactionSummary' ValidResult} +newtype TransactionSummaryV1 (tov :: TransactionOutcomesVersion) = TransactionSummaryV1 + { _transactionSummaryV1 :: TransactionSummary' tov ValidResult + } deriving (Eq, Show) -- | A 'HashableTo' instance for a 'TransactionSummary'' which omits the exact @@ -452,12 +454,13 @@ newtype TransactionSummaryV1 = TransactionSummaryV1 {_transactionSummaryV1 :: Tr -- bytestring. The downside is more foreign calls to the hashing function, so -- there might be opportunities for small-scale optimizations here, but this -- needs careful benchmarks. -instance HashableTo H.Hash TransactionSummaryV1 where +instance HashableTo H.Hash (TransactionSummaryV1 tov) where getHash (TransactionSummaryV1 summary) = H.hashLazy $! S.runPutLazy $! S.putShortByteString "TransactionOutcomeHashV1" <> encodeSender (tsSender summary) + <> mapM_ (putMaybe S.put) (tsSponsorDetails summary) <> S.put (tsHash summary) <> S.put (tsCost summary) <> S.put (tsEnergyCost summary) @@ -485,14 +488,14 @@ instance HashableTo H.Hash TransactionSummaryV1 where S.putWord8 1 S.put sender -instance (MonadBlobStore m, MonadProtocolVersion m) => BlobStorable m TransactionSummaryV1 where +instance (MonadBlobStore m, MonadProtocolVersion m, tov ~ TransactionOutcomesVersionFor (MPV m)) => BlobStorable m (TransactionSummaryV1 tov) where storeUpdate s@(TransactionSummaryV1 ts) = return (putTransactionSummary ts, s) load = do s <- getTransactionSummary (protocolVersion @(MPV m)) return . return $! TransactionSummaryV1 s -- Generic instance based on the HashableTo instance -instance (Monad m) => MHashableTo m H.Hash TransactionSummaryV1 +instance (Monad m) => MHashableTo m H.Hash (TransactionSummaryV1 tov) -- | Operations on mutable token state. -- Note that 'updateTokenState' can only fail if a key is locked by an iterator. @@ -655,7 +658,7 @@ class getRewardStatus :: BlockState m -> m (RewardStatus' Epoch) -- | Get the outcome of a transaction in the given block. - getTransactionOutcome :: BlockState m -> TransactionIndex -> m (Maybe TransactionSummary) + getTransactionOutcome :: BlockState m -> TransactionIndex -> m (Maybe (TransactionSummary (TransactionOutcomesVersionFor (MPV m)))) -- | Get the transactionOutcomesHash of a given block. getTransactionOutcomesHash :: BlockState m -> m TransactionOutcomesHash @@ -664,7 +667,7 @@ class getStateHash :: BlockState m -> m StateHash -- | Get all transaction outcomes for this block. - getOutcomes :: BlockState m -> m (Vec.Vector TransactionSummary) + getOutcomes :: BlockState m -> m (Vec.Vector (TransactionSummary (TransactionOutcomesVersionFor (MPV m)))) -- | Get special transactions outcomes (for administrative transactions, e.g., baker reward) -- They should be returned in the order that they were emitted. @@ -1518,7 +1521,7 @@ class (BlockStateQuery m, PLTQuery (UpdatableBlockState m) (MutableTokenState m) bsoSetPaydayMintRate :: (PVSupportsDelegation (MPV m)) => UpdatableBlockState m -> MintRate -> m (UpdatableBlockState m) -- | Set the transaction outcomes for the block. - bsoSetTransactionOutcomes :: UpdatableBlockState m -> [TransactionSummary] -> m (UpdatableBlockState m) + bsoSetTransactionOutcomes :: UpdatableBlockState m -> [TransactionSummary (TransactionOutcomesVersionFor (MPV m))] -> m (UpdatableBlockState m) -- | Add a special transaction outcome. bsoAddSpecialTransactionOutcome :: UpdatableBlockState m -> SpecialTransactionOutcome -> m (UpdatableBlockState m) diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs index 4b1d58a061..929d529e7a 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs @@ -688,16 +688,16 @@ emptyBlockRewardDetails = type PersistentBlockState (pv :: ProtocolVersion) = IORef (BufferedRef (BlockStatePointers pv)) -- | Transaction outcomes stored in a merkle binary tree. -data MerkleTransactionOutcomes = MerkleTransactionOutcomes +data MerkleTransactionOutcomes (tov :: TransactionOutcomesVersion) = MerkleTransactionOutcomes { -- | Normal transaction outcomes - mtoOutcomes :: LFMBT.LFMBTree TransactionIndex HashedBufferedRef TransactionSummaryV1, + mtoOutcomes :: LFMBT.LFMBTree TransactionIndex HashedBufferedRef (TransactionSummaryV1 tov), -- | Special transaction outcomes mtoSpecials :: LFMBT.LFMBTree TransactionIndex HashedBufferedRef Transactions.SpecialTransactionOutcome } deriving (Show) -- | Create an empty 'MerkleTransactionOutcomes' -emptyMerkleTransactionOutcomes :: MerkleTransactionOutcomes +emptyMerkleTransactionOutcomes :: MerkleTransactionOutcomes tov emptyMerkleTransactionOutcomes = MerkleTransactionOutcomes { mtoOutcomes = LFMBT.empty, @@ -715,9 +715,10 @@ emptyMerkleTransactionOutcomes = -- the hashing scheme is not a hash list but a merkle tree, so it is the root hash that is -- used in the final 'BlockHash'. data PersistentTransactionOutcomes (tov :: TransactionOutcomesVersion) where - PTOV0 :: TransactionOutcomes.TransactionOutcomes -> PersistentTransactionOutcomes 'TOV0 - PTOV1 :: MerkleTransactionOutcomes -> PersistentTransactionOutcomes 'TOV1 - PTOV2 :: MerkleTransactionOutcomes -> PersistentTransactionOutcomes 'TOV2 + PTOV0 :: TransactionOutcomes.TransactionOutcomes 'TOV0 -> PersistentTransactionOutcomes 'TOV0 + PTOV1 :: MerkleTransactionOutcomes 'TOV1 -> PersistentTransactionOutcomes 'TOV1 + PTOV2 :: MerkleTransactionOutcomes 'TOV2 -> PersistentTransactionOutcomes 'TOV2 + PTOV3 :: MerkleTransactionOutcomes 'TOV3 -> PersistentTransactionOutcomes 'TOV3 -- | Create an empty persistent transaction outcome emptyPersistentTransactionOutcomes :: forall tov. (IsTransactionOutcomesVersion tov) => PersistentTransactionOutcomes tov @@ -725,9 +726,10 @@ emptyPersistentTransactionOutcomes = case transactionOutcomesVersion @tov of STOV0 -> PTOV0 TransactionOutcomes.emptyTransactionOutcomesV0 STOV1 -> PTOV1 emptyMerkleTransactionOutcomes STOV2 -> PTOV2 emptyMerkleTransactionOutcomes + STOV3 -> PTOV3 emptyMerkleTransactionOutcomes instance - (BlobStorable m TransactionSummaryV1) => + (BlobStorable m (TransactionSummaryV1 tov), MonadProtocolVersion m, (TransactionOutcomesVersionFor (MPV m) ~ tov)) => MHashableTo m (TransactionOutcomes.TransactionOutcomesHashV tov) (PersistentTransactionOutcomes tov) where getHashM (PTOV0 bto) = return (getHash bto) @@ -745,6 +747,12 @@ instance return $! TransactionOutcomes.TransactionOutcomesHashV $ H.hashOfHashes (LFMBT.theLFMBTreeHash out) (LFMBT.theLFMBTreeHash special) + getHashM (PTOV3 MerkleTransactionOutcomes{..}) = do + out <- getHashM @_ @(LFMBT.LFMBTreeHash' 'BlockHashVersion1) mtoOutcomes + special <- getHashM @_ @(LFMBT.LFMBTreeHash' 'BlockHashVersion1) mtoSpecials + return $! + TransactionOutcomes.TransactionOutcomesHashV $ + H.hashOfHashes (LFMBT.theLFMBTreeHash out) (LFMBT.theLFMBTreeHash special) instance ( TransactionOutcomesVersionFor (MPV m) ~ tov, @@ -757,6 +765,7 @@ instance storeUpdate out = case out of PTOV1 mto -> (_2 %~ PTOV1) <$> inner mto PTOV2 mto -> (_2 %~ PTOV2) <$> inner mto + PTOV3 mto -> (_2 %~ PTOV3) <$> inner mto where inner MerkleTransactionOutcomes{..} = do (pout, mtoOutcomes') <- storeUpdate mtoOutcomes @@ -782,6 +791,13 @@ instance mtoOutcomes <- mout mtoSpecials <- mspecials return $! PTOV2 MerkleTransactionOutcomes{..} + STOV3 -> do + mout <- load + mspecials <- load + return $! do + mtoOutcomes <- mout + mtoSpecials <- mspecials + return $! PTOV3 MerkleTransactionOutcomes{..} -- | Create an empty 'PersistentTransactionOutcomes' based on the 'ProtocolVersion'. emptyTransactionOutcomes :: @@ -793,6 +809,7 @@ emptyTransactionOutcomes Proxy = case transactionOutcomesVersion @(TransactionOu STOV0 -> PTOV0 TransactionOutcomes.emptyTransactionOutcomesV0 STOV1 -> PTOV1 emptyMerkleTransactionOutcomes STOV2 -> PTOV2 emptyMerkleTransactionOutcomes + STOV3 -> PTOV3 emptyMerkleTransactionOutcomes -- | References to the components that make up the block state. -- @@ -3405,13 +3422,14 @@ doGetPoolStatus pbs psBakerId@(BakerId aid) = case delegationChainParameters @pv then return $ Just BakerPoolStatus{..} else return Nothing -doGetTransactionOutcome :: forall pv m. (SupportsPersistentState pv m) => PersistentBlockState pv -> Transactions.TransactionIndex -> m (Maybe TransactionSummary) +doGetTransactionOutcome :: forall tov pv m. (SupportsPersistentState pv m, TransactionOutcomesVersionFor pv ~ tov) => PersistentBlockState pv -> Transactions.TransactionIndex -> m (Maybe (TransactionSummary tov)) doGetTransactionOutcome pbs transHash = do bsp <- loadPBS pbs case bspTransactionOutcomes bsp of PTOV0 bto -> return $! bto ^? ix transHash PTOV1 bto -> fmap _transactionSummaryV1 <$> LFMBT.lookup transHash (mtoOutcomes bto) PTOV2 bto -> fmap _transactionSummaryV1 <$> LFMBT.lookup transHash (mtoOutcomes bto) + PTOV3 bto -> fmap _transactionSummaryV1 <$> LFMBT.lookup transHash (mtoOutcomes bto) doGetTransactionOutcomesHash :: forall pv m. @@ -3423,7 +3441,7 @@ doGetTransactionOutcomesHash pbs = do TransactionOutcomes.toTransactionOutcomesHash @(TransactionOutcomesVersionFor pv) <$> getHashM (bspTransactionOutcomes bsp) -doSetTransactionOutcomes :: forall pv m. (SupportsPersistentState pv m) => PersistentBlockState pv -> [TransactionSummary] -> m (PersistentBlockState pv) +doSetTransactionOutcomes :: forall tov pv m. (SupportsPersistentState pv m, tov ~ TransactionOutcomesVersionFor pv) => PersistentBlockState pv -> [TransactionSummary tov] -> m (PersistentBlockState pv) doSetTransactionOutcomes pbs transList = do bsp <- loadPBS pbs case bspTransactionOutcomes bsp of @@ -3440,8 +3458,11 @@ doSetTransactionOutcomes pbs transList = do PTOV2 _ -> do mto <- makeMTO storePBS pbs bsp{bspTransactionOutcomes = PTOV2 mto} + PTOV3 _ -> do + mto <- makeMTO + storePBS pbs bsp{bspTransactionOutcomes = PTOV3 mto} where - makeMTO :: m MerkleTransactionOutcomes + makeMTO :: m (MerkleTransactionOutcomes tov) makeMTO = do mtoOutcomes <- LFMBT.fromAscList . map TransactionSummaryV1 $ transList return MerkleTransactionOutcomes{mtoSpecials = LFMBT.empty, ..} @@ -3458,14 +3479,16 @@ doGetSpecialOutcomes pbs = do PTOV0 bto -> return (bto ^. TransactionOutcomes.outcomeSpecial) PTOV1 bto -> Seq.fromList <$> LFMBT.toAscList (mtoSpecials bto) PTOV2 bto -> Seq.fromList <$> LFMBT.toAscList (mtoSpecials bto) + PTOV3 bto -> Seq.fromList <$> LFMBT.toAscList (mtoSpecials bto) -doGetOutcomes :: (SupportsPersistentState pv m, MonadProtocolVersion m) => PersistentBlockState pv -> m (Vec.Vector TransactionSummary) +doGetOutcomes :: (SupportsPersistentState pv m, MonadProtocolVersion m) => PersistentBlockState pv -> m (Vec.Vector (TransactionSummary (TransactionOutcomesVersionFor pv))) doGetOutcomes pbs = do bsp <- loadPBS pbs case bspTransactionOutcomes bsp of PTOV0 bto -> return (TransactionOutcomes.outcomeValues bto) PTOV1 bto -> Vec.fromList . map _transactionSummaryV1 <$> LFMBT.toAscList (mtoOutcomes bto) PTOV2 bto -> Vec.fromList . map _transactionSummaryV1 <$> LFMBT.toAscList (mtoOutcomes bto) + PTOV3 bto -> Vec.fromList . map _transactionSummaryV1 <$> LFMBT.toAscList (mtoOutcomes bto) doAddSpecialTransactionOutcome :: (SupportsPersistentState pv m, MonadProtocolVersion m) => PersistentBlockState pv -> Transactions.SpecialTransactionOutcome -> m (PersistentBlockState pv) doAddSpecialTransactionOutcome pbs !o = do @@ -3483,6 +3506,9 @@ doAddSpecialTransactionOutcome pbs !o = do PTOV2 bto -> do (_, newSpecials) <- LFMBT.append o (mtoSpecials bto) storePBS pbs $! bsp{bspTransactionOutcomes = PTOV2 (bto{mtoSpecials = newSpecials})} + PTOV3 bto -> do + (_, newSpecials) <- LFMBT.append o (mtoSpecials bto) + storePBS pbs $! bsp{bspTransactionOutcomes = PTOV3 (bto{mtoSpecials = newSpecials})} doGetElectionDifficulty :: ( SupportsPersistentState pv m, diff --git a/concordium-consensus/src/Concordium/GlobalState/PurgeTransactions.hs b/concordium-consensus/src/Concordium/GlobalState/PurgeTransactions.hs index 341bff0e81..b5f095536e 100644 --- a/concordium-consensus/src/Concordium/GlobalState/PurgeTransactions.hs +++ b/concordium-consensus/src/Concordium/GlobalState/PurgeTransactions.hs @@ -225,7 +225,7 @@ filterTables :: -- | 'BlockHash' of block that transactions were added in BlockHash -> -- | Filtered transactions as a result of constructing the block. - FilteredTransactions -> + FilteredTransactions tov -> -- | Transaction table to update TransactionTable -> -- | Pending transaction table to update diff --git a/concordium-consensus/src/Concordium/GlobalState/TreeState.hs b/concordium-consensus/src/Concordium/GlobalState/TreeState.hs index e98fd2086c..55373b2964 100644 --- a/concordium-consensus/src/Concordium/GlobalState/TreeState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/TreeState.hs @@ -428,7 +428,7 @@ class -- | Hash of the block being constructed. BlockHash -> -- | Filtered transactions as a result of constructing the block. - FilteredTransactions -> + FilteredTransactions (TransactionOutcomesVersionFor (MPV m)) -> m () -- | Mark a transaction as no longer on a given block. This is used when a block is diff --git a/concordium-consensus/src/Concordium/KonsensusV1/Scheduler.hs b/concordium-consensus/src/Concordium/KonsensusV1/Scheduler.hs index f83b7d8dc4..e9ad4e5e44 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/Scheduler.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/Scheduler.hs @@ -557,7 +557,7 @@ constructBlockTransactions :: Timestamp -> -- | Block state. UpdatableBlockState m -> - m (FilteredTransactions, TransactionExecutionResult m) + m (FilteredTransactions (TransactionOutcomesVersionFor (MPV m)), TransactionExecutionResult m) constructBlockTransactions runtimeParams startTime transTable pendingTable blockTimestamp theState0 = do -- The block energy limit and account creation limit are taken from the current chain parameters. chainParams <- bsoGetChainParameters theState0 @@ -726,7 +726,7 @@ constructBlockState :: TransactionTable -> PendingTransactionTable -> BlockExecutionData pv -> - m (FilteredTransactions, PBS.HashedPersistentBlockState pv, Energy) + m (FilteredTransactions (TransactionOutcomesVersionFor pv), PBS.HashedPersistentBlockState pv, Energy) constructBlockState runtimeParams transactionTable pendingTable execData@BlockExecutionData{..} = do seedState <- getSeedState bedParentState if seedState ^. shutdownTriggered diff --git a/concordium-consensus/src/Concordium/Queries.hs b/concordium-consensus/src/Concordium/Queries.hs index 37539cf830..16ec7edc21 100644 --- a/concordium-consensus/src/Concordium/Queries.hs +++ b/concordium-consensus/src/Concordium/Queries.hs @@ -39,7 +39,6 @@ import Concordium.Types.Conditionally import Concordium.Types.Execution ( Payload (..), SupplementEvents (..), - SupplementedTransactionSummary, TransactionIndex, TransactionSummary, addInitializeParameter, @@ -834,7 +833,7 @@ getBlockTransactionSummaries = return $! supplementOutcomes (protocolVersion @pv) outcomes transactions supplementOutcomes :: SProtocolVersion pv -> - Vec.Vector TransactionSummary -> + Vec.Vector (TransactionSummary (TransactionOutcomesVersionFor pv)) -> [BlockItem] -> Either String (Vec.Vector SupplementedTransactionSummary) supplementOutcomes spv outcomes transactions = @@ -844,7 +843,7 @@ getBlockTransactionSummaries = Right (_, _) -> Left "Block has more transactions than outcomes" supplement :: SProtocolVersion pv -> - TransactionSummary -> + TransactionSummary (TransactionOutcomesVersionFor pv) -> State.StateT [BlockItem] (Either String) SupplementedTransactionSummary supplement spv ts = do items <- State.get @@ -860,7 +859,7 @@ getBlockTransactionSummaries = case decoded of InitContract{..} -> return icParam _ -> Left "Initialization event is not for a contract initialization" - lift $ supplementEvents (addInitializeParameter mInitParam) ts + lift $ toSupplementedTransactionSummary <$> supplementEvents (addInitializeParameter mInitParam) ts -- | Get the transaction outcomes in the block. getBlockSpecialEvents :: forall finconf. BlockHashInput -> MVR finconf (BHIQueryResponse (Seq.Seq SpecialTransactionOutcome)) @@ -1646,14 +1645,17 @@ getTransactionStatus trHash = -- Helper to convert a 'TransactionSummary' to a 'SupplementedTransactionSummary' given the -- 'BlockItem' corresponding to the originating transaction. supplementTransactionSummary :: - SProtocolVersion pv -> Maybe BlockItem -> Maybe TransactionSummary -> Maybe SupplementedTransactionSummary + SProtocolVersion pv -> + Maybe BlockItem -> + Maybe (TransactionSummary (TransactionOutcomesVersionFor pv)) -> + Maybe SupplementedTransactionSummary supplementTransactionSummary spv mbi mts = do ts <- mts let mip = do (NormalTransaction acctTransaction) <- wmdData <$> mbi (InitContract{..}) <- decodePayload spv (atrPayload acctTransaction) ^? _Right return icParam - supplementEvents (addInitializeParameter mip) ts + toSupplementedTransactionSummary <$> supplementEvents (addInitializeParameter mip) ts -- * Smart contract invocations invokeContract :: BlockHashInput -> InvokeContract.ContractContext -> MVR finconf (BHIQueryResponse InvokeContract.InvokeContractResult) diff --git a/concordium-consensus/src/Concordium/Scheduler.hs b/concordium-consensus/src/Concordium/Scheduler.hs index 8250f25cef..9941497da9 100644 --- a/concordium-consensus/src/Concordium/Scheduler.hs +++ b/concordium-consensus/src/Concordium/Scheduler.hs @@ -232,7 +232,7 @@ checkTransactionVerificationResult (TVer.NotOk TVer.SponsoredTransactionMissingS -- * @Nothing@ if the transaction would exceed the remaining block energy. -- * @Just result@ if the transaction failed ('TxInvalid') or was successfully committed -- ('TxValid', with either 'TxSuccess' or 'TxReject'). -dispatch :: forall msg m. (TransactionData msg, SchedulerMonad m) => (msg, Maybe TVer.VerificationResult) -> m (Maybe TxResult) +dispatch :: forall msg m. (TransactionData msg, SchedulerMonad m) => (msg, Maybe TVer.VerificationResult) -> m (Maybe (TxResult (TransactionOutcomesVersionFor (MPV m)))) dispatch (msg, mVerRes) = do validMeta <- runExceptT (checkHeader msg mVerRes) case validMeta of @@ -268,7 +268,7 @@ dispatchTransactionBody :: IndexedAccount m -> -- | Energy cost to be charged for checking the transaction header. Energy -> - m (Maybe (TransactionSummary' res)) + m (Maybe (TransactionSummary' (TransactionOutcomesVersionFor (MPV m)) res)) dispatchTransactionBody msg senderAccount checkHeaderCost = do let meta = transactionHeader msg -- At this point the transaction is going to be committed to the block. @@ -293,6 +293,7 @@ dispatchTransactionBody msg senderAccount checkHeaderCost = do { tsEnergyCost = checkHeaderCost, tsCost = payment, tsSender = Just (thSender meta), -- the sender of the transaction is as specified in the transaction. + tsSponsorDetails = conditionally cHasSponsorDetails Nothing, tsResult = transactionReject SerializationFailure, tsHash = transactionHash msg, tsType = TSTAccountTransaction Nothing, @@ -416,6 +417,7 @@ dispatchTransactionBody msg senderAccount checkHeaderCost = do onlyWithPLT c = case sSupportsPLT (accountVersion @(AccountVersionFor (MPV m))) of SFalse -> error "Operation unsupported at this protocol version." STrue -> c + cHasSponsorDetails = (sHasSponsorDetails (sTransactionOutcomesVersionFor (protocolVersion @(MPV m)))) handleTransferWithSchedule :: forall m. @@ -425,7 +427,7 @@ handleTransferWithSchedule :: [(Timestamp, Amount)] -> -- | Nothing in case of a TransferWithSchedule and Just in case of a TransferWithScheduleAndMemo Maybe Memo -> - m (Maybe TransactionSummary) + m (Maybe (TransactionSummary (TransactionOutcomesVersionFor (MPV m)))) handleTransferWithSchedule wtc twsTo twsSchedule maybeMemo = withDeposit wtc c k where senderAccount = wtc ^. wtcSenderAccount @@ -508,7 +510,7 @@ handleTransferToPublic :: (SchedulerMonad m) => WithDepositContext m -> SecToPubAmountTransferData -> - m (Maybe TransactionSummary) + m (Maybe (TransactionSummary (TransactionOutcomesVersionFor (MPV m)))) handleTransferToPublic wtc transferData@SecToPubAmountTransferData{..} = do cryptoParams <- TVer.getCryptographicParameters withDeposit wtc (c cryptoParams) k @@ -565,7 +567,7 @@ handleTransferToEncrypted :: (SchedulerMonad m) => WithDepositContext m -> Amount -> - m (Maybe TransactionSummary) + m (Maybe (TransactionSummary (TransactionOutcomesVersionFor (MPV m)))) handleTransferToEncrypted wtc toEncrypted = do cryptoParams <- TVer.getCryptographicParameters withDeposit wtc (c cryptoParams) k @@ -618,7 +620,7 @@ handleEncryptedAmountTransfer :: EncryptedAmountTransferData -> -- | Nothing in case of an EncryptedAmountTransfer and Just in case of an EncryptedAmountTransferWithMemo Maybe Memo -> - m (Maybe TransactionSummary) + m (Maybe (TransactionSummary (TransactionOutcomesVersionFor (MPV m)))) handleEncryptedAmountTransfer wtc toAddress transferData@EncryptedAmountTransferData{..} maybeMemo = do cryptoParams <- TVer.getCryptographicParameters withDeposit wtc (c cryptoParams) k @@ -713,7 +715,7 @@ handleDeployModule :: WithDepositContext m -> -- | The module to deploy. Wasm.WasmModule -> - m (Maybe TransactionSummary) + m (Maybe (TransactionSummary (TransactionOutcomesVersionFor (MPV m)))) handleDeployModule wtc mod = withDeposit wtc c k where @@ -809,7 +811,7 @@ handleInitContract :: Wasm.InitName -> -- | Parameter expression to initialize with. Wasm.Parameter -> - m (Maybe (TransactionSummary' res)) + m (Maybe (TransactionSummary' (TransactionOutcomesVersionFor (MPV m)) res)) handleInitContract wtc initAmount modref initName param = withDeposit wtc c k where @@ -989,7 +991,7 @@ handleSimpleTransfer :: Amount -> -- | Nothing in case of a Transfer and Just in case of a TransferWithMemo Maybe Memo -> - m (Maybe TransactionSummary) + m (Maybe (TransactionSummary (TransactionOutcomesVersionFor (MPV m)))) handleSimpleTransfer wtc toAddr transferamount maybeMemo = withDeposit wtc c (defaultSuccess wtc) where @@ -1022,7 +1024,7 @@ handleUpdateContract :: Wasm.ReceiveName -> -- | Message to send to the receive method. Wasm.Parameter -> - m (Maybe (TransactionSummary' res)) + m (Maybe (TransactionSummary' (TransactionOutcomesVersionFor (MPV m)) res)) handleUpdateContract wtc uAmount uAddress uReceiveName uMessage = withDeposit wtc computeAndCharge (defaultSuccess wtc) where @@ -1986,7 +1988,7 @@ handleAddBaker :: Amount -> -- | Whether to restake the baker's earnings Bool -> - m (Maybe TransactionSummary) + m (Maybe (TransactionSummary (TransactionOutcomesVersionFor (MPV m)))) handleAddBaker wtc abElectionVerifyKey abSignatureVerifyKey abAggregationVerifyKey abProofSig abProofElection abProofAggregation abBakingStake abRestakeEarnings = withDeposit wtc c k where @@ -2098,7 +2100,7 @@ handleConfigureBaker :: Maybe AmountFraction -> -- | Whether to suspend/resume the baker. Maybe Bool -> - m (Maybe TransactionSummary) + m (Maybe (TransactionSummary (TransactionOutcomesVersionFor (MPV m)))) handleConfigureBaker wtc cbCapital @@ -2292,7 +2294,7 @@ handleConfigureDelegation :: Maybe Amount -> Maybe Bool -> Maybe DelegationTarget -> - m (Maybe TransactionSummary) + m (Maybe (TransactionSummary (TransactionOutcomesVersionFor (MPV m)))) handleConfigureDelegation wtc cdCapital cdRestakeEarnings cdDelegationTarget = withDeposit wtc tickAndGetAccountBalance chargeAndExecute where @@ -2405,7 +2407,7 @@ handleConfigureDelegation wtc cdCapital cdRestakeEarnings cdDelegationTarget = handleRemoveBaker :: (AccountVersionFor (MPV m) ~ 'AccountV0, ChainParametersVersionFor (MPV m) ~ 'ChainParametersV0, SchedulerMonad m) => WithDepositContext m -> - m (Maybe TransactionSummary) + m (Maybe (TransactionSummary (TransactionOutcomesVersionFor (MPV m)))) handleRemoveBaker wtc = withDeposit wtc c k where @@ -2433,7 +2435,7 @@ handleUpdateBakerStake :: WithDepositContext m -> -- | new stake Amount -> - m (Maybe TransactionSummary) + m (Maybe (TransactionSummary (TransactionOutcomesVersionFor (MPV m)))) handleUpdateBakerStake wtc newStake = withDeposit wtc c k where @@ -2471,7 +2473,7 @@ handleUpdateBakerRestakeEarnings :: WithDepositContext m -> -- | Whether to restake earnings Bool -> - m (Maybe TransactionSummary) + m (Maybe (TransactionSummary (TransactionOutcomesVersionFor (MPV m)))) handleUpdateBakerRestakeEarnings wtc newRestakeEarnings = withDeposit wtc c k where senderAccount = wtc ^. wtcSenderAccount @@ -2511,7 +2513,7 @@ handleUpdateBakerKeys :: Proofs.Dlog25519Proof -> Proofs.Dlog25519Proof -> BakerAggregationProof -> - m (Maybe TransactionSummary) + m (Maybe (TransactionSummary (TransactionOutcomesVersionFor (MPV m)))) handleUpdateBakerKeys wtc bkuElectionKey bkuSignKey bkuAggregationKey bkuProofSig bkuProofElection bkuProofAggregation = withDeposit wtc c k where @@ -2567,11 +2569,12 @@ handleUpdateBakerKeys wtc bkuElectionKey bkuSignKey bkuAggregationKey bkuProofSi -- -- Note that the function only fails with `TxInvalid` and thus failed transactions are not committed to chain. handleDeployCredential :: + forall m. (SchedulerMonad m) => -- | Credentials to deploy with the current verification status. TVer.CredentialDeploymentWithStatus -> TransactionHash -> - m (Maybe TxResult) + m (Maybe (TxResult (TransactionOutcomesVersionFor (MPV m)))) handleDeployCredential (WithMetadata{wmdData = cred@AccountCreation{messageExpiry = messageExpiry, credential = cdi}}, mVerRes) cdiHash = do res <- runExceptT $ do cm <- lift getChainMetadata @@ -2623,6 +2626,7 @@ handleDeployCredential (WithMetadata{wmdData = cred@AccountCreation{messageExpir TxValid $ TransactionSummary { tsSender = Nothing, + tsSponsorDetails = conditionally cHasSponsorDetails Nothing, tsHash = cdiHash, tsCost = 0, tsEnergyCost = theCost, @@ -2630,6 +2634,7 @@ handleDeployCredential (WithMetadata{wmdData = cred@AccountCreation{messageExpir .. } theCost = Cost.deployCredential (ID.credentialType cdi) (ID.credNumKeys . ID.credPubKeys $ cdi) + cHasSponsorDetails = (sHasSponsorDetails (sTransactionOutcomesVersionFor (protocolVersion @(MPV m)))) -- | Updates the credential keys in the credential with the given Credential ID. -- It rejects if there is no credential with the given Credential ID. @@ -2642,7 +2647,7 @@ handleUpdateCredentialKeys :: ID.CredentialPublicKeys -> -- | Signatures on the transaction. This is needed to check that a specific credential signed. TransactionSignature -> - m (Maybe TransactionSummary) + m (Maybe (TransactionSummary (TransactionOutcomesVersionFor (MPV m)))) handleUpdateCredentialKeys wtc cid keys sigs = withDeposit wtc c k where @@ -2682,7 +2687,7 @@ handleTokenUpdate :: TokenId -> -- | Operations for the token. TokenParameter -> - m (Maybe TransactionSummary) + m (Maybe (TransactionSummary (TransactionOutcomesVersionFor (MPV m)))) handleTokenUpdate depositContext tokenId tokenOperations = withDeposit depositContext computeTransaction commitTransaction where @@ -2744,7 +2749,7 @@ handleChainUpdate :: forall m. (SchedulerMonad m) => TVer.ChainUpdateWithStatus -> - m TxResult + m (TxResult (TransactionOutcomesVersionFor (MPV m))) handleChainUpdate (WithMetadata{wmdData = ui@UpdateInstruction{..}, ..}, maybeVerificationResult) = do cm <- getChainMetadata -- check that payload si @@ -2848,7 +2853,7 @@ handleChainUpdate (WithMetadata{wmdData = ui@UpdateInstruction{..}, ..}, maybeVe scpv = chainParametersVersion sauv :: SAuthorizationsVersion (AuthorizationsVersionFor (MPV m)) sauv = sAuthorizationsVersionFor $ protocolVersion @(MPV m) - checkSigThen :: m TxResult -> m TxResult + checkSigThen :: m (TxResult tov) -> m (TxResult tov) checkSigThen cont = do case maybeVerificationResult of Just (TVer.Ok (TVer.ChainUpdateSuccess keysHash _)) -> do @@ -2870,7 +2875,7 @@ handleChainUpdate (WithMetadata{wmdData = ui@UpdateInstruction{..}, ..}, maybeVe case checkTransactionVerificationResult newVerRes of Left failure -> return $ TxInvalid failure Right _ -> cont - checkSigAndEnqueue :: UpdateValue (ChainParametersVersionFor (MPV m)) (AuthorizationsVersionFor (MPV m)) -> m TxResult + checkSigAndEnqueue :: UpdateValue (ChainParametersVersionFor (MPV m)) (AuthorizationsVersionFor (MPV m)) -> m (TxResult (TransactionOutcomesVersionFor (MPV m))) checkSigAndEnqueue = checkSigThen . enqueue enqueue change = do enqueueUpdate (updateEffectiveTime uiHeader) change @@ -2885,12 +2890,14 @@ handleChainUpdate (WithMetadata{wmdData = ui@UpdateInstruction{..}, ..}, maybeVe TxValid TransactionSummary { tsSender = Nothing, + tsSponsorDetails = conditionally cHasSponsorDetails Nothing, tsHash = wmdHash, tsCost = 0, tsEnergyCost = 0, tsType = TSTUpdateTransaction $ updateType uiPayload, .. } + cHasSponsorDetails = (sHasSponsorDetails (sTransactionOutcomesVersionFor (protocolVersion @(MPV m)))) -- | Handler for processing chain update creating a new protocol level token. -- It is assumed that the signatures have already been checked. @@ -2927,7 +2934,7 @@ handleUpdateCredentials :: OrdMap.Map ID.CredentialIndex ID.CredentialDeploymentInformation -> [ID.CredentialRegistrationID] -> ID.AccountThreshold -> - m (Maybe TransactionSummary) + m (Maybe (TransactionSummary (TransactionOutcomesVersionFor (MPV m)))) handleUpdateCredentials wtc cdis removeRegIds threshold = withDeposit wtc c k where @@ -3065,7 +3072,7 @@ handleRegisterData :: WithDepositContext m -> -- | The data to register. RegisteredData -> - m (Maybe TransactionSummary) + m (Maybe (TransactionSummary (TransactionOutcomesVersionFor (MPV m)))) handleRegisterData wtc regData = withDeposit wtc c (defaultSuccess wtc) where @@ -3151,7 +3158,7 @@ filterTransactions :: UTCTime -> -- | Transactions to make a block out of. [TransactionGroup] -> - m FilteredTransactions + m (FilteredTransactions (TransactionOutcomesVersionFor (MPV m))) filterTransactions maxSize timeout groups0 = do maxEnergy <- getMaxBlockEnergy credLimit <- getAccountCreationLimit @@ -3176,9 +3183,9 @@ filterTransactions maxSize timeout groups0 = do Integer -> -- \^Current size of transactions in the block. CredentialsPerBlockLimit -> -- \^Number of credentials until limit. Bool -> -- \^Whether or not the block timeout is reached - FilteredTransactions -> -- \^Currently accumulated result + FilteredTransactions (TransactionOutcomesVersionFor (MPV m)) -> -- \^Currently accumulated result [TransactionGroup] -> -- \^Grouped transactions to process - m FilteredTransactions + m (FilteredTransactions (TransactionOutcomesVersionFor (MPV m))) -- All block items are processed. We accumulate the added items -- in reverse order, so reverse the list before returning. runNext _ _ _ _ fts [] = return fts{ftAdded = reverse (ftAdded fts)} @@ -3250,7 +3257,7 @@ filterTransactions maxSize timeout groups0 = do in runNext maxEnergy currentSize credLimit False newFts groups -- Run a single credential and continue with 'runNext'. - runCredential :: TVer.CredentialDeploymentWithStatus -> m FilteredTransactions + runCredential :: TVer.CredentialDeploymentWithStatus -> m (FilteredTransactions (TransactionOutcomesVersionFor (MPV m))) runCredential cws@(c@WithMetadata{..}, verRes) = do totalEnergyUsed <- getUsedEnergy let csize = size + fromIntegral wmdSize @@ -3288,9 +3295,9 @@ filterTransactions maxSize timeout groups0 = do -- Run all transactions in a group and continue with 'runNext'. runTransactionGroup :: Integer -> -- \^Current size of transactions in the block. - FilteredTransactions -> + FilteredTransactions (TransactionOutcomesVersionFor (MPV m)) -> [TVer.TransactionWithStatus] -> -- \^Current group to process. - m FilteredTransactions + m (FilteredTransactions (TransactionOutcomesVersionFor (MPV m))) runTransactionGroup currentSize currentFts (t : ts) = do totalEnergyUsed <- getUsedEnergy let csize = currentSize + fromIntegral (transactionSize (fst t)) @@ -3394,7 +3401,7 @@ runTransactions :: forall m. (SchedulerMonad m) => [TVer.BlockItemWithStatus] -> - m (Either (Maybe FailureKind) [(BlockItem, TransactionSummary)]) + m (Either (Maybe FailureKind) [(BlockItem, TransactionSummary (TransactionOutcomesVersionFor (MPV m)))]) runTransactions = go [] where go valid (bi : ts) = @@ -3408,7 +3415,7 @@ runTransactions = go [] Nothing -> return (Left Nothing) go valid [] = return (Right (reverse $ map (\(x, y) -> (fst x, y)) valid)) - predispatch :: TVer.BlockItemWithStatus -> m (Maybe TxResult) + predispatch :: TVer.BlockItemWithStatus -> m (Maybe (TxResult (TransactionOutcomesVersionFor (MPV m)))) predispatch (WithMetadata{wmdData = NormalTransaction tr, ..}, verRes) = dispatch (WithMetadata{wmdData = tr, ..}, verRes) predispatch (WithMetadata{wmdData = CredentialDeployment cred, ..}, verRes) = handleDeployCredential (WithMetadata{wmdData = cred, ..}, verRes) wmdHash predispatch (WithMetadata{wmdData = ChainUpdate cu, ..}, verRes) = Just <$> handleChainUpdate (WithMetadata{wmdData = cu, ..}, verRes) @@ -3445,7 +3452,7 @@ execTransactions = go return (Left (Just reason)) go [] = return (Right ()) - predispatch :: TVer.BlockItemWithStatus -> m (Maybe TxResult) + predispatch :: TVer.BlockItemWithStatus -> m (Maybe (TxResult (TransactionOutcomesVersionFor (MPV m)))) predispatch (WithMetadata{wmdData = NormalTransaction tr, ..}, verRes) = dispatch (WithMetadata{wmdData = tr, ..}, verRes) predispatch (WithMetadata{wmdData = CredentialDeployment cred, ..}, verRes) = handleDeployCredential (WithMetadata{wmdData = cred, ..}, verRes) wmdHash predispatch (WithMetadata{wmdData = ChainUpdate cu, ..}, verRes) = Just <$> handleChainUpdate (WithMetadata{wmdData = cu, ..}, verRes) diff --git a/concordium-consensus/src/Concordium/Scheduler/Environment.hs b/concordium-consensus/src/Concordium/Scheduler/Environment.hs index ab9cd68786..3433ea0724 100644 --- a/concordium-consensus/src/Concordium/Scheduler/Environment.hs +++ b/concordium-consensus/src/Concordium/Scheduler/Environment.hs @@ -1012,7 +1012,8 @@ makeLenses ''WithDepositContext -- * The deposited amount exists in the public account value. -- * The deposited amount is __at least__ Cost.checkHeader applied to the respective parameters (i.e., minimum transaction cost). withDeposit :: - (SchedulerMonad m, TransactionResult res) => + forall tov m res a. + (SchedulerMonad m, TransactionResult res, tov ~ TransactionOutcomesVersionFor (MPV m)) => WithDepositContext m -> -- | The computation to run in the modified environment with reduced amount on the initial account. LocalT a m a -> @@ -1021,7 +1022,7 @@ withDeposit :: -- remaining energy and the ChangeSet. It should return the result, and the amount that was charged -- for the execution. (LocalState m -> a -> m (res, Amount, Energy)) -> - m (Maybe (TransactionSummary' res)) + m (Maybe (TransactionSummary' tov res)) withDeposit wtc comp k = do let tsHash = wtc ^. wtcTransactionHash let totalEnergyToUse = wtc ^. wtcEnergyAmount @@ -1052,6 +1053,7 @@ withDeposit wtc comp k = do TransactionSummary { tsSender = Just (wtc ^. wtcSenderAddress), tsCost = payment, + tsSponsorDetails = conditionally cHasSponsorDetails Nothing, tsEnergyCost = usedEnergy, tsResult = addReturn $ transactionReject reason, tsType = TSTAccountTransaction $ Just $ wtc ^. wtcTransactionType, @@ -1066,11 +1068,14 @@ withDeposit wtc comp k = do Just $! TransactionSummary { tsSender = Just (wtc ^. wtcSenderAddress), + tsSponsorDetails = conditionally cHasSponsorDetails Nothing, tsType = TSTAccountTransaction $ Just $ wtc ^. wtcTransactionType, tsIndex = wtc ^. wtcTransactionIndex, tsResult = addReturn tsResult0, .. } + where + cHasSponsorDetails = sHasSponsorDetails (sTransactionOutcomesVersionFor (protocolVersion @(MPV m))) {-# INLINE defaultSuccess #-} diff --git a/concordium-consensus/src/Concordium/Scheduler/TreeStateEnvironment.hs b/concordium-consensus/src/Concordium/Scheduler/TreeStateEnvironment.hs index 69f73f8389..f01a35526e 100644 --- a/concordium-consensus/src/Concordium/Scheduler/TreeStateEnvironment.hs +++ b/concordium-consensus/src/Concordium/Scheduler/TreeStateEnvironment.hs @@ -1343,7 +1343,7 @@ constructBlock :: Maybe FinalizerInfo -> -- | New seed state SeedState (SeedStateVersionFor (MPV m)) -> - m (Sch.FilteredTransactions, ExecutionResult m) + m (Sch.FilteredTransactions (TransactionOutcomesVersionFor (MPV m)), ExecutionResult m) constructBlock slotNumber slotTime blockParent blockBaker mfinInfo newSeedState = let cm = ChainMetadata{..} in do diff --git a/concordium-consensus/src/Concordium/Scheduler/Types.hs b/concordium-consensus/src/Concordium/Scheduler/Types.hs index ae7247241f..a4e2e8fba1 100644 --- a/concordium-consensus/src/Concordium/Scheduler/Types.hs +++ b/concordium-consensus/src/Concordium/Scheduler/Types.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DataKinds #-} + module Concordium.Scheduler.Types ( module Concordium.Scheduler.Types, module Concordium.Types, @@ -28,9 +30,9 @@ import Concordium.ID.Types (IdentityProviderIdentity) import qualified Concordium.TransactionVerification as TVer -- | Result of constructing a block from 'GroupedTransactions'. -data FilteredTransactions = FilteredTransactions +data FilteredTransactions (tov :: TransactionOutcomesVersion) = FilteredTransactions { -- | Transactions which have been added to the block, in the order added, with results. - ftAdded :: [(TVer.BlockItemWithStatus, TransactionSummary)], + ftAdded :: [(TVer.BlockItemWithStatus, TransactionSummary tov)], -- | Transactions which failed. No order is guaranteed. ftFailed :: [(TVer.TransactionWithStatus, FailureKind)], -- | Credential deployments which failed. No order is guaranteed. @@ -46,7 +48,7 @@ data FilteredTransactions = FilteredTransactions } deriving (Show) -emptyFilteredTransactions :: FilteredTransactions +emptyFilteredTransactions :: FilteredTransactions tov emptyFilteredTransactions = FilteredTransactions [] [] [] [] [] [] [] type GroupedTransactions = [TransactionGroup] diff --git a/concordium-consensus/src/Concordium/Types/TransactionOutcomes.hs b/concordium-consensus/src/Concordium/Types/TransactionOutcomes.hs index b1c13db00a..67a9350887 100644 --- a/concordium-consensus/src/Concordium/Types/TransactionOutcomes.hs +++ b/concordium-consensus/src/Concordium/Types/TransactionOutcomes.hs @@ -27,25 +27,25 @@ import Concordium.Utils.Serialization -- | Outcomes of transactions. The vector of outcomes must have the same size as the -- number of transactions in the block, and ordered in the same way. -data TransactionOutcomes = TransactionOutcomes - { outcomeValues :: !(Vec.Vector TransactionSummary), +data TransactionOutcomes (tov :: TransactionOutcomesVersion) = TransactionOutcomes + { outcomeValues :: !(Vec.Vector (TransactionSummary tov)), _outcomeSpecial :: !(Seq.Seq SpecialTransactionOutcome) } makeLenses ''TransactionOutcomes -instance Show TransactionOutcomes where +instance Show (TransactionOutcomes tov) where show (TransactionOutcomes v s) = "Normal transactions: " ++ show (Vec.toList v) ++ ", special transactions: " ++ show s -putTransactionOutcomes :: S.Putter TransactionOutcomes +putTransactionOutcomes :: S.Putter (TransactionOutcomes tov) putTransactionOutcomes TransactionOutcomes{..} = do putListOf putTransactionSummary (Vec.toList outcomeValues) S.put _outcomeSpecial -getTransactionOutcomes :: SProtocolVersion pv -> S.Get TransactionOutcomes +getTransactionOutcomes :: SProtocolVersion pv -> S.Get (TransactionOutcomes (TransactionOutcomesVersionFor pv)) getTransactionOutcomes spv = TransactionOutcomes <$> (Vec.fromList <$> getListOf (getTransactionSummary spv)) <*> S.get -instance HashableTo (TransactionOutcomesHashV 'TOV0) TransactionOutcomes where +instance HashableTo (TransactionOutcomesHashV 'TOV0) (TransactionOutcomes 'TOV0) where getHash transactionoutcomes = TransactionOutcomesHashV . H.hash . S.runPut $ putTransactionOutcomes transactionoutcomes @@ -92,7 +92,7 @@ newtype TransactionOutcomesHashV (tov :: TransactionOutcomesVersion) = Transacti toTransactionOutcomesHash :: TransactionOutcomesHashV tov -> TransactionOutcomesHash toTransactionOutcomesHash = TransactionOutcomesHash . theTransactionOutcomesHashV -emptyTransactionOutcomesV0 :: TransactionOutcomes +emptyTransactionOutcomesV0 :: TransactionOutcomes 'TOV0 emptyTransactionOutcomesV0 = TransactionOutcomes Vec.empty Seq.empty -- | Hash of the empty V0 transaction outcomes structure. This transaction outcomes @@ -123,22 +123,34 @@ emptyTransactionOutcomesHashV2 = S.putWord64be 0 S.put (H.hash "EmptyLFMBTree") +-- | Hash of the empty V3 transaction outcomes structure. This transaction outcomes +-- structure is used starting in protocol version 10. +emptyTransactionOutcomesHashV3 :: TransactionOutcomesHashV 'TOV3 +{-# NOINLINE emptyTransactionOutcomesHashV3 #-} +emptyTransactionOutcomesHashV3 = + TransactionOutcomesHashV $ H.hashOfHashes emptyHash emptyHash + where + emptyHash = H.hash $ S.runPut $ do + S.putWord64be 0 + S.put (H.hash "EmptyLFMBTree") + emptyTransactionOutcomesHashV :: STransactionOutcomesVersion tov -> TransactionOutcomesHashV tov emptyTransactionOutcomesHashV stov = case stov of STOV0 -> emptyTransactionOutcomesHashV0 STOV1 -> emptyTransactionOutcomesHashV1 STOV2 -> emptyTransactionOutcomesHashV2 + STOV3 -> emptyTransactionOutcomesHashV3 -transactionOutcomesV0FromList :: [TransactionSummary] -> TransactionOutcomes +transactionOutcomesV0FromList :: [TransactionSummary tov] -> TransactionOutcomes tov transactionOutcomesV0FromList l = let outcomeValues = Vec.fromList l _outcomeSpecial = Seq.empty in TransactionOutcomes{..} -type instance Index TransactionOutcomes = TransactionIndex -type instance IxValue TransactionOutcomes = TransactionSummary +type instance Index (TransactionOutcomes tov) = TransactionIndex +type instance IxValue (TransactionOutcomes tov) = TransactionSummary tov -instance Ixed TransactionOutcomes where +instance Ixed (TransactionOutcomes tov) where ix idx f outcomes@TransactionOutcomes{..} = let x = fromIntegral idx in if x >= length outcomeValues diff --git a/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/Consensus/Blocks.hs b/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/Consensus/Blocks.hs index c9dc238f67..80c01e375c 100644 --- a/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/Consensus/Blocks.hs +++ b/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/Consensus/Blocks.hs @@ -275,7 +275,7 @@ firstTimeoutMessageFor sProtocolVersion qc curRound curEpoch = -- | Helper to compute the transaction outcomes hash for a given set of transaction outcomes and -- special transaction outcomes. transactionOutcomesHashV1 :: - [TransactionSummaryV1] -> + [TransactionSummaryV1 tov] -> [Transactions.SpecialTransactionOutcome] -> TransactionOutcomes.TransactionOutcomesHash transactionOutcomesHashV1 outcomes specialOutcomes = diff --git a/concordium-consensus/tests/globalstate/GlobalStateTests/BlockHash.hs b/concordium-consensus/tests/globalstate/GlobalStateTests/BlockHash.hs index 436748f99b..a6d10ed43c 100644 --- a/concordium-consensus/tests/globalstate/GlobalStateTests/BlockHash.hs +++ b/concordium-consensus/tests/globalstate/GlobalStateTests/BlockHash.hs @@ -108,21 +108,21 @@ defaultHash = Block.generateBlockHash slot parent bakerid bakerSVK blockP nonce -- (Note that this test does not perform any of such actions, -- hence it's ok to simply have the instance functions be -- defined as undefined.) -newtype DummyHashMonad a = DummyHashMonad {runDummyHashMonad :: a} +newtype DummyHashMonad (pv :: ProtocolVersion) a = DummyHashMonad {runDummyHashMonad :: a} deriving (Functor, Applicative, Monad) via Identity -instance MonadIO DummyHashMonad where +instance MonadIO (DummyHashMonad (pv :: ProtocolVersion)) where liftIO = undefined -instance MonadBlobStore DummyHashMonad where +instance MonadBlobStore (DummyHashMonad (pv :: ProtocolVersion)) where storeRaw = undefined loadRaw = undefined flushStore = undefined getCallbacks = undefined loadBlobPtr = undefined -instance MonadProtocolVersion DummyHashMonad where - type MPV DummyHashMonad = 'P6 +instance (IsProtocolVersion pv, IsCompatibleAuthorizationsVersion (ChainParametersVersionFor pv) (AuthorizationsVersionFor pv) ~ 'True) => MonadProtocolVersion (DummyHashMonad (pv :: ProtocolVersion)) where + type MPV (DummyHashMonad pv) = pv tests :: Spec tests = do @@ -197,13 +197,18 @@ tests = do defaultHash `shouldNotBe` hash' specify "Hash of emptyPersistentTransactionOutcomes (TOV0) is hash of emptyTransactionOutcomesV0" $ - runDummyHashMonad (getHashM (emptyPersistentTransactionOutcomes @'TOV0)) - `shouldBe` getHash @(TransactionOutcomesHashV 'TOV0) emptyTransactionOutcomesV0 + runDummyHashMonad @'P4 (getHashM (emptyPersistentTransactionOutcomes @'TOV0)) + `shouldBe` emptyTransactionOutcomesHashV0 specify "Hash of emptyPersistentTransactionOutcomes (TOV1) is emptyTransactionOutcomesHashV1" $ - runDummyHashMonad (getHashM (emptyPersistentTransactionOutcomes @'TOV1)) + runDummyHashMonad @'P6 (getHashM (emptyPersistentTransactionOutcomes @'TOV1)) `shouldBe` emptyTransactionOutcomesHashV1 specify "Hash of emptyPersistentTransactionOutcomes (TOV2) is emptyTransactionOutcomesHashV2" $ - runDummyHashMonad (getHashM (emptyPersistentTransactionOutcomes @'TOV2)) + runDummyHashMonad @'P9 (getHashM (emptyPersistentTransactionOutcomes @'TOV2)) `shouldBe` emptyTransactionOutcomesHashV2 + +-- TODO (RUN-18): Turn on tests for P10. +-- specify "Hash of emptyPersistentTransactionOutcomes (TOV3) is emptyTransactionOutcomesHashV3" $ +-- runDummyHashMonad @'P10 (getHashM (emptyPersistentTransactionOutcomes @'TOV3)) +-- `shouldBe` emptyTransactionOutcomesHashV3 diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/AccountTransactionSpecs.hs b/concordium-consensus/tests/scheduler/SchedulerTests/AccountTransactionSpecs.hs index a5c8aaf665..099769cb98 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/AccountTransactionSpecs.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/AccountTransactionSpecs.hs @@ -104,7 +104,7 @@ testAccountCreation _ pvString = specify (map snd ftFailedCredentials) assertEqual "Execution cost should be 0." 0 srExecutionCosts where - checkState :: Helpers.SchedulerResult -> BS.PersistentBlockState pv -> Helpers.PersistentBSM pv Assertion + checkState :: Helpers.SchedulerResult (Types.TransactionOutcomesVersionFor pv) -> BS.PersistentBlockState pv -> Helpers.PersistentBSM pv Assertion checkState _ state = do doInvariantAssertions <- Helpers.assertBlockStateInvariantsH state 0 let addedAccountAddresses = diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/BakerTransactions.hs b/concordium-consensus/tests/scheduler/SchedulerTests/BakerTransactions.hs index 4bc7086eb5..1955bb1a5c 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/BakerTransactions.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/BakerTransactions.hs @@ -269,6 +269,7 @@ tests = do txs <- liftIO (processUngroupedTransactions transactionsInput) (outcomes, endState) <- Helpers.runSchedulerTestWithIntermediateStates + @(Types.TransactionOutcomesVersionFor PV1) @PV1 Helpers.defaultTestConfig initialBlockState diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/BlockEnergyLimitSpec.hs b/concordium-consensus/tests/scheduler/SchedulerTests/BlockEnergyLimitSpec.hs index 54e85694d0..4a54c58747 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/BlockEnergyLimitSpec.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/BlockEnergyLimitSpec.hs @@ -138,7 +138,7 @@ testMaxBlockEnergy _ pvString = specify (pvString ++ ": One valid, two invalid, doBlockStateAssertions where checkState :: - Helpers.SchedulerResult -> + Helpers.SchedulerResult (Types.TransactionOutcomesVersionFor pv) -> BS.PersistentBlockState pv -> Helpers.PersistentBSM pv Assertion checkState result state = do @@ -150,7 +150,7 @@ testMaxBlockEnergy _ pvString = specify (pvString ++ ": One valid, two invalid, doAssertReloadedState blockStateAssertions :: - Helpers.SchedulerResult -> + Helpers.SchedulerResult (Types.TransactionOutcomesVersionFor pv) -> BS.PersistentBlockState pv -> Helpers.PersistentBSM pv Assertion blockStateAssertions result state = do diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/ChainMetatest.hs b/concordium-consensus/tests/scheduler/SchedulerTests/ChainMetatest.hs index 5e483c05c5..ea6e37bbff 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/ChainMetatest.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/ChainMetatest.hs @@ -79,7 +79,7 @@ testChainMeta _ pvString = doBlockStateAssertions where checkState :: - Helpers.SchedulerResult -> + Helpers.SchedulerResult (Types.TransactionOutcomesVersionFor pv) -> BS.PersistentBlockState pv -> Helpers.PersistentBSM pv Assertion checkState result state = do diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/ConfigureBaker.hs b/concordium-consensus/tests/scheduler/SchedulerTests/ConfigureBaker.hs index 486250c982..4489a1322f 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/ConfigureBaker.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/ConfigureBaker.hs @@ -300,7 +300,7 @@ testDelegatorToBakerOk spv pvString = transactionEnergy = Cost.configureBakerCostWithKeys + Cost.baseCost 438 1 checkState :: BakerKeysWithProofs -> - Helpers.SchedulerResult -> + Helpers.SchedulerResult (Types.TransactionOutcomesVersionFor pv) -> BS.PersistentBlockState pv -> Helpers.PersistentBSM pv Assertion checkState keysWithProofs result blockState = do @@ -404,7 +404,7 @@ testDelegatorToBakerDuplicateKey spv pvString = -- Transaction length is 438 bytes (378 bytes for the transaction and 60 bytes for the header). transactionEnergy = Cost.configureBakerCostWithKeys + Cost.baseCost 438 1 checkState :: - Helpers.SchedulerResult -> + Helpers.SchedulerResult (Types.TransactionOutcomesVersionFor pv) -> BS.PersistentBlockState pv -> Helpers.PersistentBSM pv Assertion checkState result blockState = do @@ -465,7 +465,7 @@ testDelegatorToBakerMissingParam spv pvString = -- Transaction length is 437 bytes (378 bytes for the transaction and 60 bytes for the header). transactionEnergy = Cost.configureBakerCostWithKeys + Cost.baseCost 437 1 checkState :: - Helpers.SchedulerResult -> + Helpers.SchedulerResult (Types.TransactionOutcomesVersionFor pv) -> BS.PersistentBlockState pv -> Helpers.PersistentBSM pv Assertion checkState result blockState = do @@ -566,7 +566,7 @@ testAddBakerOk spv pvString = transactionEnergy = Cost.configureBakerCostWithKeys + Cost.baseCost 439 1 checkState :: BakerKeysWithProofs -> - Helpers.SchedulerResult -> + Helpers.SchedulerResult (Types.TransactionOutcomesVersionFor pv) -> BS.PersistentBlockState pv -> Helpers.PersistentBSM pv Assertion checkState keysWithProofs result blockState = do @@ -660,7 +660,7 @@ testAddBakerInsufficientBalance _spv pvString = -- Transaction length is 438 bytes (379 bytes for the transaction and 60 bytes for the header). transactionEnergy = Cost.configureBakerCostWithKeys + Cost.baseCost 439 1 checkState :: - Helpers.SchedulerResult -> + Helpers.SchedulerResult (Types.TransactionOutcomesVersionFor pv) -> BS.PersistentBlockState pv -> Helpers.PersistentBSM pv Assertion checkState result blockState = do @@ -719,7 +719,7 @@ testAddBakerMissingParam _spv pvString = -- Transaction length is 437 bytes (377 bytes for the transaction and 60 bytes for the header). transactionEnergy = Cost.configureBakerCostWithKeys + Cost.baseCost 437 1 checkState :: - Helpers.SchedulerResult -> + Helpers.SchedulerResult (Types.TransactionOutcomesVersionFor pv) -> BS.PersistentBlockState pv -> Helpers.PersistentBSM pv Assertion checkState result blockState = do @@ -778,7 +778,7 @@ testAddBakerInvalidProofs _spv pvString = -- Transaction length is 438 bytes (379 bytes for the transaction and 60 bytes for the header). transactionEnergy = Cost.configureBakerCostWithKeys + Cost.baseCost 439 1 checkState :: - Helpers.SchedulerResult -> + Helpers.SchedulerResult (Types.TransactionOutcomesVersionFor pv) -> BS.PersistentBlockState pv -> Helpers.PersistentBSM pv Assertion checkState result blockState = do @@ -862,7 +862,7 @@ testUpdateBakerOk _spv pvString = -- Transaction length is 79 bytes (19 bytes for the transaction and 60 bytes for the header). transactionEnergy = Cost.configureBakerCostWithoutKeys + Cost.baseCost 79 1 checkState :: - Helpers.SchedulerResult -> + Helpers.SchedulerResult (Types.TransactionOutcomesVersionFor pv) -> BS.PersistentBlockState pv -> Helpers.PersistentBSM pv Assertion checkState result blockState = do @@ -932,7 +932,7 @@ testUpdateBakerInsufficientBalance _spv pvString = -- Transaction length is 79 bytes (19 bytes for the transaction and 60 bytes for the header). transactionEnergy = Cost.configureBakerCostWithoutKeys + Cost.baseCost 79 1 checkState :: - Helpers.SchedulerResult -> + Helpers.SchedulerResult (Types.TransactionOutcomesVersionFor pv) -> BS.PersistentBlockState pv -> Helpers.PersistentBSM pv Assertion checkState result blockState = do @@ -989,7 +989,7 @@ testUpdateBakerLowStake _spv pvString = -- Transaction length is 79 bytes (19 bytes for the transaction and 60 bytes for the header). transactionEnergy = Cost.configureBakerCostWithoutKeys + Cost.baseCost 79 1 checkState :: - Helpers.SchedulerResult -> + Helpers.SchedulerResult (Types.TransactionOutcomesVersionFor pv) -> BS.PersistentBlockState pv -> Helpers.PersistentBSM pv Assertion checkState result blockState = do @@ -1047,7 +1047,7 @@ testUpdateBakerInvalidProofs _spv pvString = -- Transaction length is 415 bytes (355 bytes for the transaction and 60 bytes for the header). transactionEnergy = Cost.configureBakerCostWithKeys + Cost.baseCost 415 1 checkState :: - Helpers.SchedulerResult -> + Helpers.SchedulerResult (Types.TransactionOutcomesVersionFor pv) -> BS.PersistentBlockState pv -> Helpers.PersistentBSM pv Assertion checkState result blockState = do @@ -1108,7 +1108,7 @@ testUpdateBakerRemoveOk spv pvString = -- Transaction length is 71 bytes (11 bytes for the transaction and 60 bytes for the header). transactionEnergy = Cost.configureBakerCostWithoutKeys + Cost.baseCost 71 1 checkState :: - Helpers.SchedulerResult -> + Helpers.SchedulerResult (Types.TransactionOutcomesVersionFor pv) -> BS.PersistentBlockState pv -> Helpers.PersistentBSM pv Assertion checkState result blockState = do @@ -1200,7 +1200,7 @@ testUpdateBakerReduceStakeOk spv pvString = transactionEnergy = Cost.configureBakerCostWithKeys + Cost.baseCost 431 1 checkState :: BakerKeysWithProofs -> - Helpers.SchedulerResult -> + Helpers.SchedulerResult (Types.TransactionOutcomesVersionFor pv) -> BS.PersistentBlockState pv -> Helpers.PersistentBSM pv Assertion checkState keysWithProofs result blockState = do @@ -1281,7 +1281,7 @@ testUpdateBakerSuspendResumeOk spv pvString suspendOrResume accM = -- Transaction length is 64 bytes (4 bytes for the transaction and 60 bytes for the header). transactionEnergy = Cost.configureBakerCostWithoutKeys + Cost.baseCost 64 1 checkState :: - Helpers.SchedulerResult -> + Helpers.SchedulerResult (Types.TransactionOutcomesVersionFor pv) -> BS.PersistentBlockState pv -> Helpers.PersistentBSM pv Assertion checkState result blockState = do diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/Delegation.hs b/concordium-consensus/tests/scheduler/SchedulerTests/Delegation.hs index bad4449195..d9267159c4 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/Delegation.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/Delegation.hs @@ -258,7 +258,7 @@ testRemoveDelegatorWithStakeOverThreshold _ pvString = doBlockStateAssertions where checkState :: - Helpers.SchedulerResult -> + Helpers.SchedulerResult (Types.TransactionOutcomesVersionFor pv) -> BS.PersistentBlockState pv -> Helpers.PersistentBSM pv Assertion checkState result blockState = do @@ -295,7 +295,7 @@ testReduceDelegatorStakeStillAboveCapThreshold _ pvString = doBlockStateAssertions where checkState :: - Helpers.SchedulerResult -> + Helpers.SchedulerResult (Types.TransactionOutcomesVersionFor pv) -> BS.PersistentBlockState pv -> Helpers.PersistentBSM pv Assertion checkState result blockState = @@ -332,7 +332,7 @@ testTransactionRejectsIfStakeIncreasedOverThreshold _ pvString = doBlockStateAssertions where checkState :: - Helpers.SchedulerResult -> + Helpers.SchedulerResult (Types.TransactionOutcomesVersionFor pv) -> BS.PersistentBlockState pv -> Helpers.PersistentBSM pv Assertion checkState result blockState = @@ -370,7 +370,7 @@ testReducingStakeAndTargetNewStakeOverCap _ pvString = doBlockStateAssertions where checkState :: - Helpers.SchedulerResult -> + Helpers.SchedulerResult (Types.TransactionOutcomesVersionFor pv) -> BS.PersistentBlockState pv -> Helpers.PersistentBSM pv Assertion checkState result blockState = @@ -418,7 +418,7 @@ testChangingTargetAndReducingStake _ pvString = doBlockStateAssertions where checkState :: - Helpers.SchedulerResult -> + Helpers.SchedulerResult (Types.TransactionOutcomesVersionFor pv) -> BS.PersistentBlockState pv -> Helpers.PersistentBSM pv Assertion checkState result blockState = @@ -455,7 +455,7 @@ testIncreaseStake _ pvString = doBlockStateAssertions where checkState :: - Helpers.SchedulerResult -> + Helpers.SchedulerResult (Types.TransactionOutcomesVersionFor pv) -> BS.PersistentBlockState pv -> Helpers.PersistentBSM pv Assertion checkState result blockState = @@ -496,7 +496,7 @@ testIncreaseStakeAndTarget _ pvString = doBlockStateAssertions where checkState :: - Helpers.SchedulerResult -> + Helpers.SchedulerResult (Types.TransactionOutcomesVersionFor pv) -> BS.PersistentBlockState pv -> Helpers.PersistentBSM pv Assertion checkState result blockState = @@ -533,7 +533,7 @@ testIncreaseStakeAndChangeTargetReject _ pvString = doBlockStateAssertions where checkState :: - Helpers.SchedulerResult -> + Helpers.SchedulerResult (Types.TransactionOutcomesVersionFor pv) -> BS.PersistentBlockState pv -> Helpers.PersistentBSM pv Assertion checkState result blockState = @@ -570,7 +570,7 @@ testChangeTargetToOverdelegatedPool _ pvString = doBlockStateAssertions where checkState :: - Helpers.SchedulerResult -> + Helpers.SchedulerResult (Types.TransactionOutcomesVersionFor pv) -> BS.PersistentBlockState pv -> Helpers.PersistentBSM pv Assertion checkState result blockState = @@ -607,7 +607,7 @@ testAddDelegator _ pvString = doBlockStateAssertions where checkState :: - Helpers.SchedulerResult -> + Helpers.SchedulerResult (Types.TransactionOutcomesVersionFor pv) -> BS.PersistentBlockState pv -> Helpers.PersistentBSM pv Assertion checkState result blockState = @@ -650,7 +650,7 @@ testDelegatorWithZeroStake _ pvString = doBlockStateAssertions where checkState :: - Helpers.SchedulerResult -> + Helpers.SchedulerResult (Types.TransactionOutcomesVersionFor pv) -> BS.PersistentBlockState pv -> Helpers.PersistentBSM pv Assertion checkState result blockState = @@ -691,7 +691,7 @@ testAddDelegatorWhenAlreadyBaker spv pvString = doBlockStateAssertions where checkState :: - Helpers.SchedulerResult -> + Helpers.SchedulerResult (Types.TransactionOutcomesVersionFor pv) -> BS.PersistentBlockState pv -> Helpers.PersistentBSM pv Assertion checkState result blockState = @@ -739,7 +739,7 @@ testAddDelegatorWithZeroStakeWhenAlreadyBaker spv pvString = doBlockStateAssertions where checkState :: - Helpers.SchedulerResult -> + Helpers.SchedulerResult (Types.TransactionOutcomesVersionFor pv) -> BS.PersistentBlockState pv -> Helpers.PersistentBSM pv Assertion checkState result blockState = do @@ -905,7 +905,7 @@ testDelegateToSelf spv pvString = doBlockStateAssertions where checkState :: - Helpers.SchedulerResult -> + Helpers.SchedulerResult (Types.TransactionOutcomesVersionFor pv) -> BS.PersistentBlockState pv -> Helpers.PersistentBSM pv Assertion checkState result blockState = do diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/FibonacciSelfMessageTest.hs b/concordium-consensus/tests/scheduler/SchedulerTests/FibonacciSelfMessageTest.hs index 4ba99ff55a..4c6faac786 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/FibonacciSelfMessageTest.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/FibonacciSelfMessageTest.hs @@ -111,7 +111,7 @@ testCase1 _ pvString = } ] ensureAllUpdates :: - Helpers.SchedulerResult -> + Helpers.SchedulerResult (Types.TransactionOutcomesVersionFor pv) -> BS.PersistentBlockState pv -> Helpers.PersistentBSM pv Assertion ensureAllUpdates Helpers.SchedulerResult{..} bs = do diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/Helpers.hs b/concordium-consensus/tests/scheduler/SchedulerTests/Helpers.hs index dae2de8855..75785d5e28 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/Helpers.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/Helpers.hs @@ -61,7 +61,7 @@ import qualified Concordium.Scheduler.Types as Types import Concordium.TimeMonad import Concordium.Types (SProtocolVersion) -getResults :: [(a, Types.TransactionSummary)] -> [(a, Types.ValidResult)] +getResults :: [(a, Types.TransactionSummary tov)] -> [(a, Types.ValidResult)] getResults = map (\(x, r) -> (x, Types.tsResult r)) -- | The cost for processing a simple transfer (account to account) @@ -246,9 +246,9 @@ defaultContextState = } -- | Result from running the scheduler in a test environment. -data SchedulerResult = SchedulerResult +data SchedulerResult (tov :: Types.TransactionOutcomesVersion) = SchedulerResult { -- | The outcome for constructing a block. - srTransactions :: FilteredTransactions, + srTransactions :: FilteredTransactions tov, -- | The total execution cost of the block. srExecutionCosts :: Types.Amount, -- | The total execution energy of the block. @@ -263,7 +263,7 @@ runScheduler :: TestConfig -> BS.HashedPersistentBlockState pv -> Types.GroupedTransactions -> - PersistentBSM pv (SchedulerResult, BS.PersistentBlockState pv) + PersistentBSM pv (SchedulerResult (Types.TransactionOutcomesVersionFor pv), BS.PersistentBlockState pv) runScheduler TestConfig{..} stateBefore transactions = do blockStateBefore <- BS.thawBlockState stateBefore let txs = filterTransactions tcBlockSize (Time.timestampToUTCTime tcBlockTimeout) transactions @@ -289,12 +289,12 @@ runSchedulerTest :: (Types.IsProtocolVersion pv) => TestConfig -> PersistentBSM pv (BS.HashedPersistentBlockState pv) -> - (SchedulerResult -> BS.PersistentBlockState pv -> PersistentBSM pv a) -> + (SchedulerResult (Types.TransactionOutcomesVersionFor pv) -> BS.PersistentBlockState pv -> PersistentBSM pv a) -> Types.GroupedTransactions -> - IO (SchedulerResult, a) + IO (SchedulerResult (Types.TransactionOutcomesVersionFor pv), a) runSchedulerTest config constructState extractor transactions = runTestBlockState computation where - computation :: PersistentBSM pv (SchedulerResult, a) + computation :: PersistentBSM pv (SchedulerResult (Types.TransactionOutcomesVersionFor pv), a) computation = do blockStateBefore <- constructState (result, blockStateAfter) <- runScheduler config blockStateBefore transactions @@ -310,9 +310,9 @@ runSchedulerTestTransactionJson :: (Types.IsProtocolVersion pv) => TestConfig -> PersistentBSM pv (BS.HashedPersistentBlockState pv) -> - (SchedulerResult -> BS.PersistentBlockState pv -> PersistentBSM pv a) -> + (SchedulerResult (Types.TransactionOutcomesVersionFor pv) -> BS.PersistentBlockState pv -> PersistentBSM pv a) -> [SchedTest.TransactionJSON] -> - IO (SchedulerResult, a) + IO (SchedulerResult (Types.TransactionOutcomesVersionFor pv), a) runSchedulerTestTransactionJson config constructState extractor transactionJsonList = do transactions <- SchedTest.processUngroupedTransactions transactionJsonList runSchedulerTest config constructState extractor transactions @@ -320,7 +320,7 @@ runSchedulerTestTransactionJson config constructState extractor transactionJsonL -- | Check assertions on the result of running a transaction in the scheduler and the resulting -- block state. type TransactionAssertion pv = - SchedulerResult -> + SchedulerResult (Types.TransactionOutcomesVersionFor pv) -> BS.PersistentBlockState pv -> PersistentBSM pv Assertion @@ -373,26 +373,26 @@ runSchedulerTestAssertIntermediateStates config constructState transactionsAndAs return (nextAssertedSoFar, nextState, nextCostsSoFar) -- | Intermediate results collected while running a number of transactions. -type IntermediateResults a = [(SchedulerResult, a)] +type IntermediateResults (tov :: Types.TransactionOutcomesVersion) a = [(SchedulerResult tov, a)] -- | Run the scheduler on transactions in a test environment, while collecting all of the -- intermediate results and extracted values. runSchedulerTestWithIntermediateStates :: - forall pv a. - (Types.IsProtocolVersion pv) => + forall tov pv a. + (Types.IsProtocolVersion pv, tov ~ Types.TransactionOutcomesVersionFor pv) => TestConfig -> PersistentBSM pv (BS.HashedPersistentBlockState pv) -> - (SchedulerResult -> BS.PersistentBlockState pv -> PersistentBSM pv a) -> + (SchedulerResult tov -> BS.PersistentBlockState pv -> PersistentBSM pv a) -> Types.GroupedTransactions -> - PersistentBSM pv (IntermediateResults a, BS.HashedPersistentBlockState pv) + PersistentBSM pv (IntermediateResults tov a, BS.HashedPersistentBlockState pv) runSchedulerTestWithIntermediateStates config constructState extractor transactions = do blockStateBefore <- constructState foldM transactionRunner ([], blockStateBefore) transactions where transactionRunner :: - (IntermediateResults a, BS.HashedPersistentBlockState pv) -> + (IntermediateResults tov a, BS.HashedPersistentBlockState pv) -> Types.TransactionGroup -> - PersistentBSM pv (IntermediateResults a, BS.HashedPersistentBlockState pv) + PersistentBSM pv (IntermediateResults tov a, BS.HashedPersistentBlockState pv) transactionRunner (acc, currentState) tx = do (result, updatedState) <- runScheduler config currentState [tx] extracted <- extractor result updatedState @@ -751,11 +751,11 @@ readV1ModuleFile filePath = do return $ Wasm.WasmModuleV1 $ Wasm.WasmModuleV Wasm.ModuleSource{..} -- | Assert the scheduler result have added one successful transaction. -assertSuccess :: SchedulerResult -> Assertion +assertSuccess :: SchedulerResult tov -> Assertion assertSuccess = assertSuccessWhere (const (return ())) -- | Assert the scheduler result have added one successful transaction and check the events. -assertSuccessWhere :: ([Types.Event] -> Assertion) -> SchedulerResult -> Assertion +assertSuccessWhere :: ([Types.Event] -> Assertion) -> SchedulerResult tov -> Assertion assertSuccessWhere assertEvents result = case getResults $ ftAdded (srTransactions result) of [(_, Types.TxSuccess events)] -> @@ -766,7 +766,7 @@ assertSuccessWhere assertEvents result = -- | Assert the scheduler result have added one successful transaction and check the events are -- equal to the provided events. -assertSuccessWithEvents :: [Types.Event] -> SchedulerResult -> Assertion +assertSuccessWithEvents :: [Types.Event] -> SchedulerResult tov -> Assertion assertSuccessWithEvents expectedEvents = assertSuccessWhere (assertEqual "The correct event is produced" expectedEvents) @@ -776,7 +776,7 @@ assertNumberOfEvents expectedLength events = assertEqual "Correct number of events produced" expectedLength (length events) -- | Assert the scheduler result have added one rejected transaction and check the reason. -assertRejectWhere :: (Types.RejectReason -> Assertion) -> SchedulerResult -> Assertion +assertRejectWhere :: (Types.RejectReason -> Assertion) -> SchedulerResult tov -> Assertion assertRejectWhere assertReason result = case getResults $ ftAdded (srTransactions result) of [(_, Types.TxReject reason)] -> @@ -786,13 +786,13 @@ assertRejectWhere assertReason result = other -> assertFailure $ "Multiple transactions were added " ++ show other -- | Assert the scheduler result have added one rejected transaction and check the reason. -assertRejectWithReason :: Types.RejectReason -> SchedulerResult -> Assertion +assertRejectWithReason :: Types.RejectReason -> SchedulerResult tov -> Assertion assertRejectWithReason expectedReason = assertRejectWhere $ assertEqual "The correct reject reason is produced" expectedReason -- | Assert the scheduler result have failed one transaction and check the reason. -assertFailureWithReason :: Types.FailureKind -> SchedulerResult -> Assertion +assertFailureWithReason :: Types.FailureKind -> SchedulerResult tov -> Assertion assertFailureWithReason expectedReason result = case ftFailed $ srTransactions result of [(_, reason)] -> @@ -804,7 +804,7 @@ assertFailureWithReason expectedReason result = other -> assertFailure $ "Multiple transactions failed: " ++ show other -- | Assert the scheduler result has failed one chain update and check the reason. -assertUpdateFailureWithReason :: Types.FailureKind -> SchedulerResult -> Assertion +assertUpdateFailureWithReason :: Types.FailureKind -> SchedulerResult tov -> Assertion assertUpdateFailureWithReason expectedReason result = case ftFailedUpdates $ srTransactions result of [(_, reason)] -> @@ -818,7 +818,7 @@ assertUpdateFailureWithReason expectedReason result = -- | Assert the scheduler have used energy the exact energy needed to deploy a provided V0 smart -- contract module. Assuming the transaction was signed with a single signature. -- The provided module should be a WASM module and without the smart contract version prefix. -assertUsedEnergyDeploymentV0 :: FilePath -> SchedulerResult -> Assertion +assertUsedEnergyDeploymentV0 :: FilePath -> SchedulerResult tov -> Assertion assertUsedEnergyDeploymentV0 sourceFile result = do contractModule <- readV0ModuleFile sourceFile let len = fromIntegral $ ByteString.length $ Wasm.wasmSource contractModule @@ -838,7 +838,7 @@ assertUsedEnergyDeploymentV0 sourceFile result = do -- | Assert the scheduler have used energy the exact energy needed to deploy a provided V1 smart -- contract module. Assuming the transaction was signed with a single signature. -- The provided module should be a WASM module and without the smart contract version prefix. -assertUsedEnergyDeploymentV1 :: FilePath -> SchedulerResult -> Assertion +assertUsedEnergyDeploymentV1 :: FilePath -> SchedulerResult tov -> Assertion assertUsedEnergyDeploymentV1 sourceFile result = do contractModule <- readV0ModuleFile sourceFile let len = fromIntegral $ ByteString.length $ Wasm.wasmSource contractModule @@ -865,7 +865,7 @@ assertUsedEnergyInitialization :: Wasm.InitName -> Wasm.Parameter -> Maybe Wasm.ByteSize -> - SchedulerResult -> + SchedulerResult (Types.TransactionOutcomesVersionFor pv) -> Assertion assertUsedEnergyInitialization spv sourceFile initName parameter initialStateSize result = do moduleSource <- ByteString.readFile sourceFile diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/InitContextTest.hs b/concordium-consensus/tests/scheduler/SchedulerTests/InitContextTest.hs index b44fe64a94..791db6ba32 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/InitContextTest.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/InitContextTest.hs @@ -79,7 +79,7 @@ testInit spv pvString = specify doBlockStateAssertions where checkState :: - Helpers.SchedulerResult -> + Helpers.SchedulerResult (Types.TransactionOutcomesVersionFor pv) -> BS.PersistentBlockState pv -> Helpers.PersistentBSM pv Assertion checkState result state = do diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/InitialAccountCreationSpec.hs b/concordium-consensus/tests/scheduler/SchedulerTests/InitialAccountCreationSpec.hs index c08c16de56..746e3db7c5 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/InitialAccountCreationSpec.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/InitialAccountCreationSpec.hs @@ -54,7 +54,7 @@ testAccountCreation _ pvString = specify doAssertions where makeAssertions :: - Helpers.SchedulerResult -> + Helpers.SchedulerResult (Types.TransactionOutcomesVersionFor pv) -> BS.PersistentBlockState pv -> Helpers.PersistentBSM pv Assertion makeAssertions result state = do diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/RandomBakerTransactions.hs b/concordium-consensus/tests/scheduler/SchedulerTests/RandomBakerTransactions.hs index b4c7b08924..81e20dce4d 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/RandomBakerTransactions.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/RandomBakerTransactions.hs @@ -278,7 +278,7 @@ testTransactions spv = forAll makeTransactions (ioProperty . tt) Left f -> return $ counterexample f False Right _ -> return $ property True constructStateChecks :: - Helpers.SchedulerResult -> + Helpers.SchedulerResult (TransactionOutcomesVersionFor pv) -> BS.PersistentBlockState pv -> Helpers.PersistentBSM pv (Either String ()) constructStateChecks result state = do diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/ReceiveContextTest.hs b/concordium-consensus/tests/scheduler/SchedulerTests/ReceiveContextTest.hs index fc614ab619..1202052c33 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/ReceiveContextTest.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/ReceiveContextTest.hs @@ -124,7 +124,7 @@ testReceive _ pvString = doBlockStateAssertions where checkState :: - Helpers.SchedulerResult -> + Helpers.SchedulerResult (Types.TransactionOutcomesVersionFor pv) -> BS.PersistentBlockState pv -> Helpers.PersistentBSM pv Assertion checkState result state = do diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/RejectReasons.hs b/concordium-consensus/tests/scheduler/SchedulerTests/RejectReasons.hs index 0be77ef60a..aaa9e02abb 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/RejectReasons.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/RejectReasons.hs @@ -144,7 +144,7 @@ testRejectReasons _ pvString = doBlockStateAssertions where checkState :: - Helpers.SchedulerResult -> + Helpers.SchedulerResult (Types.TransactionOutcomesVersionFor pv) -> BS.PersistentBlockState pv -> Helpers.PersistentBSM pv Assertion checkState result state = do diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/RejectReasonsRustContract.hs b/concordium-consensus/tests/scheduler/SchedulerTests/RejectReasonsRustContract.hs index 5d0c9df8d4..29e2621c05 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/RejectReasonsRustContract.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/RejectReasonsRustContract.hs @@ -178,7 +178,7 @@ testRejectReasons _ pvString = ] checkState :: - Helpers.SchedulerResult -> + Helpers.SchedulerResult (Types.TransactionOutcomesVersionFor pv) -> BS.PersistentBlockState pv -> Helpers.PersistentBSM pv Assertion checkState result state = do diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/SimpleTransferSpec.hs b/concordium-consensus/tests/scheduler/SchedulerTests/SimpleTransferSpec.hs index 0ede730522..820e937068 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/SimpleTransferSpec.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/SimpleTransferSpec.hs @@ -105,7 +105,7 @@ testCase0 _ pvString = specify doBlockStateAssertions where checkState :: - Helpers.SchedulerResult -> + Helpers.SchedulerResult (Types.TransactionOutcomesVersionFor pv) -> BS.PersistentBlockState pv -> Helpers.PersistentBSM pv Assertion checkState result state = diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/SimpleTransfersTest.hs b/concordium-consensus/tests/scheduler/SchedulerTests/SimpleTransfersTest.hs index c1bcb2cd71..5804704450 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/SimpleTransfersTest.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/SimpleTransfersTest.hs @@ -73,7 +73,7 @@ transferWithMemoRejectTestP1 = specify doBlockStateAssertions where checkState :: - Helpers.SchedulerResult -> + Helpers.SchedulerResult (Types.TransactionOutcomesVersionFor Types.P1) -> BS.PersistentBlockState PV1 -> Helpers.PersistentBSM PV1 Assertion checkState result state = do @@ -167,7 +167,7 @@ simpleTransferTest _ pvString = specify doBlockStateAssertions where checkState :: - Helpers.SchedulerResult -> + Helpers.SchedulerResult (Types.TransactionOutcomesVersionFor pv) -> BS.PersistentBlockState pv -> Helpers.PersistentBSM pv Assertion checkState result state = do @@ -297,7 +297,7 @@ simpleTransferWithMemoTest _ pvString = specify doBlockStateAssertions where checkState :: - Helpers.SchedulerResult -> + Helpers.SchedulerResult (Types.TransactionOutcomesVersionFor pv) -> BS.PersistentBlockState pv -> Helpers.PersistentBSM pv Assertion checkState result state = do @@ -409,7 +409,7 @@ simpleTransferUsingAccountAliasesTest _ pvString = specify doBlockStateAssertions where checkState :: - Helpers.SchedulerResult -> + Helpers.SchedulerResult (Types.TransactionOutcomesVersionFor pv) -> BS.PersistentBlockState pv -> Helpers.PersistentBSM pv Assertion checkState result state = do diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V0/SmartContractTests.hs b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V0/SmartContractTests.hs index 122d6f6a92..4967772a91 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V0/SmartContractTests.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/SmartContracts/V0/SmartContractTests.hs @@ -54,7 +54,7 @@ runInitTestsFromFile :: Types.SProtocolVersion pv -> String -> FilePath -> - [(Text, BSS.ShortByteString, Helpers.SchedulerResult -> Assertion)] -> + [(Text, BSS.ShortByteString, Helpers.SchedulerResult (Types.TransactionOutcomesVersionFor pv) -> Assertion)] -> Spec runInitTestsFromFile _ testCaseDescription testFile testCases = describe testCaseDescription $ @@ -110,7 +110,7 @@ runReceiveTestsFromFile :: Types.SProtocolVersion pv -> String -> FilePath -> - [(Text, BSS.ShortByteString, Helpers.SchedulerResult -> Assertion)] -> + [(Text, BSS.ShortByteString, Helpers.SchedulerResult (Types.TransactionOutcomesVersionFor pv) -> Assertion)] -> Spec runReceiveTestsFromFile _ testCaseDescription testFile testCases = describe testCaseDescription $ diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/StakedAmountLocked.hs b/concordium-consensus/tests/scheduler/SchedulerTests/StakedAmountLocked.hs index 29fd1cb303..2d8eddc202 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/StakedAmountLocked.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/StakedAmountLocked.hs @@ -135,7 +135,7 @@ testCase0 _ pvString = doBlockStateAssertions where checkState :: - Helpers.SchedulerResult -> + Helpers.SchedulerResult (Types.TransactionOutcomesVersionFor pv) -> BS.PersistentBlockState pv -> Helpers.PersistentBSM pv Assertion checkState result blockState = diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/TokenModule.hs b/concordium-consensus/tests/scheduler/SchedulerTests/TokenModule.hs index d7e755abd0..433f3196e9 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/TokenModule.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/TokenModule.hs @@ -1598,7 +1598,7 @@ testTokenOutOfEnergy = describe "tokenOutOfEnergy" $ do } ] checkState :: - Helpers.SchedulerResult -> + Helpers.SchedulerResult (Types.TransactionOutcomesVersionFor P9) -> BS.PersistentBlockState 'P9 -> Helpers.PersistentBSM 'P9 Assertion checkState result state = do @@ -1610,7 +1610,7 @@ testTokenOutOfEnergy = describe "tokenOutOfEnergy" $ do doAssertReloadedState blockStateAssertions :: - Helpers.SchedulerResult -> + Helpers.SchedulerResult (Types.TransactionOutcomesVersionFor P9) -> BS.PersistentBlockState 'P9 -> Helpers.PersistentBSM 'P9 Assertion blockStateAssertions result state = do diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/TransactionExpirySpec.hs b/concordium-consensus/tests/scheduler/SchedulerTests/TransactionExpirySpec.hs index 22a2bb41ff..bff0a5a666 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/TransactionExpirySpec.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/TransactionExpirySpec.hs @@ -169,7 +169,7 @@ testExpiryTime expiry transactions _ = isExpired _ = False checkState :: - Helpers.SchedulerResult -> + Helpers.SchedulerResult (Types.TransactionOutcomesVersionFor pv) -> BS.PersistentBlockState pv -> Helpers.PersistentBSM pv Assertion checkState result blockstate = diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/TransactionGroupingSpec2.hs b/concordium-consensus/tests/scheduler/SchedulerTests/TransactionGroupingSpec2.hs index c5184deafb..6d0533170a 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/TransactionGroupingSpec2.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/TransactionGroupingSpec2.hs @@ -315,7 +315,7 @@ testGroups _ groups = do return (Helpers.getResults ftAdded, ftFailed, ftUnprocessed, concat (Types.perAccountTransactions ts)) where checkState :: - Helpers.SchedulerResult -> + Helpers.SchedulerResult (Types.TransactionOutcomesVersionFor pv) -> BS.PersistentBlockState pv -> Helpers.PersistentBSM pv Assertion checkState result blockstate = diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/TransfersWithScheduleTest.hs b/concordium-consensus/tests/scheduler/SchedulerTests/TransfersWithScheduleTest.hs index e9907476b0..e3de27830e 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/TransfersWithScheduleTest.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/TransfersWithScheduleTest.hs @@ -73,7 +73,7 @@ scheduledTransferWithMemoRejectsP1 = doBlockStateAssertions where checkState :: - Helpers.SchedulerResult -> + Helpers.SchedulerResult (Types.TransactionOutcomesVersionFor Types.P1) -> BS.PersistentBlockState PV1 -> Helpers.PersistentBSM PV1 Assertion checkState result state = @@ -336,7 +336,7 @@ scheduledTransferRejectsSelfTransferUsingAliases _ pvString = doBlockStateAssertions where checkState :: - Helpers.SchedulerResult -> + Helpers.SchedulerResult (Types.TransactionOutcomesVersionFor pv) -> BS.PersistentBlockState pv -> Helpers.PersistentBSM pv Assertion checkState result state = From 941c5577baa33286f73a7f8fe1f681c2829b8cdb Mon Sep 17 00:00:00 2001 From: Thomas Dinsdale-Young Date: Fri, 14 Nov 2025 19:06:41 +0100 Subject: [PATCH 10/26] Refactor energy charging code. --- .../src-lib/Concordium/External/DryRun.hs | 4 +- .../src/Concordium/Scheduler.hs | 282 +++++++----------- .../src/Concordium/Scheduler/Environment.hs | 97 +++--- .../src/Concordium/TransactionVerification.hs | 3 +- 4 files changed, 172 insertions(+), 214 deletions(-) diff --git a/concordium-consensus/src-lib/Concordium/External/DryRun.hs b/concordium-consensus/src-lib/Concordium/External/DryRun.hs index 0c515ca239..cad90e55c2 100644 --- a/concordium-consensus/src-lib/Concordium/External/DryRun.hs +++ b/concordium-consensus/src-lib/Concordium/External/DryRun.hs @@ -755,8 +755,8 @@ dryRunTransaction dryRunPtr senderPtr energyLimit payloadPtr payloadLen sigPairs dreAvailableAmount = accBalance } shiQuotaRem - - lift (Scheduler.dispatchTransactionBody transaction src cost) >>= \case + let checkHeaderResult = Scheduler.CheckHeaderResult src src cost + lift (Scheduler.dispatchTransactionBody transaction checkHeaderResult) >>= \case Nothing -> do lift . lift . liftIO $ writeIORef shiQuotaRef 0 return $ Left OutOfEnergyQuota diff --git a/concordium-consensus/src/Concordium/Scheduler.hs b/concordium-consensus/src/Concordium/Scheduler.hs index cbd0e58c77..a9a5f56f75 100644 --- a/concordium-consensus/src/Concordium/Scheduler.hs +++ b/concordium-consensus/src/Concordium/Scheduler.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE EmptyCase #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -36,6 +37,7 @@ module Concordium.Scheduler ( filterTransactions, runTransactions, execTransactions, + CheckHeaderResult (..), dispatchTransactionBody, handleContractUpdateV1, handleContractUpdateV0, @@ -110,6 +112,16 @@ import Data.Either (isLeft) import Data.Proxy import Prelude hiding (exp, mod) +data CheckHeaderResult m = CheckHeaderResult + { -- | The sender account for the transaction. + chrSenderAccount :: !(IndexedAccount m), + -- | The account that is paying the transaction fees for the transaction. + -- For a sponsored transaction, this is the sponsor. Otherwise, it is the sender. + chrPayerAccount :: !(IndexedAccount m), + -- | The energy cost to charge for checking the header. + chrCheckHeaderCost :: !Energy + } + -- | The function asserts the following -- * the transaction has a valid sender, -- * the amount corresponding to the deposited energy is on the sender account, @@ -125,12 +137,17 @@ import Prelude hiding (exp, mod) -- Important! If @mVerRes@ is `Just VerificationResult` then it MUST be the `VerificationResult` matching the provided transaction. -- -- Returns the sender account and the cost to be charged for checking the header. -checkHeader :: forall msg m. (TransactionData msg, SchedulerMonad m) => msg -> Maybe TVer.VerificationResult -> ExceptT (Maybe FailureKind) m (IndexedAccount m, Energy) +checkHeader :: + forall msg m. + (TransactionData msg, SchedulerMonad m) => + msg -> + Maybe TVer.VerificationResult -> + ExceptT (Maybe FailureKind) m (CheckHeaderResult m) checkHeader meta mVerRes = do unless (validatePayloadSize (protocolVersion @(MPV m)) (thPayloadSize (transactionHeader meta))) $ throwError $ Just InvalidPayloadSize -- Before even checking the header we calculate the cost that will be charged for this -- and check that at least that much energy is deposited and remaining from the maximum block energy. - let cost = Cost.baseCost (getTransactionHeaderPayloadSize $ transactionHeader meta) (getTransactionNumSigs (transactionSignature meta)) + let cost = transactionBaseCost meta remainingBlockEnergy <- lift getRemainingEnergy -- check that enough energy is remaining for the block. unless (remainingBlockEnergy >= cost) $ throwError Nothing @@ -159,12 +176,12 @@ checkHeader meta mVerRes = do if ID.matchesAccountInformation currentKeys keysHash then do checkNonceAndFunds acc - return (iacc, cost) + return (CheckHeaderResult iacc iacc cost) -- the account information has changed, so we re-verify the signature. else do unless (verifyTransaction currentKeys meta) (throwError $ Just IncorrectSignature) checkNonceAndFunds acc - return (iacc, cost) + return (CheckHeaderResult iacc iacc cost) -- An invalid verification result or `Nothing` was supplied to this function. -- In either case we verify the transaction now. -- Note: we do not have special handling for 'TVer.TrustedSuccess'. @@ -173,7 +190,7 @@ checkHeader meta mVerRes = do newVerRes <- lift (TVer.verifyNormalTransaction meta) case checkTransactionVerificationResult newVerRes of Left failure -> throwError . Just $ failure - Right _ -> return (iacc, cost) + Right _ -> return (CheckHeaderResult iacc iacc cost) where -- check that the nonce is ok and that the sender has enough funds to cover the transaction fee deposit. checkNonceAndFunds acc = do @@ -238,8 +255,8 @@ dispatch (msg, mVerRes) = do case validMeta of Left (Just fk) -> return $ Just (TxInvalid fk) Left Nothing -> return Nothing - Right (senderAccount, checkHeaderCost) -> do - res <- dispatchTransactionBody msg senderAccount checkHeaderCost + Right checkHeaderRes -> do + res <- dispatchTransactionBody msg checkHeaderRes case res of -- The remaining block energy is not sufficient for the handler to execute the transaction. Nothing -> return Nothing @@ -264,33 +281,31 @@ dispatchTransactionBody :: (TransactionData msg, SchedulerMonad m, TransactionResult res) => -- | Transaction to execute. msg -> - -- | Sender account. - IndexedAccount m -> - -- | Energy cost to be charged for checking the transaction header. - Energy -> + -- | Sender/sponsor account and header check energy cost. + CheckHeaderResult m -> m (Maybe (TransactionSummary' (TransactionOutcomesVersionFor (MPV m)) res)) -dispatchTransactionBody msg senderAccount checkHeaderCost = do +dispatchTransactionBody msg CheckHeaderResult{..} = do let meta = transactionHeader msg -- At this point the transaction is going to be committed to the block. -- It could be that the execution exceeds maximum block energy allowed, but in that case -- the whole block state will be removed, and thus this operation will have no effect anyhow. -- Hence we can increase the account nonce of the sender account. - increaseAccountNonce senderAccount + increaseAccountNonce chrSenderAccount tsIndex <- bumpTransactionIndex -- Payload is not parametrised by the protocol version, but decodePayload only returns -- payloads appropriate to the protocol version. case decodePayload (protocolVersion @(MPV m)) (transactionPayload msg) of Left _ -> do - -- In case of serialization failure we charge the sender for checking + -- In case of serialization failure we charge the payer for checking -- the header and reject the transaction; we have checked that the amount -- exists on the account with 'checkHeader'. - payment <- energyToGtu checkHeaderCost - chargeExecutionCost senderAccount payment + payment <- energyToGtu chrCheckHeaderCost + chargeExecutionCostAccount chrPayerAccount payment return $ Just $ TransactionSummary - { tsEnergyCost = checkHeaderCost, + { tsEnergyCost = chrCheckHeaderCost, tsCost = payment, tsSender = Just (thSender meta), -- the sender of the transaction is as specified in the transaction. tsSponsorDetails = conditionally cHasSponsorDetails Nothing, @@ -303,13 +318,15 @@ dispatchTransactionBody msg senderAccount checkHeaderCost = do usedBlockEnergy <- getUsedEnergy let mkWTC _wtcTransactionType = WithDepositContext - { _wtcSenderAccount = senderAccount, + { _wtcSenderAccount = chrSenderAccount, + _wtcPayerAccount = chrPayerAccount, _wtcTransactionHash = transactionHash msg, _wtcSenderAddress = thSender meta, + _wtcSponsorAddress = transactionSponsor msg, _wtcEnergyAmount = thEnergyAmount meta, - _wtcTransactionCheckHeaderCost = checkHeaderCost, + _wtcTransactionCheckHeaderCost = chrCheckHeaderCost, -- NB: We already account for the cost we used here. - _wtcCurrentlyUsedBlockEnergy = usedBlockEnergy + checkHeaderCost, + _wtcCurrentlyUsedBlockEnergy = usedBlockEnergy + chrCheckHeaderCost, _wtcTransactionIndex = tsIndex, .. } @@ -494,17 +511,11 @@ handleTransferWithSchedule wtc twsTo twsSchedule maybeMemo = withDeposit wtc c k withScheduledAmount senderAccount targetAccount transferAmount twsSchedule txHash $ return () k ls () = do - (usedEnergy, energyCost) <- computeExecutionCharge (wtc ^. wtcEnergyAmount) (ls ^. energyLeft) - chargeExecutionCost senderAccount energyCost commitChanges (ls ^. changeSet) let eventList = TransferredWithSchedule{etwsFrom = senderAddress, etwsTo = twsTo, etwsAmount = twsSchedule} : (TransferMemo <$> maybeToList maybeMemo) - return - ( TxSuccess eventList, - energyCost, - usedEnergy - ) + return (TxSuccess eventList) handleTransferToPublic :: (SchedulerMonad m) => @@ -542,12 +553,10 @@ handleTransferToPublic wtc transferData@SecToPubAmountTransferData{..} = do return senderAmount k ls senderAmount = do - (usedEnergy, energyCost) <- computeExecutionCharge (wtc ^. wtcEnergyAmount) (ls ^. energyLeft) - chargeExecutionCost senderAccount energyCost notifyEncryptedBalanceChange $ amountDiff 0 stpatdTransferAmount commitChanges (ls ^. changeSet) - return - ( TxSuccess + return $ + TxSuccess [ EncryptedAmountsRemoved { earAccount = senderAddress, earUpToIndex = stpatdIndex, @@ -558,10 +567,7 @@ handleTransferToPublic wtc transferData@SecToPubAmountTransferData{..} = do { aabdAccount = senderAddress, aabdAmount = stpatdTransferAmount } - ], - energyCost, - usedEnergy - ) + ] handleTransferToEncrypted :: (SchedulerMonad m) => @@ -594,22 +600,17 @@ handleTransferToEncrypted wtc toEncrypted = do return encryptedAmount k ls encryptedAmount = do - (usedEnergy, energyCost) <- computeExecutionCharge (wtc ^. wtcEnergyAmount) (ls ^. energyLeft) - chargeExecutionCost senderAccount energyCost notifyEncryptedBalanceChange $ amountToDelta toEncrypted commitChanges (ls ^. changeSet) - return - ( TxSuccess + return $ + TxSuccess [ EncryptedSelfAmountAdded { eaaAccount = senderAddress, eaaNewAmount = encryptedAmount, eaaAmount = toEncrypted } - ], - energyCost, - usedEnergy - ) + ] handleEncryptedAmountTransfer :: forall m. @@ -684,8 +685,6 @@ handleEncryptedAmountTransfer wtc toAddress transferData@EncryptedAmountTransfer return (targetAccountEncryptedAmountIndex, senderAmount) k ls (targetAccountEncryptedAmountIndex, senderAmount) = do - (usedEnergy, energyCost) <- computeExecutionCharge (wtc ^. wtcEnergyAmount) (ls ^. energyLeft) - chargeExecutionCost senderAccount energyCost commitChanges (ls ^. changeSet) let eventList = [ EncryptedAmountsRemoved @@ -701,12 +700,7 @@ handleEncryptedAmountTransfer wtc toAddress transferData@EncryptedAmountTransfer } ] ++ (TransferMemo <$> maybeToList maybeMemo) - - return - ( TxSuccess eventList, - energyCost, - usedEnergy - ) + return (TxSuccess eventList) -- | Handle the deployment of a module. handleDeployModule :: @@ -719,7 +713,6 @@ handleDeployModule :: handleDeployModule wtc mod = withDeposit wtc c k where - senderAccount = wtc ^. wtcSenderAccount currentProtocolVersion = demoteProtocolVersion (protocolVersion @(MPV m)) c = do @@ -744,15 +737,13 @@ handleDeployModule wtc mod = return (Right (iface, moduleV1), mhash) _ -> rejectTransaction ModuleNotWF - k ls (toCommit, mhash) = do - (usedEnergy, energyCost) <- computeExecutionCharge (wtc ^. wtcEnergyAmount) (ls ^. energyLeft) - chargeExecutionCost senderAccount energyCost + k _ls (toCommit, mhash) = do -- Add the module to the global state (module interface, value interface and module itself). -- We know the module does not exist at this point, so we can ignore the return value. case toCommit of Left v0 -> () <$ commitModule v0 Right v1 -> () <$ commitModule v1 - return (TxSuccess [ModuleDeployed mhash], energyCost, usedEnergy) + return (TxSuccess [ModuleDeployed mhash]) -- | Tick energy for storing the given contract state for V0 contracts. V1 -- contract storage works differently, we charge based only on the part of the @@ -907,8 +898,6 @@ handleInitContract wtc initAmount modref initName param = k ls (Left (iface, result)) = do let model = Wasm.newState result - (usedEnergy, energyCost) <- computeExecutionCharge (wtc ^. wtcEnergyAmount) (ls ^. energyLeft) - chargeExecutionCost senderAccount energyCost -- Withdraw the amount the contract is initialized with from the sender account. cs' <- addAmountToCS senderAccount (amountDiff 0 initAmount) (ls ^. changeSet) @@ -928,8 +917,8 @@ handleInitContract wtc initAmount modref initName param = -- add the contract initialization to the change set and commit the changes commitChanges $ addContractInitToCS (Proxy @m) newInstanceAddr cs' - return - ( transactionSuccess + return $ + transactionSuccess [ ContractInitialized { ecRef = modref, ecAddress = newInstanceAddr, @@ -939,14 +928,9 @@ handleInitContract wtc initAmount modref initName param = ecEvents = Wasm.logs result, ecParameter = CFalse } - ], - energyCost, - usedEnergy - ) + ] k ls (Right (iface, result)) = do let model = WasmV1.irdNewState result - (usedEnergy, energyCost) <- computeExecutionCharge (wtc ^. wtcEnergyAmount) (ls ^. energyLeft) - chargeExecutionCost senderAccount energyCost -- Withdraw the amount the contract is initialized with from the sender account. cs' <- addAmountToCS senderAccount (amountDiff 0 initAmount) (ls ^. changeSet) @@ -966,8 +950,8 @@ handleInitContract wtc initAmount modref initName param = -- add the contract initialization to the change set and commit the changes commitChanges $ addContractInitToCS (Proxy @m) newInstanceAddr cs' - return - ( transactionSuccess + return $ + transactionSuccess [ ContractInitialized { ecRef = modref, ecAddress = newInstanceAddr, @@ -977,10 +961,7 @@ handleInitContract wtc initAmount modref initName param = ecEvents = WasmV1.irdLogs result, ecParameter = CFalse } - ], - energyCost, - usedEnergy - ) + ] handleSimpleTransfer :: (SchedulerMonad m) => @@ -993,7 +974,7 @@ handleSimpleTransfer :: Maybe Memo -> m (Maybe (TransactionSummary (TransactionOutcomesVersionFor (MPV m)))) handleSimpleTransfer wtc toAddr transferamount maybeMemo = - withDeposit wtc c (defaultSuccess wtc) + withDeposit wtc c defaultSuccessNoCharge where senderAccount = wtc ^. wtcSenderAccount senderAddress = wtc ^. wtcSenderAddress @@ -1026,7 +1007,7 @@ handleUpdateContract :: Wasm.Parameter -> m (Maybe (TransactionSummary' (TransactionOutcomesVersionFor (MPV m)) res)) handleUpdateContract wtc uAmount uAddress uReceiveName uMessage = - withDeposit wtc computeAndCharge (defaultSuccess wtc) + withDeposit wtc computeAndCharge defaultSuccessNoCharge where senderAccount = wtc ^. wtcSenderAccount senderAddress = wtc ^. wtcSenderAddress @@ -2000,10 +1981,7 @@ handleAddBaker wtc abElectionVerifyKey abSignatureVerifyKey abAggregationVerifyK -- Get the total amount on the account, including locked amounts, -- less the deposit. getCurrentAccountTotalAmount senderAccount - k ls accountBalance = do - (usedEnergy, energyCost) <- computeExecutionCharge (wtc ^. wtcEnergyAmount) (ls ^. energyLeft) - chargeExecutionCost senderAccount energyCost - + k _ls accountBalance = do let challenge = addBakerChallenge senderAddress abElectionVerifyKey abSignatureVerifyKey abAggregationVerifyKey electionP = checkElectionKeyProof challenge abElectionVerifyKey abProofElection signP = checkSignatureVerifyKeyProof challenge abSignatureVerifyKey abProofSig @@ -2011,7 +1989,7 @@ handleAddBaker wtc abElectionVerifyKey abSignatureVerifyKey abAggregationVerifyK if accountBalance < abBakingStake then -- The balance is insufficient. - return (TxReject InsufficientBalanceForBakerStake, energyCost, usedEnergy) + return (TxReject InsufficientBalanceForBakerStake) else if electionP && signP && aggregationP then do @@ -2042,14 +2020,14 @@ handleAddBaker wtc abElectionVerifyKey abSignatureVerifyKey abAggregationVerifyK ebaStake = abBakingStake, ebaRestakeEarnings = abRestakeEarnings } - return (TxSuccess [baddEvt], energyCost, usedEnergy) + return (TxSuccess [baddEvt]) BI.BAInvalidAccount -> -- This case should not be possible because the account was already resolved - return (TxReject (InvalidAccountReference senderAddress), energyCost, usedEnergy) - BI.BAAlreadyBaker bid -> return (TxReject (AlreadyABaker bid), energyCost, usedEnergy) - BI.BADuplicateAggregationKey -> return (TxReject (DuplicateAggregationKey abAggregationVerifyKey), energyCost, usedEnergy) - BI.BAStakeUnderThreshold -> return (TxReject StakeUnderMinimumThresholdForBaking, energyCost, usedEnergy) - else return (TxReject InvalidProof, energyCost, usedEnergy) + return (TxReject (InvalidAccountReference senderAddress)) + BI.BAAlreadyBaker bid -> return (TxReject (AlreadyABaker bid)) + BI.BADuplicateAggregationKey -> return (TxReject (DuplicateAggregationKey abAggregationVerifyKey)) + BI.BAStakeUnderThreshold -> return (TxReject StakeUnderMinimumThresholdForBaking) + else return (TxReject InvalidProof) -- | Argument to configure baker 'withDeposit' continuation. data ConfigureBakerCont (av :: AccountVersion) @@ -2113,7 +2091,7 @@ handleConfigureBaker cbBakingRewardCommission cbFinalizationRewardCommission cbSuspend = - withDeposit wtc tickGetArgAndBalance chargeAndExecute + withDeposit wtc tickGetArgAndBalance (const executeConfigure) where senderAccount = wtc ^. wtcSenderAccount senderAccountIndex = fst senderAccount @@ -2181,11 +2159,6 @@ handleConfigureBaker else tickEnergy Cost.configureBakerCostWithoutKeys arg <- makeArg (arg,) <$> getCurrentAccountTotalAmount senderAccount - chargeAndExecute ls argAndBalance = do - (usedEnergy, energyCost) <- computeExecutionCharge (wtc ^. wtcEnergyAmount) (ls ^. energyLeft) - chargeExecutionCost senderAccount energyCost - result <- executeConfigure argAndBalance - return (result, energyCost, usedEnergy) -- Check the proofs are valid, if we are updating the keys. -- (If there is no key update, then this is trivially 'True'.) proofsValid = maybe True (checkConfigureBakerKeys senderAddress) cbKeysWithProofs @@ -2297,7 +2270,7 @@ handleConfigureDelegation :: Maybe DelegationTarget -> m (Maybe (TransactionSummary (TransactionOutcomesVersionFor (MPV m)))) handleConfigureDelegation wtc cdCapital cdRestakeEarnings cdDelegationTarget = - withDeposit wtc tickAndGetAccountBalance chargeAndExecute + withDeposit wtc tickAndGetAccountBalance (const executeConfigure) where senderAccount = wtc ^. wtcSenderAccount senderAccountIndex = fst senderAccount @@ -2343,11 +2316,6 @@ handleConfigureDelegation wtc cdCapital cdRestakeEarnings cdDelegationTarget = duDelegationTarget = cdDelegationTarget } (arg,) <$> getCurrentAccountTotalAmount senderAccount - chargeAndExecute ls argAndBalance = do - (usedEnergy, energyCost) <- computeExecutionCharge (wtc ^. wtcEnergyAmount) (ls ^. energyLeft) - chargeExecutionCost senderAccount energyCost - result <- executeConfigure argAndBalance - return (result, energyCost, usedEnergy) executeConfigure (CDCAdd{..}, accountBalance) | accountBalance < BI.daCapital cdcDelegatorAdd = return (TxReject InsufficientBalanceForDelegationStake) @@ -2415,10 +2383,7 @@ handleRemoveBaker wtc = senderAccount = wtc ^. wtcSenderAccount senderAddress = wtc ^. wtcSenderAddress c = tickEnergy Cost.removeBakerCost - k ls () = do - (usedEnergy, energyCost) <- computeExecutionCharge (wtc ^. wtcEnergyAmount) (ls ^. energyLeft) - chargeExecutionCost senderAccount energyCost - + k _ls () = do res <- removeBaker (fst senderAccount) case res of BI.BRRemoved bid _ -> do @@ -2427,9 +2392,9 @@ handleRemoveBaker wtc = { ebrBakerId = bid, ebrAccount = senderAddress } - return (TxSuccess [brEvt], energyCost, usedEnergy) - BI.BRInvalidBaker -> return (TxReject (NotABaker senderAddress), energyCost, usedEnergy) - BI.BRChangePending _ -> return (TxReject BakerInCooldown, energyCost, usedEnergy) + return (TxSuccess [brEvt]) + BI.BRInvalidBaker -> return (TxReject (NotABaker senderAddress)) + BI.BRChangePending _ -> return (TxReject BakerInCooldown) handleUpdateBakerStake :: (AccountVersionFor (MPV m) ~ 'AccountV0, ChainParametersVersionFor (MPV m) ~ 'ChainParametersV0, SchedulerMonad m) => @@ -2447,27 +2412,25 @@ handleUpdateBakerStake wtc newStake = -- Get the total amount on the account, including locked amounts, -- less the deposit. getCurrentAccountTotalAmount senderAccount - k ls accountBalance = do - (usedEnergy, energyCost) <- computeExecutionCharge (wtc ^. wtcEnergyAmount) (ls ^. energyLeft) - chargeExecutionCost senderAccount energyCost + k _ls accountBalance = do if accountBalance < newStake then -- The balance is insufficient. - return (TxReject InsufficientBalanceForBakerStake, energyCost, usedEnergy) + return (TxReject InsufficientBalanceForBakerStake) else do res <- updateBakerStake (fst senderAccount) newStake case res of - BI.BSUChangePending _ -> return (TxReject BakerInCooldown, energyCost, usedEnergy) + BI.BSUChangePending _ -> return (TxReject BakerInCooldown) BI.BSUStakeIncreased bid -> - return (TxSuccess [BakerStakeIncreased bid senderAddress newStake], energyCost, usedEnergy) + return (TxSuccess [BakerStakeIncreased bid senderAddress newStake]) BI.BSUStakeReduced bid _ -> - return (TxSuccess [BakerStakeDecreased bid senderAddress newStake], energyCost, usedEnergy) + return (TxSuccess [BakerStakeDecreased bid senderAddress newStake]) BI.BSUStakeUnchanged _ -> - return (TxSuccess [], energyCost, usedEnergy) + return (TxSuccess []) BI.BSUInvalidBaker -> -- Since we resolved the account already, this happens only if the account is not a baker. - return (TxReject (NotABaker senderAddress), energyCost, usedEnergy) + return (TxReject (NotABaker senderAddress)) BI.BSUStakeUnderThreshold -> - return (TxReject StakeUnderMinimumThresholdForBaking, energyCost, usedEnergy) + return (TxReject StakeUnderMinimumThresholdForBaking) handleUpdateBakerRestakeEarnings :: (AccountVersionFor (MPV m) ~ 'AccountV0, SchedulerMonad m) => @@ -2480,17 +2443,14 @@ handleUpdateBakerRestakeEarnings wtc newRestakeEarnings = withDeposit wtc c k senderAccount = wtc ^. wtcSenderAccount senderAddress = wtc ^. wtcSenderAddress c = tickEnergy Cost.updateBakerRestakeCost - k ls () = do - (usedEnergy, energyCost) <- computeExecutionCharge (wtc ^. wtcEnergyAmount) (ls ^. energyLeft) - chargeExecutionCost senderAccount energyCost - + k _ls () = do res <- updateBakerRestakeEarnings (fst senderAccount) newRestakeEarnings case res of BI.BREUUpdated bid -> - return (TxSuccess [BakerSetRestakeEarnings bid senderAddress newRestakeEarnings], energyCost, usedEnergy) + return (TxSuccess [BakerSetRestakeEarnings bid senderAddress newRestakeEarnings]) BI.BREUInvalidBaker -> -- Since we resolved the account already, this happens only if the account is not a baker. - return (TxReject (NotABaker senderAddress), energyCost, usedEnergy) + return (TxReject (NotABaker senderAddress)) -- | Update a baker's keys. The logic is as follows: -- @@ -2521,10 +2481,7 @@ handleUpdateBakerKeys wtc bkuElectionKey bkuSignKey bkuAggregationKey bkuProofSi senderAccount = wtc ^. wtcSenderAccount senderAddress = wtc ^. wtcSenderAddress c = tickEnergy Cost.updateBakerKeysCost - k ls _ = do - (usedEnergy, energyCost) <- computeExecutionCharge (wtc ^. wtcEnergyAmount) (ls ^. energyLeft) - chargeExecutionCost senderAccount energyCost - + k _ls _ = do let challenge = updateBakerKeyChallenge senderAddress bkuElectionKey bkuSignKey bkuAggregationKey electionP = checkElectionKeyProof challenge bkuElectionKey bkuProofElection signP = checkSignatureVerifyKeyProof challenge bkuSignKey bkuProofSig @@ -2545,12 +2502,12 @@ handleUpdateBakerKeys wtc bkuElectionKey bkuSignKey bkuAggregationKey bkuProofSi ebkuElectionKey = bkuElectionKey, ebkuAggregationKey = bkuAggregationKey } - return (TxSuccess [bupdEvt], energyCost, usedEnergy) + return (TxSuccess [bupdEvt]) BI.BKUInvalidBaker -> -- Since we resolved the account already, this happens only if the account is not a baker. - return (TxReject (NotABaker senderAddress), energyCost, usedEnergy) - BI.BKUDuplicateAggregationKey -> return (TxReject (DuplicateAggregationKey bkuAggregationKey), energyCost, usedEnergy) - else return (TxReject InvalidProof, energyCost, usedEnergy) + return (TxReject (NotABaker senderAddress)) + BI.BKUDuplicateAggregationKey -> return (TxReject (DuplicateAggregationKey bkuAggregationKey)) + else return (TxReject InvalidProof) -- | Credential deployments (transactions without a sender) -- The logic is as follows: @@ -2671,11 +2628,9 @@ handleUpdateCredentialKeys wtc cid keys sigs = let ownerCheck = OrdMap.member index $ tsSignatures sigs unless ownerCheck $ rejectTransaction CredentialHolderDidNotSign return index - k ls index = do - (usedEnergy, energyCost) <- computeExecutionCharge (wtc ^. wtcEnergyAmount) (ls ^. energyLeft) - chargeExecutionCost senderAccount energyCost + k _ls index = do updateCredentialKeys (fst senderAccount) index keys - return (TxSuccess [CredentialKeysUpdated cid], energyCost, usedEnergy) + return (TxSuccess [CredentialKeysUpdated cid]) -- | Handler for a token update transaction. handleTokenUpdate :: @@ -2712,19 +2667,13 @@ handleTokenUpdate depositContext tokenId tokenOperations = tickEnergy energyUsed return (res, cannonicalTokenId) -- Process the successful transaction computation. - commitTransaction computeState (computeResult, cannonicalTokenId) = do - (usedEnergy, energyCost) <- - computeExecutionCharge - (depositContext ^. wtcEnergyAmount) - (computeState ^. energyLeft) - chargeExecutionCost senderAccount energyCost - let result = case computeResult of - Left PLTEOutOfEnergy -> TxReject OutOfEnergy - Left (PLTEFail encodedRejectReason) -> - TxReject . TokenUpdateTransactionFailed $ - makeTokenModuleRejectReason cannonicalTokenId encodedRejectReason - Right events -> TxSuccess events - return (result, energyCost, usedEnergy) + commitTransaction _computeState (computeResult, cannonicalTokenId) = + return $! case computeResult of + Left PLTEOutOfEnergy -> TxReject OutOfEnergy + Left (PLTEFail encodedRejectReason) -> + TxReject . TokenUpdateTransactionFailed $ + makeTokenModuleRejectReason cannonicalTokenId encodedRejectReason + Right events -> TxSuccess events -- Call the module of the token with the operations and return the events emitted from the token module. invokeTokenOperations :: Energy -> @@ -2956,9 +2905,7 @@ handleUpdateCredentials wtc cdis removeRegIds threshold = unless allowed $ rejectTransaction NotAllowedMultipleCredentials return creds - k ls existingCredentials = do - (usedEnergy, energyCost) <- computeExecutionCharge (wtc ^. wtcEnergyAmount) (ls ^. energyLeft) - chargeExecutionCost senderAccount energyCost + k _ls existingCredentials = do cryptoParams <- TVer.getCryptographicParameters -- check that all credentials that are to be removed actually exist. @@ -3026,46 +2973,33 @@ handleUpdateCredentials wtc cdis removeRegIds threshold = -- check all the credential proofs. -- This is only done if all the previous checks have succeeded since this is by far the most computationally expensive part. checkProofs <- foldM (\check cdi -> if check then checkCDI cdi else return False) (firstCredNotRemoved && thresholdCheck && removalCheck && null existingCredIds) cdis - if checkProofs - then do + if + | checkProofs -> do -- check if stuff is correct let creds = traverse (ID.values . ID.NormalACWP) cdis case creds of - Nothing -> return (TxReject InvalidCredentials, energyCost, usedEnergy) + Nothing -> return (TxReject InvalidCredentials) Just newCredentials -> do updateAccountCredentials (fst senderAccount) (reverse revListIndicesToRemove) newCredentials threshold - return - ( TxSuccess + return $ + TxSuccess [ CredentialsUpdated { cuAccount = senderAddress, cuNewCredIds = Set.toList newCredIds, cuRemovedCredIds = removeRegIds, cuNewThreshold = threshold } - ], - energyCost, - usedEnergy - ) + ] -- try to provide a more fine-grained error by analyzing what went wrong -- at some point we should refine the scheduler monad to support cleaner error -- handling by adding MonadError capability to it. Until that is done this -- is a pretty clean alternative to avoid deep nesting. - else - if not firstCredNotRemoved - then return (TxReject RemoveFirstCredential, energyCost, usedEnergy) - else - if not thresholdCheck - then return (TxReject InvalidAccountThreshold, energyCost, usedEnergy) - else - if not (null nonExistingRegIds) - then return (TxReject (NonExistentCredIDs nonExistingRegIds), energyCost, usedEnergy) - else - if not removalCheck - then return (TxReject KeyIndexAlreadyInUse, energyCost, usedEnergy) - else - if not (null existingCredIds) - then return (TxReject (DuplicateCredIDs existingCredIds), energyCost, usedEnergy) - else return (TxReject InvalidCredentials, energyCost, usedEnergy) + | not firstCredNotRemoved -> return (TxReject RemoveFirstCredential) + | not thresholdCheck -> return (TxReject InvalidAccountThreshold) + | not (null nonExistingRegIds) -> return (TxReject (NonExistentCredIDs nonExistingRegIds)) + | not removalCheck -> return (TxReject KeyIndexAlreadyInUse) + | not (null existingCredIds) -> return (TxReject (DuplicateCredIDs existingCredIds)) + | otherwise -> return (TxReject InvalidCredentials) -- | Charges energy based on payload size and emits a 'DataRegistered' event. handleRegisterData :: @@ -3075,7 +3009,7 @@ handleRegisterData :: RegisteredData -> m (Maybe (TransactionSummary (TransactionOutcomesVersionFor (MPV m)))) handleRegisterData wtc regData = - withDeposit wtc c (defaultSuccess wtc) + withDeposit wtc c defaultSuccessNoCharge where c = do tickEnergy Cost.registerDataCost diff --git a/concordium-consensus/src/Concordium/Scheduler/Environment.hs b/concordium-consensus/src/Concordium/Scheduler/Environment.hs index 3433ea0724..f9cab62b1f 100644 --- a/concordium-consensus/src/Concordium/Scheduler/Environment.hs +++ b/concordium-consensus/src/Concordium/Scheduler/Environment.hs @@ -888,8 +888,9 @@ data LocalState m = LocalState makeLenses ''LocalState data TransactionContext = TransactionContext - { -- | Header of the transaction initiating the transaction. - _tcTxSender :: !AccountIndex, + { -- | Index of the account that is paying for the transaction. + _tcTxPayer :: !AccountIndex, + -- | Amount deposited by the payer to fund the transaction cost. _tcDepositedAmount :: !Amount } @@ -915,12 +916,16 @@ runLocalT :: forall m a. (Monad m) => LocalT a m a -> + -- | Deposit amount. Amount -> + -- | Payer account index. AccountIndex -> - Energy -> -- Energy limit by the transaction header. - Energy -> -- remaining block energy + -- | Energy left for executing this transaction. + Energy -> + -- | Energy left for executing this block. + Energy -> m (Either (Maybe RejectReason) a, LocalState m) -runLocalT (LocalT st) _tcDepositedAmount _tcTxSender _energyLeft _blockEnergyLeft = do +runLocalT (LocalT st) _tcDepositedAmount _tcTxPayer _energyLeft _blockEnergyLeft = do -- The initial contract modification index must start at 1 since 0 is the -- "initial state" of all contracts (as recorded in the changeset). let s = @@ -971,17 +976,39 @@ computeExecutionCharge allocated unused = -- is the only one affected by the transaction, either because a transaction was -- rejected, or because it was a transaction which only affects one account's -- balance such as DeployCredential, or DeployModule. -chargeExecutionCost :: forall m. (SchedulerMonad m) => IndexedAccount m -> Amount -> m () -chargeExecutionCost (ai, acc) amnt = do +chargeExecutionCostAccount :: forall m. (SchedulerMonad m) => IndexedAccount m -> Amount -> m () +chargeExecutionCostAccount (ai, acc) amnt = do balance <- getAccountAmount acc let csWithAccountDelta = emptyCS (Proxy @m) & accountUpdates . at ai ?~ (emptyAccountUpdate ai & auAmount ?~ amountDiff 0 amnt) assert (balance >= amnt) $ commitChanges csWithAccountDelta notifyExecutionCost amnt +-- | The energy used in executing a transaction and the cost that was paid for it. +data ExecutionCharge = ExecutionCharge + { -- | The amount of energy used in the transaction. + ecUsedEnergy :: !Energy, + -- | The cost charged for the energy used in the transaction. + ecEnergyCost :: !Amount + } + +computeChargeExecution :: + (SchedulerMonad m) => + -- | The context for the transaction execution. + WithDepositContext m -> + -- | The remaining unused energy. + Energy -> + m ExecutionCharge +computeChargeExecution wtc unused = do + (used, cost) <- computeExecutionCharge (_wtcEnergyAmount wtc) unused + chargeExecutionCostAccount (_wtcPayerAccount wtc) cost + return $ ExecutionCharge{ecUsedEnergy = used, ecEnergyCost = cost} + data WithDepositContext m = WithDepositContext { -- | The account initiating the transaction. _wtcSenderAccount :: !(IndexedAccount m), + -- | The account paying the energy cost for the transaction. + _wtcPayerAccount :: !(IndexedAccount m), -- | Type of the top-level transaction. _wtcTransactionType :: !TransactionType, -- | Hash of the top-level transaction. @@ -989,6 +1016,8 @@ data WithDepositContext m = WithDepositContext -- | Address of the sender of the transaction. -- This should correspond to '_wtcSenderAccount', but need not be the canonical address. _wtcSenderAddress :: !AccountAddress, + -- | If the transaction is sponsored, this is the address of the sponsor account. + _wtcSponsorAddress :: !(Maybe AccountAddress), -- | The amount of energy dedicated for the execution of this transaction. _wtcEnergyAmount :: !Energy, -- | Cost to be charged for checking the transaction header. @@ -1001,14 +1030,14 @@ data WithDepositContext m = WithDepositContext makeLenses ''WithDepositContext --- | Given an account which is initiating the top-level transaction and the +-- | Given an account which is paying the fees for the top-level transaction and the -- deposited amount, run the given computation in the modified environment where -- the balance on the account is decreased by the deposited amount. Return the -- amount of energy __used__ by the computation and any result returned. The -- function __ensures__ that the amount of energy is not more than the -- deposited amount. The function __assumes__ the following -- --- * The account exists in the account database. +-- * The payer account exists in the account database. -- * The deposited amount exists in the public account value. -- * The deposited amount is __at least__ Cost.checkHeader applied to the respective parameters (i.e., minimum transaction cost). withDeposit :: @@ -1018,10 +1047,10 @@ withDeposit :: -- | The computation to run in the modified environment with reduced amount on the initial account. LocalT a m a -> -- | Continuation for the successful branch of the computation. + -- The execution cost is charged before this is called. -- It gets the result of the previous computation as input, in particular the - -- remaining energy and the ChangeSet. It should return the result, and the amount that was charged - -- for the execution. - (LocalState m -> a -> m (res, Amount, Energy)) -> + -- remaining energy and the ChangeSet. It should return the result. + (LocalState m -> a -> m res) -> m (Maybe (TransactionSummary' tov res)) withDeposit wtc comp k = do let tsHash = wtc ^. wtcTransactionHash @@ -1033,7 +1062,7 @@ withDeposit wtc comp k = do let energy = totalEnergyToUse - wtc ^. wtcTransactionCheckHeaderCost -- record how much we have deposited. This cannot be touched during execution. depositedAmount <- energyToGtu totalEnergyToUse - (res, ls) <- runLocalT comp depositedAmount (wtc ^. wtcSenderAccount . _1) energy beLeft + (res, ls) <- runLocalT comp depositedAmount (wtc ^. wtcPayerAccount . _1) energy beLeft let addReturn result = foldr (setTransactionReturnValue . V1.returnValueToByteString) @@ -1044,17 +1073,16 @@ withDeposit wtc comp k = do Left Nothing -> return Nothing -- Failure: transaction fails (out of energy or actual failure by transaction logic) Left (Just reason) -> do - -- The only effect of this transaction is that the sender is charged for the execution cost + -- The only effect of this transaction is that the payer is charged for the execution cost -- (energy ticked so far). - (usedEnergy, payment) <- computeExecutionCharge totalEnergyToUse (ls ^. energyLeft) - chargeExecutionCost (wtc ^. wtcSenderAccount) payment + executionCharge <- computeChargeExecution wtc (ls ^. energyLeft) return $! Just $! TransactionSummary { tsSender = Just (wtc ^. wtcSenderAddress), - tsCost = payment, + tsCost = ecEnergyCost executionCharge, tsSponsorDetails = conditionally cHasSponsorDetails Nothing, - tsEnergyCost = usedEnergy, + tsEnergyCost = ecUsedEnergy executionCharge, tsResult = addReturn $ transactionReject reason, tsType = TSTAccountTransaction $ Just $ wtc ^. wtcTransactionType, tsIndex = wtc ^. wtcTransactionIndex, @@ -1062,13 +1090,16 @@ withDeposit wtc comp k = do } -- Computation successful Right a -> do - -- In this case we invoke the continuation, which should charge for the used energy. - (tsResult0, tsCost, tsEnergyCost) <- k ls a + -- In this case we charge for the used energy then invoke the continuation. + executionCharge <- computeChargeExecution wtc (ls ^. energyLeft) + tsResult0 <- k ls a return $! Just $! TransactionSummary { tsSender = Just (wtc ^. wtcSenderAddress), + tsCost = ecEnergyCost executionCharge, tsSponsorDetails = conditionally cHasSponsorDetails Nothing, + tsEnergyCost = ecUsedEnergy executionCharge, tsType = TSTAccountTransaction $ Just $ wtc ^. wtcTransactionType, tsIndex = wtc ^. wtcTransactionIndex, tsResult = addReturn tsResult0, @@ -1077,24 +1108,18 @@ withDeposit wtc comp k = do where cHasSponsorDetails = sHasSponsorDetails (sTransactionOutcomesVersionFor (protocolVersion @(MPV m))) -{-# INLINE defaultSuccess #-} - --- | Default continuation to use with 'withDeposit'. It charges for the energy used, commits the changes +-- | Default continuation to use with 'withDeposit'. It commits the changes -- from the current changeset and returns the recorded events, the amount corresponding to the -- used energy and the used energy. -defaultSuccess :: +{-# INLINE defaultSuccessNoCharge #-} +defaultSuccessNoCharge :: (SchedulerMonad m, TransactionResult res) => - WithDepositContext m -> LocalState m -> [Event] -> - m (res, Amount, Energy) -defaultSuccess wtc = \ls res -> do - let energyAllocated = wtc ^. wtcEnergyAmount - senderAccount = wtc ^. wtcSenderAccount - (usedEnergy, energyCost) <- computeExecutionCharge energyAllocated (ls ^. energyLeft) - chargeExecutionCost senderAccount energyCost + m res +defaultSuccessNoCharge = \ls res -> do commitChanges (ls ^. changeSet) - return (transactionSuccess res, energyCost, usedEnergy) + return (transactionSuccess res) {-# INLINE liftLocal #-} liftLocal :: (Monad m) => m a -> LocalT r m a @@ -1335,9 +1360,9 @@ instance (MonadProtocolVersion m, StaticInformation m, AccountOperations m, Cont getCurrentAccountTotalAmount (ai, acc) = do oldTotal <- getAccountAmount acc !txCtx <- ask - -- If the account is the sender, subtract the deposit + -- If the account is the transaction fee payer, subtract the deposit let netDeposit = - if txCtx ^. tcTxSender == ai + if txCtx ^. tcTxPayer == ai then oldTotal - (txCtx ^. tcDepositedAmount) else oldTotal macc <- use (changeSet . accountUpdates . at ai) @@ -1355,9 +1380,9 @@ instance (MonadProtocolVersion m, StaticInformation m, AccountOperations m, Cont oldLockedUp <- getAccountLockedAmount acc staked <- getAccountTotalStakedAmount acc !txCtx <- ask - -- If the account is the sender, subtract the deposit + -- If the account is the transaction fee payer, subtract the deposit let netDeposit = - if txCtx ^. tcTxSender == ai + if txCtx ^. tcTxPayer == ai then oldTotal - (txCtx ^. tcDepositedAmount) else oldTotal macc <- use (changeSet . accountUpdates . at ai) diff --git a/concordium-consensus/src/Concordium/TransactionVerification.hs b/concordium-consensus/src/Concordium/TransactionVerification.hs index e6ebf17ef0..e4c5a86a20 100644 --- a/concordium-consensus/src/Concordium/TransactionVerification.hs +++ b/concordium-consensus/src/Concordium/TransactionVerification.hs @@ -6,7 +6,6 @@ module Concordium.TransactionVerification where import qualified Data.Map.Strict as OrdMap import qualified Data.Serialize as S -import qualified Concordium.Cost as Cost import qualified Concordium.Crypto.SHA256 as Sha256 import qualified Concordium.GlobalState.Types as GSTypes import qualified Concordium.ID.Account as A @@ -335,7 +334,7 @@ verifyNormalTransaction meta = throwError $ NotOk InvalidPayloadSize -- Check that enough energy is supplied - let cost = Cost.baseCost (Tx.getTransactionHeaderPayloadSize $ Tx.transactionHeader meta) (Tx.getTransactionNumSigs (Tx.transactionSignature meta)) + let cost = Tx.transactionBaseCost meta unless (Tx.transactionGasAmount meta >= cost) $ throwError $ NotOk NormalTransactionDepositInsufficient -- Check that the required energy does not exceed the maximum allowed for a block maxEnergy <- lift getMaxBlockEnergy From d426af80734fef08ce4014e0fd46fadac4d85476 Mon Sep 17 00:00:00 2001 From: Thomas Dinsdale-Young Date: Mon, 17 Nov 2025 11:50:05 +0100 Subject: [PATCH 11/26] Renaming and refactoring. --- .../src/Concordium/Scheduler.hs | 6 +-- .../src/Concordium/Scheduler/Environment.hs | 37 ++++++++++--------- 2 files changed, 22 insertions(+), 21 deletions(-) diff --git a/concordium-consensus/src/Concordium/Scheduler.hs b/concordium-consensus/src/Concordium/Scheduler.hs index a9a5f56f75..9bd803b0e6 100644 --- a/concordium-consensus/src/Concordium/Scheduler.hs +++ b/concordium-consensus/src/Concordium/Scheduler.hs @@ -974,7 +974,7 @@ handleSimpleTransfer :: Maybe Memo -> m (Maybe (TransactionSummary (TransactionOutcomesVersionFor (MPV m)))) handleSimpleTransfer wtc toAddr transferamount maybeMemo = - withDeposit wtc c defaultSuccessNoCharge + withDeposit wtc c defaultSuccess where senderAccount = wtc ^. wtcSenderAccount senderAddress = wtc ^. wtcSenderAddress @@ -1007,7 +1007,7 @@ handleUpdateContract :: Wasm.Parameter -> m (Maybe (TransactionSummary' (TransactionOutcomesVersionFor (MPV m)) res)) handleUpdateContract wtc uAmount uAddress uReceiveName uMessage = - withDeposit wtc computeAndCharge defaultSuccessNoCharge + withDeposit wtc computeAndCharge defaultSuccess where senderAccount = wtc ^. wtcSenderAccount senderAddress = wtc ^. wtcSenderAddress @@ -3009,7 +3009,7 @@ handleRegisterData :: RegisteredData -> m (Maybe (TransactionSummary (TransactionOutcomesVersionFor (MPV m)))) handleRegisterData wtc regData = - withDeposit wtc c defaultSuccessNoCharge + withDeposit wtc c defaultSuccess where c = do tickEnergy Cost.registerDataCost diff --git a/concordium-consensus/src/Concordium/Scheduler/Environment.hs b/concordium-consensus/src/Concordium/Scheduler/Environment.hs index f9cab62b1f..df563bbf7f 100644 --- a/concordium-consensus/src/Concordium/Scheduler/Environment.hs +++ b/concordium-consensus/src/Concordium/Scheduler/Environment.hs @@ -952,6 +952,14 @@ instance BlockStateTypes (LocalT r m) where type InstrumentedModuleRef (LocalT r m) = InstrumentedModuleRef m type MutableTokenState (LocalT r m) = MutableTokenState m +-- | The energy used in executing a transaction and the cost that was paid for it. +data ExecutionCharge = ExecutionCharge + { -- | The amount of energy used in the transaction. + ecUsedEnergy :: !Energy, + -- | The cost charged for the energy used in the transaction. + ecEnergyCost :: !Amount + } + -- | Given the deposited amount and the remaining amount of gas compute how much -- the sender of the transaction should be charged, as well as how much energy was used -- for execution. @@ -962,10 +970,11 @@ computeExecutionCharge :: Energy -> -- | Energy remaining unused. Energy -> - m (Energy, Amount) -computeExecutionCharge allocated unused = - let used = allocated - unused - in (used,) <$> energyToGtu used + m ExecutionCharge +computeExecutionCharge allocated unused = do + let ecUsedEnergy = allocated - unused + ecEnergyCost <- energyToGtu ecUsedEnergy + return ExecutionCharge{..} -- | Reduce the public balance on the account to charge for execution cost. The -- given amount is the amount to charge (subtract). The precondition of this @@ -984,14 +993,6 @@ chargeExecutionCostAccount (ai, acc) amnt = do commitChanges csWithAccountDelta notifyExecutionCost amnt --- | The energy used in executing a transaction and the cost that was paid for it. -data ExecutionCharge = ExecutionCharge - { -- | The amount of energy used in the transaction. - ecUsedEnergy :: !Energy, - -- | The cost charged for the energy used in the transaction. - ecEnergyCost :: !Amount - } - computeChargeExecution :: (SchedulerMonad m) => -- | The context for the transaction execution. @@ -1000,9 +1001,9 @@ computeChargeExecution :: Energy -> m ExecutionCharge computeChargeExecution wtc unused = do - (used, cost) <- computeExecutionCharge (_wtcEnergyAmount wtc) unused - chargeExecutionCostAccount (_wtcPayerAccount wtc) cost - return $ ExecutionCharge{ecUsedEnergy = used, ecEnergyCost = cost} + executionCharge <- computeExecutionCharge (_wtcEnergyAmount wtc) unused + chargeExecutionCostAccount (_wtcPayerAccount wtc) (ecEnergyCost executionCharge) + return executionCharge data WithDepositContext m = WithDepositContext { -- | The account initiating the transaction. @@ -1111,13 +1112,13 @@ withDeposit wtc comp k = do -- | Default continuation to use with 'withDeposit'. It commits the changes -- from the current changeset and returns the recorded events, the amount corresponding to the -- used energy and the used energy. -{-# INLINE defaultSuccessNoCharge #-} -defaultSuccessNoCharge :: +{-# INLINE defaultSuccess #-} +defaultSuccess :: (SchedulerMonad m, TransactionResult res) => LocalState m -> [Event] -> m res -defaultSuccessNoCharge = \ls res -> do +defaultSuccess = \ls res -> do commitChanges (ls ^. changeSet) return (transactionSuccess res) From 1625708f676322f9b4dbf9f4e26a5a05aa3352b9 Mon Sep 17 00:00:00 2001 From: drsk <827698+drsk0@users.noreply.github.com> Date: Tue, 25 Nov 2025 11:46:38 +0100 Subject: [PATCH 12/26] SPO-10: transaction verification for sponsored transactions (#1469) * SPO-10: transaction verifier implementation * one passing test with valid transaction data * transaction verifier tests * fix transaction verifier the signature verifiaction for sponsored transactions is different from the signature verifaction of normal transactions. * clean up * Update concordium-consensus/src/Concordium/TransactionVerification.hs Co-authored-by: Thomas Dinsdale-Young * Update concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/TransactionProcessingTest.hs Co-authored-by: Thomas Dinsdale-Young * Update concordium-consensus/src/Concordium/TransactionVerification.hs Co-authored-by: Thomas Dinsdale-Young * concordium-base: update submodule * Update concordium-consensus/src/Concordium/TransactionVerification.hs Co-authored-by: Thomas Dinsdale-Young * update call to verifySponsoredTransaction * set unused type family instances to Void * factor out sender/sponsor signatures * update minimal energy amount in tests * add EnergyRate to test data * update minimum nonce * introduce `checkExactNonce` field in test data * add test for succeeding tx when checkExactNonce == False * remove test .dat file * Add a test for NormalTransactionDuplicateNonce error case * refactor test data creation * incremented nonce, so no zero nonce appear in the tests * cosmetics * replace dummy type family * add comment * format --------- Co-authored-by: drsk Co-authored-by: Thomas Dinsdale-Young --- concordium-base | 2 +- .../src/Concordium/TransactionVerification.hs | 86 ++- .../KonsensusV1/TransactionProcessingTest.hs | 649 +++++++++++++++++- 3 files changed, 733 insertions(+), 4 deletions(-) diff --git a/concordium-base b/concordium-base index fb0edc5dcd..da88ca0d8b 160000 --- a/concordium-base +++ b/concordium-base @@ -1 +1 @@ -Subproject commit fb0edc5dcd74f9ecf0f3929f9f19b28916782c62 +Subproject commit da88ca0d8bd2b1e6a7f5b411321d266035a8a334 diff --git a/concordium-consensus/src/Concordium/TransactionVerification.hs b/concordium-consensus/src/Concordium/TransactionVerification.hs index e6ebf17ef0..b7e0ff87c8 100644 --- a/concordium-consensus/src/Concordium/TransactionVerification.hs +++ b/concordium-consensus/src/Concordium/TransactionVerification.hs @@ -232,8 +232,8 @@ verify now bi = do verifyChainUpdate ui Tx.WithMetadata{wmdData = Tx.NormalTransaction tx} -> do verifyNormalTransaction tx - Tx.WithMetadata{wmdData = Tx.ExtendedTransaction _tx} -> - error "TODO(SPO-10): transaction verifier support for sponsored transactions" + Tx.WithMetadata{wmdData = Tx.ExtendedTransaction tx} -> + verifyExtendedTransaction tx -- | Verifies a 'CredentialDeployment' transaction. -- @@ -370,6 +370,88 @@ verifyNormalTransaction meta = return $ Ok $ NormalTransactionSuccess (getHash keys) nonce ) +-- | Verifies an 'ExtendedTransaction' transaction. +-- This function verifies the following: +-- * Checks that enough energy is supplied for the transaction. +-- * Checks that if a sponsor is specified, a sponsor signature is present as well. +-- * CHecks that if no sponsor is specified, no sponsor signature is present. +-- * Checks that the sender is a valid account. +-- * Checks that the sponsor is a valid account, if present. +-- * Checks that the nonce is correct. +-- * Checks that the 'ExtendedTransaction' is correctly signed by both sender and the optional sponsor. +verifyExtendedTransaction :: + forall m msg. + (TransactionVerifier m, Tx.TransactionData msg) => + msg -> + m VerificationResult +verifyExtendedTransaction meta = + either id id + <$> runExceptT + ( do + unless (Types.validatePayloadSize (Types.protocolVersion @(Types.MPV m)) (Tx.thPayloadSize (Tx.transactionHeader meta))) $ + throwError $ + NotOk InvalidPayloadSize + + -- Check that either both, the sponsor and the sponsor signature are specified or neither. + mbSponsorAddr <- case (Tx.transactionSponsor meta, Tx.transactionSponsorSignature meta) of + (Just sponsorAddr, Just _sponsorSig) -> return $ Just sponsorAddr + (Nothing, Nothing) -> return Nothing + (Just _sponsorAddr, Nothing) -> throwError $ NotOk SponsoredTransactionMissingSponsorSignature + (Nothing, Just _sponsorSignature) -> throwError $ NotOk SponsoredTransactionMissingSponsor + + -- Check that enough energy is supplied + let cost = Tx.transactionBaseCost meta + unless (Tx.transactionGasAmount meta >= cost) $ throwError $ NotOk NormalTransactionDepositInsufficient + -- Check that the required energy does not exceed the maximum allowed for a block + maxEnergy <- lift getMaxBlockEnergy + when (Tx.transactionGasAmount meta > maxEnergy) $ throwError $ MaybeOk NormalTransactionEnergyExceeded + -- Check that the sender account exists + let senderAddr = Tx.transactionSender meta + mbSenderAcc <- lift (getAccount senderAddr) + senderAcc <- case mbSenderAcc of + Nothing -> throwError (MaybeOk $ NormalTransactionInvalidSender senderAddr) + Just senderAcc -> return senderAcc + -- Check that the sponsor account exists if a sponsor is present + mbSponsorAcc <- case mbSponsorAddr of + Just sponsorAddr -> do + macc <- lift (getAccount sponsorAddr) + case macc of + Nothing -> throwError (MaybeOk $ ExtendedTransactionInvalidSponsor sponsorAddr) + Just acc -> return $ Just acc + Nothing -> return Nothing + -- Check that the nonce of the transaction is correct. + nextNonce <- lift (getNextAccountNonce senderAcc) + let nonce = Tx.transactionNonce meta + when (nonce < nextNonce) $ throwError (NotOk $ NormalTransactionDuplicateNonce nonce) + -- For transactions received as part of a `Block` we only check that the `Nonce` + -- is not too old with respect to the 'last finalized block' or the 'parent block'. + -- In the `Scheduler` we check that the `Nonce` is actually the next one. + -- The reason for this is that otherwise when transactions are received via a block + -- we don't know what the next nonce is as we can't verify in the context of the 'block' which the + -- transactions were received with. Hence if there are multiple transactions from the same account within the same block, + -- which would lead us to rejecting the valid transaction(s). + exactNonce <- lift checkExactNonce + when (exactNonce && nonce /= nextNonce) $ throwError (MaybeOk $ NormalTransactionInvalidNonce nextNonce) + -- check that the sender or sponsor account has enough funds to cover the transfer + amnt <- case mbSponsorAcc of + Nothing -> lift $ getAccountAvailableAmount senderAcc + Just sponsorAcc -> lift $ getAccountAvailableAmount sponsorAcc + depositedAmount <- lift (energyToCcd (Tx.transactionGasAmount meta)) + unless (depositedAmount <= amnt) $ throwError $ MaybeOk NormalTransactionInsufficientFunds + -- Check the sender and sponsor signatures + senderKeys <- lift (getAccountVerificationKeys senderAcc) + case mbSponsorAcc of + Nothing -> do + let sigCheck = Tx.verifyTransaction senderKeys meta + unless sigCheck $ throwError $ MaybeOk NormalTransactionInvalidSignatures + return $ Ok $ ExtendedTransactionSuccess (getHash senderKeys) Absent nonce + Just sponsorAcc -> do + sponsorKeys <- lift (getAccountVerificationKeys sponsorAcc) + let sigCheck = Tx.verifySponsoredTransaction senderKeys sponsorKeys meta + unless sigCheck $ throwError $ MaybeOk NormalTransactionInvalidSignatures + return $ Ok $ ExtendedTransactionSuccess (getHash senderKeys) (Present $ getHash sponsorKeys) nonce + ) + -- | Wrapper types for pairing a transaction with its verification result (if it has one). -- The purpose of these types is to provide a uniform api between the 'TransactionTable' and the 'TreeState'. -- diff --git a/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/TransactionProcessingTest.hs b/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/TransactionProcessingTest.hs index bc887718b7..21f7abeea9 100644 --- a/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/TransactionProcessingTest.hs +++ b/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/TransactionProcessingTest.hs @@ -4,8 +4,10 @@ {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -- | This module tests processing of transactions for consensus V1. @@ -19,6 +21,7 @@ module ConcordiumTests.KonsensusV1.TransactionProcessingTest where import Control.Monad import Control.Monad.Catch +import Control.Monad.Identity import Control.Monad.Reader import Control.Monad.State import qualified Data.Aeson as AE @@ -30,15 +33,18 @@ import Data.Kind (Type) import qualified Data.Map.Strict as Map import Data.Maybe (isJust) import Data.Ratio +import qualified Data.Text as T import Data.Time.Clock import Data.Time.Clock.POSIX import qualified Data.Vector as Vec +import Data.Void import Lens.Micro.Platform import System.Random import Test.HUnit import Test.Hspec import Concordium.Common.Version +import Concordium.Constants import Concordium.Crypto.DummyData import qualified Concordium.Crypto.SHA256 as Hash import qualified Concordium.Crypto.SignatureScheme as SigScheme @@ -58,7 +64,10 @@ import Concordium.GlobalState.Persistent.BlobStore import Concordium.GlobalState.Persistent.BlockState import Concordium.GlobalState.Persistent.Genesis (genesisState) import Concordium.GlobalState.TransactionTable +import Concordium.GlobalState.Transactions +import qualified Concordium.GlobalState.Types as GSTypes import Concordium.ID.Types (randomAccountAddress) +import qualified Concordium.ID.Types as ID import Concordium.Logger import Concordium.Scheduler.DummyData import Concordium.TimeMonad @@ -74,8 +83,8 @@ import Concordium.Types.TransactionOutcomes import Concordium.Types.Transactions import Concordium.Types.Updates import Concordium.Utils +import Concordium.Wasm (WasmVersion) -import Concordium.GlobalState.Transactions import Concordium.KonsensusV1.Transactions import Concordium.KonsensusV1.TreeState.Implementation import Concordium.KonsensusV1.TreeState.Types @@ -615,6 +624,641 @@ testProcessBlockItems sProtocolVersion = describe "processBlockItems" $ do .. } +-- TransactionVerifier testing +------------------------------ + +-- | Test data used for testing transaction verification +data TransactionVerifierTestData (pv :: ProtocolVersion) = TransactionVerifierTestData + { tvtdAccounts :: !(Map.Map (GSTypes.Account (TVTM pv)) (AccountTestData pv)), + tvtdAccountsByAddress :: !(Map.Map AccountAddress (GSTypes.Account (TVTM pv))), + tvtdEnergyRate :: !EnergyRate, + tvtdCheckExactNonce :: !Bool + } + +data AccountTestData (pv :: ProtocolVersion) = AccountTestData + { atdAccountAvailableAmount :: !Amount, + atdAccountNonce :: !Nonce, + atdAccountVerificationKeys :: ID.AccountInformation + } + +-- The transaction verifier test monad. +newtype TVTM (pv :: ProtocolVersion) a = TVTM + { runTVTM :: TransactionVerifierT' (TransactionVerifierTestData pv) Identity a + } + deriving (Functor, Applicative, Monad, MonadReader (TransactionVerifierTestData pv)) + +instance + forall (pv :: ProtocolVersion). + (IsProtocolVersion pv, IsCompatibleAuthorizationsVersion (ChainParametersVersionFor pv) (AuthorizationsVersionFor pv) ~ 'True) => + MonadProtocolVersion (TVTM pv) + where + type MPV (TVTM pv) = pv + +-- Used to define the following type family instances. +data WasmVersionedVoid (v :: WasmVersion) + +instance forall (pv :: ProtocolVersion). GSTypes.BlockStateTypes (TVTM pv) where + type Account (TVTM pv) = T.Text + type BlockState (TVTM pv) = Void + type UpdatableBlockState (TVTM pv) = Void + type ContractState (TVTM pv) = WasmVersionedVoid + type BakerInfoRef (TVTM pv) = Void + type InstrumentedModuleRef (TVTM pv) = WasmVersionedVoid + type MutableTokenState (TVTM pv) = Void + +instance + forall (pv :: ProtocolVersion). + (IsProtocolVersion pv, IsCompatibleAuthorizationsVersion (ChainParametersVersionFor pv) (AuthorizationsVersionFor pv) ~ 'True) => + TVer.TransactionVerifier (TVTM pv) + where + getAccount addr = do + testData <- ask + return $ Map.lookup addr $ tvtdAccountsByAddress testData + + getAccountAvailableAmount acc = do + testData <- tvtdAccounts <$> ask + case Map.lookup acc testData of + Nothing -> error "account not available in test data" + Just atd -> return $ atdAccountAvailableAmount atd + + getNextAccountNonce acc = do + testData <- tvtdAccounts <$> ask + case Map.lookup acc testData of + Nothing -> error "account not available in test data" + Just atd -> return $ atdAccountNonce atd + + getAccountVerificationKeys acc = do + testData <- tvtdAccounts <$> ask + case Map.lookup acc testData of + Nothing -> error "account not available in test data" + Just atd -> return $ atdAccountVerificationKeys atd + + getMaxBlockEnergy = return 1000 + + -- For testing we assume exact nonces. + checkExactNonce = tvtdCheckExactNonce <$> ask + + energyToCcd nrg = do + testData <- ask + return $ computeCost (tvtdEnergyRate testData) nrg + + -- We currently don't use the following for testing. + getIdentityProvider = error "Unexpected use of `getIdentityProvider` in TransactionVerifierTestM" + getAnonymityRevokers = error "Unexpected use of `getAnonymityRevokers` in TransactionVerifierTestM" + getCryptographicParameters = error "Unexpected use of `getCryptographicParameters` in TransactionVerifierTestM" + registrationIdExists = error "Unexpected use of `registrationIdExists` in TransactionVerifierTestM" + getNextUpdateSequenceNumber = error "Unexpected use of `getNextUpdateSequenceNumber` in TransactionVerifierTestM" + getUpdateKeysCollection = error "Unexpected use of `getUpdateKeysCollection` in TransactionVerifierTestM" + +-- | Tests for the transaction verification of extended transaction introduced in P10. +testExtendedTransactionVerification :: + forall pv. + (IsConsensusV1 pv, IsProtocolVersion pv) => + SProtocolVersion pv -> + Spec +testExtendedTransactionVerification spv = do + it "A well-formed extended transaction with sponsor should pass verification" $ do + let + txHeader = + TransactionHeaderV1 + { thv1HeaderV0 = + TransactionHeader + { thSender = senderAccountAddress, + thNonce = 2, + thEnergyAmount = 302, + thPayloadSize = 8, + thExpiry = 0 + }, + thv1Sponsor = Just sponsorAccountAddress + } + txPayload = EncodedPayload "deadbeef" + txBodyHash = transactionV1SignHashFromHeaderPayload txHeader txPayload + senderTxSignature = makeTxSignature senderKeyPair txBodyHash + sponsorTxSignature = makeTxSignature sponsorKeyPair txBodyHash + txSignatures = + TransactionSignaturesV1 + { tsv1Sender = senderTxSignature, + tsv1Sponsor = Just sponsorTxSignature + } + tx = makeAccountTransactionV1 txSignatures txHeader txPayload + let res = + runIdentity $ + (runTransactionVerifierT $ runTVTM $ TVer.verifyExtendedTransaction tx) + testData + assertEqual + "The verification should yield the expected `Ok ExtendTransactionSuccess` result" + ( TVer.Ok + TVer.ExtendedTransactionSuccess + { senderKeysHash = getHash senderAccountVerificationKeys, + sponsorKeysHash = Present $ getHash sponsorAccountVerificationKeys, + nonce = 2 + } + ) + res + it "A transaction with a too big payload size should be rejected" $ do + let + txHeader = + TransactionHeaderV1 + { thv1HeaderV0 = + TransactionHeader + { thSender = senderAccountAddress, + thNonce = 2, + thEnergyAmount = 302, + thPayloadSize = (fromIntegral $ maxPayloadSize spv + 1), + thExpiry = 0 + }, + thv1Sponsor = Just sponsorAccountAddress + } + txPayload = EncodedPayload "deadbeef" + txBodyHash = transactionV1SignHashFromHeaderPayload txHeader txPayload + senderTxSignature = makeTxSignature senderKeyPair txBodyHash + sponsorTxSignature = makeTxSignature sponsorKeyPair txBodyHash + txSignatures = + TransactionSignaturesV1 + { tsv1Sender = senderTxSignature, + tsv1Sponsor = Just sponsorTxSignature + } + tx = makeAccountTransactionV1 txSignatures txHeader txPayload + let res = + runIdentity $ + (runTransactionVerifierT $ runTVTM $ TVer.verifyExtendedTransaction tx) + testData + assertEqual + "The verification should yield the expected `NotOk InvalidPayloadSize` result" + (TVer.NotOk TVer.InvalidPayloadSize) + res + + it "A transaction with a sponsor address but without sponsor signature should be rejected" $ do + let + txHeader = + TransactionHeaderV1 + { thv1HeaderV0 = + TransactionHeader + { thSender = senderAccountAddress, + thNonce = 2, + thEnergyAmount = 302, + thPayloadSize = 8, + thExpiry = 0 + }, + thv1Sponsor = Just sponsorAccountAddress + } + txPayload = EncodedPayload "deadbeef" + txBodyHash = transactionV1SignHashFromHeaderPayload txHeader txPayload + senderTxSignature = makeTxSignature senderKeyPair txBodyHash + txSignatures = + TransactionSignaturesV1 + { tsv1Sender = senderTxSignature, + tsv1Sponsor = Nothing + } + tx = makeAccountTransactionV1 txSignatures txHeader txPayload + let res = + runIdentity $ + (runTransactionVerifierT $ runTVTM $ TVer.verifyExtendedTransaction tx) + testData + assertEqual + "The verification should yield the expected `NotOk SponsoredTransactionMissingSponsorSignature` result" + (TVer.NotOk TVer.SponsoredTransactionMissingSponsorSignature) + res + it "A transaction with no sponsor address but a sponsor signature should be rejected" $ do + let + txHeader = + TransactionHeaderV1 + { thv1HeaderV0 = + TransactionHeader + { thSender = senderAccountAddress, + thNonce = 2, + thEnergyAmount = 302, + thPayloadSize = 8, + thExpiry = 0 + }, + thv1Sponsor = Nothing + } + txPayload = EncodedPayload "deadbeef" + txBodyHash = transactionV1SignHashFromHeaderPayload txHeader txPayload + senderTxSignature = makeTxSignature senderKeyPair txBodyHash + sponsorTxSignature = makeTxSignature sponsorKeyPair txBodyHash + txSignatures = + TransactionSignaturesV1 + { tsv1Sender = senderTxSignature, + tsv1Sponsor = Just sponsorTxSignature + } + tx = makeAccountTransactionV1 txSignatures txHeader txPayload + let res = + runIdentity $ + (runTransactionVerifierT $ runTVTM $ TVer.verifyExtendedTransaction tx) + testData + assertEqual + "The verification should yield the expected `NotOk SponsoredTransactionMissingSponsor` result" + (TVer.NotOk TVer.SponsoredTransactionMissingSponsor) + res + it "An extended transaction with too little energy should be rejected" $ do + let + txHeader = + TransactionHeaderV1 + { thv1HeaderV0 = + TransactionHeader + { thSender = senderAccountAddress, + thNonce = 2, + -- cost: 302 + -- V1 header: 2 (bitmap) + 60 (V0 header) + 32 (sponsor address) = 94 + -- payload: 8 + -- signatures: 2 * 100 + thEnergyAmount = 301, + thPayloadSize = 8, + thExpiry = 0 + }, + thv1Sponsor = Just sponsorAccountAddress + } + txPayload = EncodedPayload "deadbeef" + txBodyHash = transactionV1SignHashFromHeaderPayload txHeader txPayload + senderTxSignature = makeTxSignature senderKeyPair txBodyHash + sponsorTxSignature = makeTxSignature sponsorKeyPair txBodyHash + txSignatures = + TransactionSignaturesV1 + { tsv1Sender = senderTxSignature, + tsv1Sponsor = Just sponsorTxSignature + } + tx = makeAccountTransactionV1 txSignatures txHeader txPayload + let res = + runIdentity $ + (runTransactionVerifierT $ runTVTM $ TVer.verifyExtendedTransaction tx) + testData + assertEqual + "The verification should yield the expected `NotOk NormalTransactionDepositInsufficient` result" + (TVer.NotOk TVer.NormalTransactionDepositInsufficient) + res + it "An extended transaction with energy exceeding the maximally allowed energy should be rejected" $ do + let + txHeader = + TransactionHeaderV1 + { thv1HeaderV0 = + TransactionHeader + { thSender = senderAccountAddress, + thNonce = 2, + -- max energy is set by the TVTM mock to 1000 + thEnergyAmount = fromIntegral $ (1000 + 1 :: Int), + thPayloadSize = 8, + thExpiry = 0 + }, + thv1Sponsor = Just sponsorAccountAddress + } + txPayload = EncodedPayload "deadbeef" + txBodyHash = transactionV1SignHashFromHeaderPayload txHeader txPayload + senderTxSignature = makeTxSignature senderKeyPair txBodyHash + sponsorTxSignature = makeTxSignature sponsorKeyPair txBodyHash + txSignatures = + TransactionSignaturesV1 + { tsv1Sender = senderTxSignature, + tsv1Sponsor = Just sponsorTxSignature + } + tx = makeAccountTransactionV1 txSignatures txHeader txPayload + let res = + runIdentity $ + (runTransactionVerifierT $ runTVTM $ TVer.verifyExtendedTransaction tx) + testData + assertEqual + "The verification should yield the expected `MaybeOk NormalTransactionEnergyExceeded` result" + (TVer.MaybeOk TVer.NormalTransactionEnergyExceeded) + res + + it "An extended transaction with nonce < next expected nonce should not pass verification" $ do + let + txHeader = + TransactionHeaderV1 + { thv1HeaderV0 = + TransactionHeader + { thSender = senderAccountAddress, + thNonce = 1, + thEnergyAmount = 302, + thPayloadSize = 8, + thExpiry = 0 + }, + thv1Sponsor = Just sponsorAccountAddress + } + txPayload = EncodedPayload "deadbeef" + txBodyHash = transactionV1SignHashFromHeaderPayload txHeader txPayload + senderTxSignature = makeTxSignature senderKeyPair txBodyHash + sponsorTxSignature = makeTxSignature sponsorKeyPair txBodyHash + txSignatures = + TransactionSignaturesV1 + { tsv1Sender = senderTxSignature, + tsv1Sponsor = Just sponsorTxSignature + } + tx = makeAccountTransactionV1 txSignatures txHeader txPayload + let res = + runIdentity $ + (runTransactionVerifierT $ runTVTM $ TVer.verifyExtendedTransaction tx) + testData + assertEqual + "The verification should yield the expected `NotOk NormalTransactionDuplicateNonce` result" + (TVer.NotOk $ TVer.NormalTransactionDuplicateNonce 1) + res + it "An extended transaction with nonce > next expected nonce should not pass verification if `checkExactNonce == True`" $ do + let + txHeader = + TransactionHeaderV1 + { thv1HeaderV0 = + TransactionHeader + { thSender = senderAccountAddress, + -- the expected nonce is 2 + thNonce = 3, + thEnergyAmount = 302, + thPayloadSize = 8, + thExpiry = 0 + }, + thv1Sponsor = Just sponsorAccountAddress + } + txPayload = EncodedPayload "deadbeef" + txBodyHash = transactionV1SignHashFromHeaderPayload txHeader txPayload + senderTxSignature = makeTxSignature senderKeyPair txBodyHash + sponsorTxSignature = makeTxSignature sponsorKeyPair txBodyHash + txSignatures = + TransactionSignaturesV1 + { tsv1Sender = senderTxSignature, + tsv1Sponsor = Just sponsorTxSignature + } + tx = makeAccountTransactionV1 txSignatures txHeader txPayload + let res = + runIdentity $ + (runTransactionVerifierT $ runTVTM $ TVer.verifyExtendedTransaction tx) + testData + assertEqual + "The verification should yield the expected `MaybeOk NormalTransactionInvalidNonce` result" + (TVer.MaybeOk $ TVer.NormalTransactionInvalidNonce 2) + res + it "An extended transaction with nonce > next expected nonce should pass verification if `checkExactNonce == False`" $ do + let + txHeader = + TransactionHeaderV1 + { thv1HeaderV0 = + TransactionHeader + { thSender = senderAccountAddress, + -- the expected nonce is 1 + thNonce = 3, + thEnergyAmount = 302, + thPayloadSize = 8, + thExpiry = 0 + }, + thv1Sponsor = Just sponsorAccountAddress + } + txPayload = EncodedPayload "deadbeef" + txBodyHash = transactionV1SignHashFromHeaderPayload txHeader txPayload + senderTxSignature = makeTxSignature senderKeyPair txBodyHash + sponsorTxSignature = makeTxSignature sponsorKeyPair txBodyHash + txSignatures = + TransactionSignaturesV1 + { tsv1Sender = senderTxSignature, + tsv1Sponsor = Just sponsorTxSignature + } + tx = makeAccountTransactionV1 txSignatures txHeader txPayload + let res = + runIdentity $ + (runTransactionVerifierT $ runTVTM $ TVer.verifyExtendedTransaction tx) + testDataNotExactNonce + assertEqual + "The verification should yield the expected `Ok ExtendedTransactionSuccess` result" + ( TVer.Ok + TVer.ExtendedTransactionSuccess + { senderKeysHash = getHash senderAccountVerificationKeys, + sponsorKeysHash = Present $ getHash sponsorAccountVerificationKeys, + nonce = 3 + } + ) + res + it "An extended transaction with sponsor but missing sponsor account should not pass verification" $ do + let + txHeader = + TransactionHeaderV1 + { thv1HeaderV0 = + TransactionHeader + { thSender = senderAccountAddress, + thNonce = 2, + thEnergyAmount = 302, + thPayloadSize = 8, + thExpiry = 0 + }, + thv1Sponsor = Just sponsorAccountAddress + } + txPayload = EncodedPayload "deadbeef" + txBodyHash = transactionV1SignHashFromHeaderPayload txHeader txPayload + senderTxSignature = makeTxSignature senderKeyPair txBodyHash + sponsorTxSignature = makeTxSignature sponsorKeyPair txBodyHash + txSignatures = + TransactionSignaturesV1 + { tsv1Sender = senderTxSignature, + tsv1Sponsor = Just sponsorTxSignature + } + tx = makeAccountTransactionV1 txSignatures txHeader txPayload + let res = + runIdentity $ + (runTransactionVerifierT $ runTVTM $ TVer.verifyExtendedTransaction tx) + testDataNoSponsor + assertEqual + "The verification should yield the expected `MaybeOk ExtendedTransactionInvalidSponsor` result" + (TVer.MaybeOk $ TVer.ExtendedTransactionInvalidSponsor sponsorAccountAddress) + res + it "An extended transaction where the sponsor has too little funds should be rejected" $ do + let + txHeader = + TransactionHeaderV1 + { thv1HeaderV0 = + TransactionHeader + { thSender = senderAccountAddress, + thNonce = 2, + thEnergyAmount = 302, + thPayloadSize = 8, + thExpiry = 0 + }, + thv1Sponsor = Just sponsorAccountAddress + } + txPayload = EncodedPayload "deadbeef" + txBodyHash = transactionV1SignHashFromHeaderPayload txHeader txPayload + senderTxSignature = makeTxSignature senderKeyPair txBodyHash + sponsorTxSignature = makeTxSignature sponsorKeyPair txBodyHash + txSignatures = + TransactionSignaturesV1 + { tsv1Sender = senderTxSignature, + tsv1Sponsor = Just sponsorTxSignature + } + tx = makeAccountTransactionV1 txSignatures txHeader txPayload + let res = + runIdentity $ + (runTransactionVerifierT $ runTVTM $ TVer.verifyExtendedTransaction tx) + testDataTooLittleFunding + assertEqual + "The verification should yield the expected `MaybeOk NormalTransactionInsufficientFunds` result" + (TVer.MaybeOk $ TVer.NormalTransactionInsufficientFunds) + res + it "An extended transaction with invalid sender signature should be rejected" $ do + let + txHeader = + TransactionHeaderV1 + { thv1HeaderV0 = + TransactionHeader + { thSender = senderAccountAddress, + thNonce = 2, + thEnergyAmount = 302, + thPayloadSize = 8, + thExpiry = 0 + }, + thv1Sponsor = Just sponsorAccountAddress + } + txPayload = EncodedPayload "deadbeef" + txBodyHash = transactionV1SignHashFromHeaderPayload txHeader txPayload + senderTxSignature = + TransactionSignature $ + Map.singleton + 0 + ( Map.singleton + 0 + (SigScheme.sign senderKeyPair "nice_try") + ) + sponsorTxSignature = makeTxSignature sponsorKeyPair txBodyHash + txSignatures = + TransactionSignaturesV1 + { tsv1Sender = senderTxSignature, + tsv1Sponsor = Just sponsorTxSignature + } + tx = makeAccountTransactionV1 txSignatures txHeader txPayload + let res = + runIdentity $ + (runTransactionVerifierT $ runTVTM $ TVer.verifyExtendedTransaction tx) + testData + assertEqual + "The verification should yield the expected `MaybeOk NormalTransactionInvalidSignatures` result" + (TVer.MaybeOk $ TVer.NormalTransactionInvalidSignatures) + res + it "An extended transaction with invalid sponsor signature should be rejected" $ do + let + txHeader = + TransactionHeaderV1 + { thv1HeaderV0 = + TransactionHeader + { thSender = senderAccountAddress, + thNonce = 2, + thEnergyAmount = 302, + thPayloadSize = 8, + thExpiry = 0 + }, + thv1Sponsor = Just sponsorAccountAddress + } + txPayload = EncodedPayload "deadbeef" + txBodyHash = transactionV1SignHashFromHeaderPayload txHeader txPayload + senderTxSignature = makeTxSignature senderKeyPair txBodyHash + sponsorTxSignature = + TransactionSignature $ + Map.singleton + 0 + ( Map.singleton + 0 + (SigScheme.sign sponsorKeyPair "some_other_transaction") + ) + txSignatures = + TransactionSignaturesV1 + { tsv1Sender = senderTxSignature, + tsv1Sponsor = Just sponsorTxSignature + } + tx = makeAccountTransactionV1 txSignatures txHeader txPayload + let res = + runIdentity $ + (runTransactionVerifierT $ runTVTM $ TVer.verifyExtendedTransaction tx) + testData + assertEqual + "The verification should yield the expected `MaybeOk NormalTransactionInvalidSignatures` result" + (TVer.MaybeOk $ TVer.NormalTransactionInvalidSignatures) + res + where + senderAccountAddress = fst $ randomAccountAddress (mkStdGen 42) + sponsorAccountAddress = fst $ randomAccountAddress (mkStdGen 43) + ((senderSignKey, senderVerifyKey), _) = randomEd25519KeyPair $ mkStdGen 42 + senderKeyPair = + SigScheme.KeyPairEd25519 + { signKey = senderSignKey, + verifyKey = senderVerifyKey + } + ((sponsorSignKey, sponsorVerifyKey), _) = randomEd25519KeyPair $ mkStdGen 43 + sponsorKeyPair = + SigScheme.KeyPairEd25519 + { signKey = sponsorSignKey, + verifyKey = sponsorVerifyKey + } + mkAccountVerificationKeys key = + ID.AccountInformation + { aiCredentials = + Map.singleton + (ID.CredentialIndex 0) + ( ID.CredentialPublicKeys + { credKeys = Map.singleton 0 (SigScheme.VerifyKeyEd25519 key), + credThreshold = 0 + } + ), + aiThreshold = 0 + } + senderAccountVerificationKeys = mkAccountVerificationKeys senderVerifyKey + sponsorAccountVerificationKeys = mkAccountVerificationKeys sponsorVerifyKey + makeTxSignature keyPair txBodyHash = + TransactionSignature $ + Map.singleton + 0 + ( Map.singleton + 0 + (SigScheme.sign keyPair (transactionSignHashToByteString txBodyHash)) + ) + mkTestData :: Amount -> Amount -> Bool -> TransactionVerifierTestData pv + mkTestData senderAvailableAmount sponsorAvailableAmount checkExactNonce = + TransactionVerifierTestData + { tvtdAccounts = + Map.fromList + [ ( "sender_account", + AccountTestData + { -- transasction cost is `computeCost 1/3 302` = 100+2/3 + atdAccountAvailableAmount = senderAvailableAmount, + atdAccountNonce = 2, + atdAccountVerificationKeys = senderAccountVerificationKeys + } + ), + ( "sponsor_account", + AccountTestData + { atdAccountAvailableAmount = sponsorAvailableAmount, + atdAccountNonce = 2, + atdAccountVerificationKeys = sponsorAccountVerificationKeys + } + ) + ], + tvtdAccountsByAddress = + Map.fromList + [ (senderAccountAddress, "sender_account"), + (sponsorAccountAddress, "sponsor_account") + ], + tvtdEnergyRate = 1 % 3, + tvtdCheckExactNonce = checkExactNonce + } + -- the minimal funding for the test transactions + minFunding = 101 + testData = mkTestData minFunding minFunding True + testDataNotExactNonce = mkTestData minFunding minFunding False + testDataTooLittleFunding = mkTestData minFunding (minFunding - 1) True + -- test data with missing sponsor account + testDataNoSponsor :: TransactionVerifierTestData pv = + TransactionVerifierTestData + { tvtdAccounts = + Map.fromList + [ ( "sender_account", + AccountTestData + { atdAccountAvailableAmount = minFunding, + atdAccountNonce = 2, + atdAccountVerificationKeys = senderAccountVerificationKeys + } + ) + ], + tvtdAccountsByAddress = + Map.fromList + [ (senderAccountAddress, "sender_account") + ], + tvtdEnergyRate = 1 % 3, + tvtdCheckExactNonce = True + } + tests :: Spec tests = describe "KonsensusV1.TransactionProcessing" $ do Common.forEveryProtocolVersionConsensusV1 $ \spv pvString -> @@ -626,3 +1270,6 @@ tests = describe "KonsensusV1.TransactionProcessing" $ do describe "P9" $ do describe "Transaction verification" $ testTransactionVerification SP9 + describe "P10" $ do + describe "ExtendedTransaction verification" $ + testExtendedTransactionVerification SP10 From 55751d0be9c8ce494aa6173656139546f55fb173 Mon Sep 17 00:00:00 2001 From: Thomas Dinsdale-Young Date: Tue, 25 Nov 2025 17:43:01 +0100 Subject: [PATCH 13/26] Sponsored transaction fixes. --- concordium-base | 2 +- .../GlobalState/Persistent/TreeState.hs | 15 ++- .../GlobalState/TransactionTable.hs | 31 ++++- .../Concordium/KonsensusV1/Transactions.hs | 18 +-- .../KonsensusV1/TreeState/Implementation.hs | 8 +- .../src/Concordium/MultiVersion.hs | 5 +- .../src/Concordium/Queries.hs | 7 +- .../src/Concordium/Scheduler.hs | 125 ++++++++++-------- .../src/Concordium/Scheduler/Environment.hs | 15 ++- .../src/Concordium/Scheduler/Runner.hs | 6 +- .../src/Concordium/Skov/Update.hs | 16 +-- concordium-consensus/test-runners/app/Main.hs | 2 +- .../test-runners/catchup/Main.hs | 2 +- .../EndToEnd/CredentialDeploymentTests.hs | 6 +- .../TransactionTableIntegrationTest.hs | 8 +- .../ConcordiumTests/KonsensusV1/LMDB.hs | 15 +-- .../KonsensusV1/TransactionProcessingTest.hs | 18 +-- .../KonsensusV1/TreeStateTest.hs | 68 +++++----- .../ReceiveTransactionsTest.hs | 63 ++++----- .../SchedulerTests/AccountTransactionSpecs.hs | 2 +- .../SchedulerTests/BlockEnergyLimitSpec.hs | 6 +- .../InitialAccountCreationSpec.hs | 2 +- .../TransactionGroupingSpec2.hs | 4 +- concordium-node/src/grpc2.rs | 6 +- 24 files changed, 248 insertions(+), 202 deletions(-) diff --git a/concordium-base b/concordium-base index da88ca0d8b..00795e8890 160000 --- a/concordium-base +++ b/concordium-base @@ -1 +1 @@ -Subproject commit da88ca0d8bd2b1e6a7f5b411321d266035a8a334 +Subproject commit 00795e88900de30de0d1a30320b9524e303ffff8 diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/TreeState.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/TreeState.hs index 3570cb781f..f702ccc302 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/TreeState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/TreeState.hs @@ -902,12 +902,17 @@ instance mAcc <- getAccount lfbState $ transactionSender tr nonce <- maybe (pure minNonce) getAccountNonce (snd <$> mAcc) return $! nonce <= transactionNonce tr + ExtendedTransaction tr -> do + lfbState <- use (skovPersistentData . lastFinalized . to _bpState) + mAcc <- getAccount lfbState $ transactionSender tr + nonce <- maybe (pure minNonce) getAccountNonce (snd <$> mAcc) + return $! nonce <= transactionNonce tr -- We need to check here that the nonce is still ok with respect to the last finalized block, -- because it could be that a block was finalized thus the next account nonce being incremented -- after this transaction was received and pre-verified. CredentialDeployment{} -> not <$> memberTransactionTable wmdHash -- the sequence number will be checked by @Impl.addTransaction@. - _ -> return True + ChainUpdate{} -> return True if mayAddTransaction then do let ~(added, newTT) = addTransaction bi 0 verRes tt @@ -929,7 +934,7 @@ instance type FinTrans (PersistentTreeStateMonad state m) = [(TransactionHash, FinalizedTransactionStatus)] finalizeTransactions bh slot txs = mapM finTrans txs where - finTrans WithMetadata{wmdData = NormalTransaction tr, ..} = do + finAccountTrans WithMetadata{wmdData = tr, ..} = do let nonce = transactionNonce tr sender = accountAddressEmbed (transactionSender tr) anft <- use (skovPersistentData . transactionTable . ttNonFinalizedTransactions . at' sender . non emptyANFT) @@ -950,6 +955,8 @@ instance return ss else do logErrorAndThrowTS $ "Tried to finalize transaction which is not known to be in the set of non-finalized transactions for the sender " ++ show sender + finTrans WithMetadata{wmdData = NormalTransaction tr, ..} = + finAccountTrans WithMetadata{wmdData = TransactionV0 tr, ..} finTrans WithMetadata{wmdData = CredentialDeployment{}, ..} = deleteAndFinalizeStatus wmdHash finTrans WithMetadata{wmdData = ChainUpdate cu, ..} = do @@ -976,8 +983,8 @@ instance . at' uty ?= (nfcu & (nfcuMap . at' sn .~ Nothing) & (nfcuNextSequenceNumber .~ sn + 1)) return ss - finTrans WithMetadata{wmdData = ExtendedTransaction{}} = - error "TODO(SP0-10): transaction verifier support for sponsored transactions" + finTrans WithMetadata{wmdData = ExtendedTransaction tr, ..} = + finAccountTrans WithMetadata{wmdData = TransactionV1 tr, ..} deleteAndFinalizeStatus txHash = do status <- preuse (skovPersistentData . transactionTable . ttHashMap . ix txHash . _2) diff --git a/concordium-consensus/src/Concordium/GlobalState/TransactionTable.hs b/concordium-consensus/src/Concordium/GlobalState/TransactionTable.hs index 6cb3062863..f9d633f4a7 100644 --- a/concordium-consensus/src/Concordium/GlobalState/TransactionTable.hs +++ b/concordium-consensus/src/Concordium/GlobalState/TransactionTable.hs @@ -265,18 +265,26 @@ addTransaction blockItem@WithMetadata{..} cp !verRes tt0 = senderANFT = ttNonFinalizedTransactions . at' sender . non anft anft = emptyANFT nonce = transactionNonce tr - wmdtr = WithMetadata{wmdData = tr, ..} + wmdtr = WithMetadata{wmdData = TransactionV0 tr, ..} CredentialDeployment{} -> (True, tt1) ChainUpdate cu | tt0 ^. utNFCU . nfcuNextSequenceNumber <= sn -> (True, tt1 & utNFCU . nfcuMap . at' sn . non Map.empty . at' wmdcu ?~ verRes) + | otherwise -> (False, tt0) where uty = updateType (uiPayload cu) sn = updateSeqNumber (uiHeader cu) utNFCU :: Lens' TransactionTable NonFinalizedChainUpdates utNFCU = ttNonFinalizedChainUpdates . at' uty . non emptyNFCU wmdcu = WithMetadata{wmdData = cu, ..} - _ -> (False, tt0) + ExtendedTransaction tr -> (True, tt1 & senderANFT . anftMap . at' nonce . non Map.empty . at' wmdtr ?~ verRes) + where + sender = accountAddressEmbed (transactionSender tr) + senderANFT :: Lens' TransactionTable AccountNonFinalizedTransactions + senderANFT = ttNonFinalizedTransactions . at' sender . non anft + anft = emptyANFT + nonce = transactionNonce tr + wmdtr = WithMetadata{wmdData = TransactionV1 tr, ..} where tt1 = tt0 & ttHashMap . at' wmdHash ?~ (blockItem, Received cp verRes) @@ -414,8 +422,14 @@ forwardPTT trs ptt0 = foldl' forward1 ptt0 trs assert (low == updateSeqNumber (uiHeader biUpdate)) $ assert (low <= high) $ if low == high then Nothing else Just (low + 1, high) - forward1 _ptt WithMetadata{wmdData = ExtendedTransaction{}} = - error "TODO(SPO-10): transaction verifier support for sponsored transactions" + forward1 ptt WithMetadata{wmdData = ExtendedTransaction tr} = ptt & pttWithSender . at' sender %~ upd + where + sender = accountAddressEmbed (transactionSender tr) + upd Nothing = error "forwardPTT : forwarding transaction that is not pending" + upd (Just (low, high)) = + assert (low == transactionNonce tr) $ + assert (low <= high) $ + if low == high then Nothing else Just (low + 1, high) -- | Update the pending transaction table by considering the supplied 'BlockItem's -- pending again. The 'BlockItem's must be ordered correctly with respect @@ -431,6 +445,13 @@ reversePTT trs ptt0 = foldr reverse1 ptt0 trs upd (Just (low, high)) = assert (low == transactionNonce tr + 1) $ Just (low - 1, high) + reverse1 WithMetadata{wmdData = ExtendedTransaction tr} = pttWithSender . at' sender %~ upd + where + sender = accountAddressEmbed (transactionSender tr) + upd Nothing = Just (transactionNonce tr, transactionNonce tr) + upd (Just (low, high)) = + assert (low == transactionNonce tr + 1) $ + Just (low - 1, high) reverse1 WithMetadata{wmdData = CredentialDeployment{}, ..} = pttDeployCredential %~ upd where upd ps = assert (not (HS.member wmdHash ps)) $ HS.insert wmdHash ps @@ -441,8 +462,6 @@ reversePTT trs ptt0 = foldr reverse1 ptt0 trs upd (Just (low, high)) = assert (low == sn + 1) $ Just (low - 1, high) - reverse1 WithMetadata{wmdData = ExtendedTransaction{}} = - error "TODO(SPO-10): transaction verifier support for sponsored transactions" -- | Returns the next available account nonce for the -- provided account address from the perspective of the 'TransactionTable'. diff --git a/concordium-consensus/src/Concordium/KonsensusV1/Transactions.hs b/concordium-consensus/src/Concordium/KonsensusV1/Transactions.hs index 51d20bac1f..65e7417f29 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/Transactions.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/Transactions.hs @@ -120,13 +120,8 @@ addPendingTransaction :: m () addPendingTransaction bi = do case wmdData bi of - NormalTransaction tx -> do - fbState <- bpState <$> (Impl._focusBlock <$> gets' Impl._skovPendingTransactions) - macct <- getAccount fbState $! transactionSender tx - nextNonce <- fromMaybe minNonce <$> mapM (getAccountNonce . snd) macct - when (nextNonce <= transactionNonce tx) $ do - Impl.pendingTransactionTable %=! TT.addPendingTransaction nextNonce tx - Impl.purgeTransactionTable False =<< currentTime + NormalTransaction tx -> addPendingAccountTransaction (TransactionV0 tx) + ExtendedTransaction tx -> addPendingAccountTransaction (TransactionV1 tx) CredentialDeployment _ -> do Impl.pendingTransactionTable %=! TT.addPendingDeployCredential txHash Impl.purgeTransactionTable False =<< currentTime @@ -136,10 +131,15 @@ addPendingTransaction bi = do when (nextSN <= updateSeqNumber (uiHeader cu)) $ do Impl.pendingTransactionTable %=! TT.addPendingUpdate nextSN cu Impl.purgeTransactionTable False =<< currentTime - ExtendedTransaction _tx -> - error "TODO(SP0-10): transaction verifier support for sponsored transactions" where txHash = getHash bi + addPendingAccountTransaction tx = do + fbState <- bpState <$> (Impl._focusBlock <$> gets' Impl._skovPendingTransactions) + macct <- getAccount fbState $! transactionSender tx + nextNonce <- fromMaybe minNonce <$> mapM (getAccountNonce . snd) macct + when (nextNonce <= transactionNonce tx) $ do + Impl.pendingTransactionTable %=! TT.addPendingTransaction nextNonce tx + Impl.purgeTransactionTable False =<< currentTime -- | Attempt to put the 'BlockItem' into the tree state. -- If the the 'BlockItem' was successfully added then it will be diff --git a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/Implementation.hs b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/Implementation.hs index 3df9af5804..e6524875e8 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/Implementation.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/Implementation.hs @@ -845,7 +845,7 @@ finalizeTransactions :: m () finalizeTransactions = mapM_ removeTrans where - removeTrans WithMetadata{wmdData = NormalTransaction tr, ..} = do + removeAccountTrans WithMetadata{wmdData = tr, ..} = do let nonce = transactionNonce tr sender = accountAddressEmbed (transactionSender tr) anft <- use (transactionTable . TT.ttNonFinalizedTransactions . at' sender . non TT.emptyANFT) @@ -865,6 +865,10 @@ finalizeTransactions = mapM_ removeTrans -- If there are no non-finalized transactions left then remove the entry -- for the sender in @ttNonFinalizedTransactions@. transactionTable %=! TT.finalizeTransactionAt sender nonce + removeTrans WithMetadata{wmdData = NormalTransaction tr, ..} = do + removeAccountTrans (WithMetadata{wmdData = TransactionV0 tr, ..}) + removeTrans WithMetadata{wmdData = ExtendedTransaction tr, ..} = do + removeAccountTrans (WithMetadata{wmdData = TransactionV1 tr, ..}) removeTrans WithMetadata{wmdData = CredentialDeployment{}, ..} = do transactionTable . TT.ttHashMap . at' wmdHash .= Nothing removeTrans WithMetadata{wmdData = ChainUpdate cu, ..} = do @@ -896,8 +900,6 @@ finalizeTransactions = mapM_ removeTrans . TT.ttNonFinalizedChainUpdates . at' uty ?=! (nfcu & (TT.nfcuMap . at' sn .~ Nothing) & (TT.nfcuNextSequenceNumber .~ sn + 1)) - removeTrans WithMetadata{wmdData = ExtendedTransaction{}} = - error "TODO(SP0-10): transaction verifier support for sponsored transactions" -- | Mark a live transaction as committed in a particular block. -- This does nothing if the transaction is not live. diff --git a/concordium-consensus/src/Concordium/MultiVersion.hs b/concordium-consensus/src/Concordium/MultiVersion.hs index f2264f8c03..022a31e8c9 100644 --- a/concordium-consensus/src/Concordium/MultiVersion.hs +++ b/concordium-consensus/src/Concordium/MultiVersion.hs @@ -2115,6 +2115,7 @@ receiveTransaction transactionBS = handleMVRExceptionsWith (Nothing, Skov.Result _ -> return $! Skov.transactionVerificationResultToUpdateResult verRes (EVersionedConfigurationV1 (vc :: VersionedConfigurationV1 finconf pv)) -> withDeserializedTransaction (protocolVersion @pv) now $ \transaction -> do + logEvent Runner LLDebug $ "Transaction: " ++ show transaction st <- liftIO $ readIORef $ vc1State vc (known, verRes) <- SkovV1.evalSkovT (SkovV1.preverifyTransaction transaction) (vc1Context vc) st @@ -2132,7 +2133,9 @@ receiveTransaction transactionBS = handleMVRExceptionsWith (Nothing, Skov.Result else do -- A protocol update has occurred. receiveUnverified (Vec.last vvec') transaction - _ -> return $! Skov.transactionVerificationResultToUpdateResult verRes + _ -> do + logEvent Runner LLWarning $ "Transaction received: " ++ show transaction ++ " gave result " ++ show verRes + return $! Skov.transactionVerificationResultToUpdateResult verRes where withDeserializedTransaction :: SProtocolVersion spv -> diff --git a/concordium-consensus/src/Concordium/Queries.hs b/concordium-consensus/src/Concordium/Queries.hs index 16ec7edc21..9a976bdd79 100644 --- a/concordium-consensus/src/Concordium/Queries.hs +++ b/concordium-consensus/src/Concordium/Queries.hs @@ -852,10 +852,11 @@ getBlockTransactionSummaries = (item : items') -> do State.put items' let mInitParam = do - accTransaction <- case wmdData item of - NormalTransaction t -> return t + payload <- case wmdData item of + NormalTransaction t -> return (transactionPayload t) + ExtendedTransaction t -> return (transactionPayload t) _ -> Left "Initialization event is not for an account transaction" - decoded <- decodePayload spv (atrPayload accTransaction) + decoded <- decodePayload spv payload case decoded of InitContract{..} -> return icParam _ -> Left "Initialization event is not for a contract initialization" diff --git a/concordium-consensus/src/Concordium/Scheduler.hs b/concordium-consensus/src/Concordium/Scheduler.hs index 9bd803b0e6..57051a42cf 100644 --- a/concordium-consensus/src/Concordium/Scheduler.hs +++ b/concordium-consensus/src/Concordium/Scheduler.hs @@ -106,6 +106,7 @@ import Concordium.GlobalState.Persistent.BlockState.ProtocolLevelTokens (PLTConf import qualified Concordium.Scheduler.ProtocolLevelTokens.Module as TokenModule import Concordium.Scheduler.WasmIntegration.V1 (ReceiveResultData (rrdCurrentState)) import Concordium.Types.Accounts +import Concordium.Types.Option import Concordium.Wasm (IsWasmVersion) import qualified Concordium.Wasm as GSWasm import Data.Either (isLeft) @@ -156,52 +157,71 @@ checkHeader meta mVerRes = do cm <- lift getChainMetadata when (transactionExpired (thExpiry $ transactionHeader meta) $ slotTime cm) $ throwError . Just $ ExpiredTransaction - let addr = transactionSender meta - miacc <- lift (getStateAccount addr) - case miacc of - -- check if the sender is present on the chain. - Nothing -> throwError (Just $ UnknownAccount addr) - Just iacc -> do - -- The sender exists and thus we continue verifying the transaction. - - -- We check if we previously have deemed the transaction valid and check if the - -- current account information matches with one at the point of verification. - -- Also we check that the nonce is valid and that the sender has enough funds to cover his transfer. - let acc = snd iacc - case mVerRes of - Just (TVer.Ok (TVer.NormalTransactionSuccess keysHash _)) -> do - currentKeys <- lift (TVer.getAccountVerificationKeys acc) - -- Check that the keys match from initial verification. - -- If they match we skip checking the signature as it has already been verified. - if ID.matchesAccountInformation currentKeys keysHash - then do - checkNonceAndFunds acc - return (CheckHeaderResult iacc iacc cost) - -- the account information has changed, so we re-verify the signature. - else do - unless (verifyTransaction currentKeys meta) (throwError $ Just IncorrectSignature) - checkNonceAndFunds acc - return (CheckHeaderResult iacc iacc cost) - -- An invalid verification result or `Nothing` was supplied to this function. - -- In either case we verify the transaction now. - -- Note: we do not have special handling for 'TVer.TrustedSuccess'. - -- Since the case is uncommon, it is reasonable to redo the verification. - _ -> do - newVerRes <- lift (TVer.verifyNormalTransaction meta) - case checkTransactionVerificationResult newVerRes of - Left failure -> throwError . Just $ failure - Right _ -> return (CheckHeaderResult iacc iacc cost) - where - -- check that the nonce is ok and that the sender has enough funds to cover the transaction fee deposit. - checkNonceAndFunds acc = do - -- Check that the nonce is still 'Ok'. - nextNonce <- lift (TVer.getNextAccountNonce acc) - let nonce = transactionNonce meta - unless (nonce == nextNonce) $ throwError (Just $ NonSequentialNonce nonce) - -- Check that the account still has enough funds to cover the deposit - amnt <- lift (TVer.getAccountAvailableAmount acc) - depositedAmount <- lift (TVer.energyToCcd (transactionGasAmount meta)) - unless (depositedAmount <= amnt) $ throwError $ Just InsufficientFunds + let senderAddr = transactionSender meta + -- Check that the sender is present on the chain. + senderAccount <- + lift (getStateAccount senderAddr) >>= \case + Nothing -> throwError (Just $ UnknownAccount senderAddr) + Just senderAccount -> return senderAccount + -- Check that the sponsor (if any) is present on the chain. + -- If there is no sponsor, payerAccount will be the senderAccount. + payerAccount <- case transactionSponsor meta of + Nothing -> return senderAccount + Just sponsorAddr -> + lift (getStateAccount sponsorAddr) >>= \case + Nothing -> throwError (Just $ UnknownAccount sponsorAddr) + Just sponsorAccount -> return sponsorAccount + -- The sender exists and thus we continue verifying the transaction. + + -- We check if we previously have deemed the transaction valid and check if the + -- current account information matches with one at the point of verification. + -- Also we check that the nonce is valid and that the sender has enough funds to cover his transfer. + let senderAcc = snd senderAccount + + let bodyHash = transactionSignHashToByteString (transactionSignHash meta) + validateAccountKeys account expectedKeys signature = do + actualKeys <- lift (TVer.getAccountVerificationKeys (snd account)) + unless (ID.matchesAccountInformation actualKeys expectedKeys) $ do + -- The account keys have changed, so we re-verify the signature. + -- Note, the keys changing does not automatically mean the signature is invalid, + -- since it could be a subset of keys that have not changed. + unless (verifyAccountSignature bodyHash (tsSignatures signature) actualKeys) $ + throwError (Just IncorrectSignature) + checkNonceAndFunds = do + -- Check that the sender's nonce is OK. + nextNonce <- lift (TVer.getNextAccountNonce senderAcc) + let nonce = transactionNonce meta + unless (nonce == nextNonce) $ throwError (Just $ NonSequentialNonce nonce) + -- Check that the payer account still has enough funds to cover the deposit + amnt <- lift (TVer.getAccountAvailableAmount (snd payerAccount)) + depositedAmount <- lift (TVer.energyToCcd (transactionGasAmount meta)) + unless (depositedAmount <= amnt) $ throwError $ Just InsufficientFunds + case mVerRes of + Just (TVer.Ok (TVer.NormalTransactionSuccess keysHash _)) + | Nothing <- transactionSponsorSignature meta -> do + validateAccountKeys senderAccount keysHash (transactionSignature meta) + checkNonceAndFunds + Just (TVer.Ok (TVer.ExtendedTransactionSuccess{sponsorKeysHash = Absent, ..})) + | Nothing <- transactionSponsorSignature meta -> do + validateAccountKeys senderAccount senderKeysHash (transactionSignature meta) + checkNonceAndFunds + Just (TVer.Ok (TVer.ExtendedTransactionSuccess{sponsorKeysHash = Present sponsorHash, ..})) + | Just sponsorSig <- transactionSponsorSignature meta -> do + validateAccountKeys senderAccount senderKeysHash (transactionSignature meta) + validateAccountKeys payerAccount sponsorHash sponsorSig + checkNonceAndFunds + -- An invalid verification result or `Nothing` was supplied to this function. + -- In either case we verify the transaction now. + -- Note: we do not have special handling for 'TVer.TrustedSuccess'. + -- Since the case is uncommon, it is reasonable to redo the verification. + _ -> do + -- Although the transaction may be a normal (non-extended) transaction, we verify it + -- as an extended transaction, which should produce the same result + newVerRes <- lift (TVer.verifyExtendedTransaction meta) + case checkTransactionVerificationResult newVerRes of + Left failure -> throwError . Just $ failure + Right _ -> return () + return (CheckHeaderResult senderAccount payerAccount cost) -- | Maps transaction verification results into Either `FailureKind`s. or `OkResult`s checkTransactionVerificationResult :: TVer.VerificationResult -> Either FailureKind TVer.OkResult @@ -316,6 +336,7 @@ dispatchTransactionBody msg CheckHeaderResult{..} = do } Right payload -> do usedBlockEnergy <- getUsedEnergy + logEvent Scheduler LLInfo $ "Executing transaction with sender " ++ show (thSender meta) ++ " and sponsor " ++ show (transactionSponsor msg) ++ ". Payer index: " ++ show (fst chrPayerAccount) let mkWTC _wtcTransactionType = WithDepositContext { _wtcSenderAccount = chrSenderAccount, @@ -3176,7 +3197,7 @@ filterTransactions maxSize timeout groups0 = do newFts = currentFts { ftFailedUpdates = ((,NonSequentialNonce (curSN + 1)) <$> invalid) ++ ftFailedUpdates currentFts, - ftAdded = (ui & _1 %~ chainUpdate, summary) : ftAdded currentFts + ftAdded = (ui & _1 %~ toBlockItem, summary) : ftAdded currentFts } runUpdateInstructions csize newFts rest -- The cumulative block size with this update is too high. @@ -3214,7 +3235,7 @@ filterTransactions maxSize timeout groups0 = do runNext maxEnergy size (credLimit - 1) False newFts groups -- NB: We keep the old size Just (TxValid summary) -> do markEnergyUsed (tsEnergyCost summary) - let newFts = fts{ftAdded = ((credentialDeployment c, verRes), summary) : ftAdded fts} + let newFts = fts{ftAdded = ((toBlockItem c, verRes), summary) : ftAdded fts} runNext maxEnergy csize (credLimit - 1) False newFts groups Nothing -> error "Unreachable due to cenergy <= maxEnergy check." else @@ -3301,7 +3322,7 @@ filterTransactions maxSize timeout groups0 = do { ftFailed = map (,NonSequentialNonce nextNonce) invalid ++ ftFailed currentFts, - ftAdded = ((normalTransaction (fst t), snd t), summary) : ftAdded currentFts + ftAdded = ((toBlockItem (fst t), snd t), summary) : ftAdded currentFts } return (newFts, rest) @@ -3354,8 +3375,7 @@ runTransactions = go [] predispatch (WithMetadata{wmdData = NormalTransaction tr, ..}, verRes) = dispatch (WithMetadata{wmdData = tr, ..}, verRes) predispatch (WithMetadata{wmdData = CredentialDeployment cred, ..}, verRes) = handleDeployCredential (WithMetadata{wmdData = cred, ..}, verRes) wmdHash predispatch (WithMetadata{wmdData = ChainUpdate cu, ..}, verRes) = Just <$> handleChainUpdate (WithMetadata{wmdData = cu, ..}, verRes) - predispatch (WithMetadata{wmdData = ExtendedTransaction _tr}, _verRes) = - error "TODO(SPO-10): transaction verifier support for sponsored transactions" + predispatch (WithMetadata{wmdData = ExtendedTransaction tr, ..}, verRes) = dispatch (WithMetadata{wmdData = tr, ..}, verRes) -- | Execute transactions in sequence. Like 'runTransactions' but only for side-effects on global state. -- @@ -3391,5 +3411,4 @@ execTransactions = go predispatch (WithMetadata{wmdData = NormalTransaction tr, ..}, verRes) = dispatch (WithMetadata{wmdData = tr, ..}, verRes) predispatch (WithMetadata{wmdData = CredentialDeployment cred, ..}, verRes) = handleDeployCredential (WithMetadata{wmdData = cred, ..}, verRes) wmdHash predispatch (WithMetadata{wmdData = ChainUpdate cu, ..}, verRes) = Just <$> handleChainUpdate (WithMetadata{wmdData = cu, ..}, verRes) - predispatch (WithMetadata{wmdData = ExtendedTransaction _tr}, _verRes) = - error "TODO(SPO-10): transaction verifier support for sponsored transactions" + predispatch (WithMetadata{wmdData = ExtendedTransaction tr, ..}, verRes) = dispatch (WithMetadata{wmdData = tr, ..}, verRes) diff --git a/concordium-consensus/src/Concordium/Scheduler/Environment.hs b/concordium-consensus/src/Concordium/Scheduler/Environment.hs index df563bbf7f..46cdf2ab76 100644 --- a/concordium-consensus/src/Concordium/Scheduler/Environment.hs +++ b/concordium-consensus/src/Concordium/Scheduler/Environment.hs @@ -987,6 +987,7 @@ computeExecutionCharge allocated unused = do -- balance such as DeployCredential, or DeployModule. chargeExecutionCostAccount :: forall m. (SchedulerMonad m) => IndexedAccount m -> Amount -> m () chargeExecutionCostAccount (ai, acc) amnt = do + logEvent Scheduler LLInfo $ "Charging execution cost of " ++ show amnt ++ " to " ++ show ai balance <- getAccountAmount acc let csWithAccountDelta = emptyCS (Proxy @m) & accountUpdates . at ai ?~ (emptyAccountUpdate ai & auAmount ?~ amountDiff 0 amnt) assert (balance >= amnt) $ @@ -1069,6 +1070,9 @@ withDeposit wtc comp k = do (setTransactionReturnValue . V1.returnValueToByteString) result (ls ^. transactionReturnValue) + let (tsCost, sponsorDetails) + | Just sponsorAddress <- wtc ^. wtcSponsorAddress = (0, Just $ SponsorDetails{sdSponsor = sponsorAddress, sdCost = tsCost}) + | otherwise = (tsCost, Nothing) case res of -- Failure: maximum block energy exceeded Left Nothing -> return Nothing @@ -1077,12 +1081,12 @@ withDeposit wtc comp k = do -- The only effect of this transaction is that the payer is charged for the execution cost -- (energy ticked so far). executionCharge <- computeChargeExecution wtc (ls ^. energyLeft) + return $! Just $! TransactionSummary { tsSender = Just (wtc ^. wtcSenderAddress), - tsCost = ecEnergyCost executionCharge, - tsSponsorDetails = conditionally cHasSponsorDetails Nothing, + tsSponsorDetails = conditionally cHasSponsorDetails sponsorDetails, tsEnergyCost = ecUsedEnergy executionCharge, tsResult = addReturn $ transactionReject reason, tsType = TSTAccountTransaction $ Just $ wtc ^. wtcTransactionType, @@ -1098,8 +1102,7 @@ withDeposit wtc comp k = do Just $! TransactionSummary { tsSender = Just (wtc ^. wtcSenderAddress), - tsCost = ecEnergyCost executionCharge, - tsSponsorDetails = conditionally cHasSponsorDetails Nothing, + tsSponsorDetails = conditionally cHasSponsorDetails sponsorDetails, tsEnergyCost = ecUsedEnergy executionCharge, tsType = TSTAccountTransaction $ Just $ wtc ^. wtcTransactionType, tsIndex = wtc ^. wtcTransactionIndex, @@ -1500,8 +1503,8 @@ logInvalidBlockItem WithMetadata{wmdData = CredentialDeployment cred} fk = logEvent Scheduler LLWarning $ "Credential with registration id " ++ (show . ID.credId . credential $ cred) ++ " was invalid with reason " ++ show fk logInvalidBlockItem WithMetadata{wmdData = ChainUpdate{}, ..} fk = logEvent Scheduler LLWarning $ "Chain update with hash " ++ show wmdHash ++ " was invalid with reason: " ++ show fk -logInvalidBlockItem WithMetadata{wmdData = ExtendedTransaction{}} _fk = - error "TODO(SPO-10): transaction verifier support for sponsored transactions" +logInvalidBlockItem WithMetadata{wmdData = ExtendedTransaction{}, ..} fk = + logEvent Scheduler LLWarning $ "Transaction with hash " ++ show wmdHash ++ " was invalid with reason: " ++ show fk {-# INLINE logInvalidTransaction #-} logInvalidTransaction :: (SchedulerMonad m) => TVer.TransactionWithStatus -> FailureKind -> m () diff --git a/concordium-consensus/src/Concordium/Scheduler/Runner.hs b/concordium-consensus/src/Concordium/Scheduler/Runner.hs index fa5c27c016..ae2894d8bf 100644 --- a/concordium-consensus/src/Concordium/Scheduler/Runner.hs +++ b/concordium-consensus/src/Concordium/Scheduler/Runner.hs @@ -172,9 +172,9 @@ processUngroupedBlockItems inpt = do return (map txMap txs) where txMap (Types.NormalTransaction x) = Types.TGAccountTransactions [(Types.fromAccountTransaction 0 x, Nothing)] - txMap (Types.CredentialDeployment x) = Types.TGCredentialDeployment (Types.addMetadata Types.CredentialDeployment 0 x, Nothing) - txMap (Types.ChainUpdate x) = Types.TGUpdateInstructions [(Types.addMetadata Types.ChainUpdate 0 x, Nothing)] - txMap (Types.ExtendedTransaction _x) = error "TODO(SPO-10): transaction verifier support for sponsored transactions" + txMap (Types.CredentialDeployment x) = Types.TGCredentialDeployment (Types.addMetadata 0 x, Nothing) + txMap (Types.ChainUpdate x) = Types.TGUpdateInstructions [(Types.addMetadata 0 x, Nothing)] + txMap (Types.ExtendedTransaction x) = Types.TGAccountTransactions [(Types.fromAccountTransactionV1 0 x, Nothing)] -- | For testing purposes: process transactions in the groups in which they came -- The arrival time of all transactions is taken to be 0. diff --git a/concordium-consensus/src/Concordium/Skov/Update.hs b/concordium-consensus/src/Concordium/Skov/Update.hs index ad58d5fefd..400c797bf4 100644 --- a/concordium-consensus/src/Concordium/Skov/Update.hs +++ b/concordium-consensus/src/Concordium/Skov/Update.hs @@ -815,8 +815,7 @@ doAddPreverifiedTransaction blockItem okRes = do case res of Added WithMetadata{..} verRes -> do ptrs <- getPendingTransactions - case wmdData of - NormalTransaction tx -> do + let addPreverifiedAccountTransaction tx = do -- Record the transaction in the pending transaction table. focus <- getFocusBlock st <- blockState focus @@ -825,6 +824,9 @@ doAddPreverifiedTransaction blockItem okRes = do when (nextNonce <= transactionNonce tx) $ putPendingTransactions $! addPendingTransaction nextNonce WithMetadata{wmdData = tx, ..} ptrs + case wmdData of + NormalTransaction tx -> addPreverifiedAccountTransaction (TransactionV0 tx) + ExtendedTransaction tx -> addPreverifiedAccountTransaction (TransactionV1 tx) CredentialDeployment _ -> do putPendingTransactions $! addPendingDeployCredential wmdHash ptrs ChainUpdate cu -> do @@ -834,8 +836,6 @@ doAddPreverifiedTransaction blockItem okRes = do when (nextSN <= updateSeqNumber (uiHeader cu)) $ putPendingTransactions $! addPendingUpdate nextSN cu ptrs - ExtendedTransaction _tx -> - error "TODO(SP0-10): transaction verifier support for sponsored transactions" purgeTransactionTable False =<< currentTime return $! transactionVerificationResultToUpdateResult verRes Duplicate{} -> return ResultDuplicate @@ -862,8 +862,7 @@ doReceiveTransactionInternal origin verifyBs tr ts slot = do addCommitTransaction tr ctx ts slot >>= \case Added bi@WithMetadata{..} verRes -> do ptrs <- getPendingTransactions - case wmdData of - NormalTransaction tx -> do + let addAccountTransaction tx = do -- Transactions received individually should always be added to the ptt. -- If the transaction was received as part of a block we only add it to the ptt if -- the transaction nonce is at least the `nextNonce` recorded for sender account. @@ -893,6 +892,9 @@ doReceiveTransactionInternal origin verifyBs tr ts slot = do -- the focus block, then we do not need to add it to the -- pending transactions. Otherwise, we do. when (nextNonce <= transactionNonce tx) $ add nextNonce + case wmdData of + NormalTransaction tx -> addAccountTransaction (TransactionV0 tx) + ExtendedTransaction tx -> addAccountTransaction (TransactionV1 tx) CredentialDeployment _ -> do putPendingTransactions $! addPendingDeployCredential wmdHash ptrs ChainUpdate cu -> do @@ -902,8 +904,6 @@ doReceiveTransactionInternal origin verifyBs tr ts slot = do when (nextSN <= updateSeqNumber (uiHeader cu)) $ putPendingTransactions $! addPendingUpdate nextSN cu ptrs - ExtendedTransaction _tx -> - error "TODO(SP0-10): transaction verifier support for sponsored transactions" -- The actual verification result here is only used if the transaction was received individually. -- If the transaction was received as part of a block we don't use the result for anything. diff --git a/concordium-consensus/test-runners/app/Main.hs b/concordium-consensus/test-runners/app/Main.hs index 143eff4252..7ed64d9730 100644 --- a/concordium-consensus/test-runners/app/Main.hs +++ b/concordium-consensus/test-runners/app/Main.hs @@ -86,7 +86,7 @@ protocolUpdateTransactions :: Timestamp -> [BlockItem] protocolUpdateTransactions (Timestamp ts) = [ui] where ui = - addMetadata id 0 $ + addMetadata 0 $ ChainUpdate $ makeUpdateInstruction RawUpdateInstruction diff --git a/concordium-consensus/test-runners/catchup/Main.hs b/concordium-consensus/test-runners/catchup/Main.hs index 15de0952f3..ed708cefb0 100644 --- a/concordium-consensus/test-runners/catchup/Main.hs +++ b/concordium-consensus/test-runners/catchup/Main.hs @@ -86,7 +86,7 @@ protocolUpdateTransactions :: Timestamp -> [BlockItem] protocolUpdateTransactions (Timestamp ts) = [ui] where ui = - addMetadata id 0 $ + addMetadata 0 $ ChainUpdate $ makeUpdateInstruction RawUpdateInstruction diff --git a/concordium-consensus/tests/consensus/ConcordiumTests/EndToEnd/CredentialDeploymentTests.hs b/concordium-consensus/tests/consensus/ConcordiumTests/EndToEnd/CredentialDeploymentTests.hs index 4c07616e85..f59ff093f8 100644 --- a/concordium-consensus/tests/consensus/ConcordiumTests/EndToEnd/CredentialDeploymentTests.hs +++ b/concordium-consensus/tests/consensus/ConcordiumTests/EndToEnd/CredentialDeploymentTests.hs @@ -62,21 +62,21 @@ cred3 = readAccountCreation . BSL.fromStrict $ $(makeRelativeToProject "testdata -- | A credential deployment transaction yielding cred1. credBi1 :: BlockItem credBi1 = - credentialDeployment $ addMetadata (\x -> CredentialDeployment{biCred = x}) (tt + 1) cred1 + makeBlockItem (tt + 1) cred1 where tt = utcTimeToTransactionTime testTime -- | A credential deployment transaction yielding cred2. credBi2 :: BlockItem credBi2 = - credentialDeployment $ addMetadata (\x -> CredentialDeployment{biCred = x}) (tt + 1) cred2 + makeBlockItem (tt + 1) cred2 where tt = utcTimeToTransactionTime testTime -- | A credential deployment transaction yielding cred3 credBi3 :: BlockItem credBi3 = - credentialDeployment $ addMetadata (\x -> CredentialDeployment{biCred = x}) (tt + 1) cred3 + makeBlockItem (tt + 1) cred3 where tt = utcTimeToTransactionTime testTime diff --git a/concordium-consensus/tests/consensus/ConcordiumTests/EndToEnd/TransactionTableIntegrationTest.hs b/concordium-consensus/tests/consensus/ConcordiumTests/EndToEnd/TransactionTableIntegrationTest.hs index 65c3197a56..55b023f45e 100644 --- a/concordium-consensus/tests/consensus/ConcordiumTests/EndToEnd/TransactionTableIntegrationTest.hs +++ b/concordium-consensus/tests/consensus/ConcordiumTests/EndToEnd/TransactionTableIntegrationTest.hs @@ -28,8 +28,8 @@ import qualified ConcordiumTests.KonsensusV1.Common as Common import ConcordiumTests.KonsensusV1.Consensus.Blocks hiding (testBB1, testBB2, testBB2', testBB3, testBB3', tests) -- | Make a raw transfer transaction with the provided nonce. -mkTransferTransaction :: Nonce -> BareBlockItem -mkTransferTransaction nonce = NormalTransaction{biTransaction = signTransactionSingle foundationKeyPair mkHeader payload} +mkTransferTransaction :: Nonce -> AccountTransaction +mkTransferTransaction nonce = signTransactionSingle foundationKeyPair mkHeader payload where mkHeader = TransactionHeader @@ -43,11 +43,11 @@ mkTransferTransaction nonce = NormalTransaction{biTransaction = signTransactionS -- | A transfer with nonce 1 for testBB1 transfer1 :: BlockItem -transfer1 = normalTransaction $ addMetadata (\x -> NormalTransaction{biTransaction = x}) 1000 (biTransaction $ mkTransferTransaction 1) +transfer1 = makeBlockItem 1000 (mkTransferTransaction 1) -- | A transfer with nonce 2 for testBB4 transfer2 :: BlockItem -transfer2 = normalTransaction $ addMetadata (\x -> NormalTransaction{biTransaction = x}) 1001 (biTransaction $ mkTransferTransaction 2) +transfer2 = makeBlockItem 1000 (mkTransferTransaction 2) -- | Valid block for round 1 with 1 normal transfer testBB1 :: forall pv. (IsProtocolVersion pv, IsConsensusV1 pv) => BakedBlock pv diff --git a/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/LMDB.hs b/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/LMDB.hs index c0bae4775b..2862cf0778 100644 --- a/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/LMDB.hs +++ b/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/LMDB.hs @@ -140,14 +140,13 @@ dummyTransactionHeader = -- data. dummyBlockItem :: BlockItem dummyBlockItem = - addMetadata id dummyTransactionTime $ - NormalTransaction $ - AccountTransaction - { atrSignature = TransactionSignature $ Map.fromList [(1, Map.fromList [(1, Signature "bla")])], - atrHeader = dummyTransactionHeader, - atrPayload = EncodedPayload "bla", - atrSignHash = TransactionSignHashV0 dummyHash - } + makeBlockItem dummyTransactionTime $ + AccountTransaction + { atrSignature = TransactionSignature $ Map.fromList [(1, Map.fromList [(1, Signature "bla")])], + atrHeader = dummyTransactionHeader, + atrPayload = EncodedPayload "bla", + atrSignHash = TransactionSignHashV0 dummyHash + } -- | A helper function for creating a block with the given round and block items. -- Blocks with different hashes can then be constructed by calling this function with different rounds. diff --git a/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/TransactionProcessingTest.hs b/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/TransactionProcessingTest.hs index 21f7abeea9..478aa71880 100644 --- a/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/TransactionProcessingTest.hs +++ b/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/TransactionProcessingTest.hs @@ -133,11 +133,11 @@ myCryptographicParameters = -- | The valid credential deployment wrapped in 'WithMetadata' and @1@ for the transaction time. credentialDeploymentWM :: WithMetadata AccountCreation -credentialDeploymentWM = addMetadata CredentialDeployment 1 validAccountCreation +credentialDeploymentWM = addMetadata 1 validAccountCreation -- | The valid credential deployment wrapped in a 'BlockItem'. dummyCredentialDeployment :: BlockItem -dummyCredentialDeployment = credentialDeployment credentialDeploymentWM +dummyCredentialDeployment = toBlockItem credentialDeploymentWM -- | A dummy credential deployment 'TransactionHash'. dummyCredentialDeploymentHash :: TransactionHash @@ -349,7 +349,7 @@ dummyAccountAddress = fst $ randomAccountAddress (mkStdGen 42) -- Note. that the signature is not correct either. dummyNormalTransaction :: Transaction dummyNormalTransaction = - addMetadata NormalTransaction 0 $ + addMetadata 0 . TransactionV0 $ makeAccountTransaction dummyTransactionSignature hdr @@ -368,7 +368,7 @@ dummyNormalTransaction = -- | A dummy update instruction. dummyUpdateInstruction :: TransactionTime -> WithMetadata UpdateInstruction dummyUpdateInstruction effTime = - addMetadata ChainUpdate 0 $ + addMetadata 0 $ makeUpdateInstruction RawUpdateInstruction { ruiSeqNumber = 1, @@ -389,11 +389,11 @@ dummyUpdateInstruction effTime = -- | The block item for 'dummyNormalTransaction'. dummyNormalTransactionBI :: BlockItem -dummyNormalTransactionBI = normalTransaction dummyNormalTransaction +dummyNormalTransactionBI = toBlockItem dummyNormalTransaction -- | The block item for 'dummyUpdateInstruction'. dummyChainUpdateBI :: TransactionTime -> BlockItem -dummyChainUpdateBI effTime = chainUpdate $ dummyUpdateInstruction effTime +dummyChainUpdateBI effTime = toBlockItem $ dummyUpdateInstruction effTime -- | Test for transaction verification testTransactionVerification :: @@ -455,7 +455,7 @@ testProcessBlockItem _ = describe "processBlockItem" $ do -- The credential deployment must be in the the transaction table at this point. assertEqual "The transaction table should yield the 'Received' credential deployment with a round 0 as commit point" - (HM.fromList [(dummyCredentialDeploymentHash, (credentialDeployment credentialDeploymentWM, Received (commitPoint $! Round 0) (TVer.Ok TVer.CredentialDeploymentSuccess)))]) + (HM.fromList [(dummyCredentialDeploymentHash, (toBlockItem credentialDeploymentWM, Received (commitPoint $! Round 0) (TVer.Ok TVer.CredentialDeploymentSuccess)))]) (sd' ^. transactionTable . ttHashMap) -- The purge counter must be incremented at this point. assertEqual @@ -515,7 +515,7 @@ testProcessBlockItem _ = describe "processBlockItem" $ do -- The credential deployment that was not deemed duplicate must be in the the transaction table at this point. assertEqual "The transaction table should yield the 'Received' credential deployment with a round 0 as commit point" - (HM.fromList [(dummyCredentialDeploymentHash, (credentialDeployment credentialDeploymentWM, Received (commitPoint $! Round 0) (TVer.Ok TVer.CredentialDeploymentSuccess)))]) + (HM.fromList [(dummyCredentialDeploymentHash, (toBlockItem credentialDeploymentWM, Received (commitPoint $! Round 0) (TVer.Ok TVer.CredentialDeploymentSuccess)))]) (sd' ^. transactionTable . ttHashMap) -- The purge counter must be incremented only once at this point. assertEqual @@ -582,7 +582,7 @@ testProcessBlockItems sProtocolVersion = describe "processBlockItems" $ do (sd' ^. transactionTablePurgeCounter) assertEqual "The transaction table should yield the 'Received' credential deployment with a round 1 as commit point" - (HM.fromList [(dummyCredentialDeploymentHash, (credentialDeployment credentialDeploymentWM, Received (commitPoint $! Round 1) (TVer.Ok TVer.CredentialDeploymentSuccess)))]) + (HM.fromList [(dummyCredentialDeploymentHash, (toBlockItem credentialDeploymentWM, Received (commitPoint $! Round 1) (TVer.Ok TVer.CredentialDeploymentSuccess)))]) (sd' ^. transactionTable . ttHashMap) where theTime :: UTCTime diff --git a/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/TreeStateTest.hs b/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/TreeStateTest.hs index a16f8b6513..2c8992d08e 100644 --- a/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/TreeStateTest.hs +++ b/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/TreeStateTest.hs @@ -515,7 +515,7 @@ dummyAccountAddress = dummyAccountAddressN 0 -- does no transaction processing i.e. verification of the transaction. dummyTransaction' :: AccountAddress -> Nonce -> Transaction dummyTransaction' accAddr n = - addMetadata NormalTransaction 0 $ + addMetadata 0 . TransactionV0 $ makeAccountTransaction dummyTransactionSignature hdr @@ -535,13 +535,13 @@ dummyTransactionFromSender :: AccountAddress -> Nonce -> Transaction dummyTransactionFromSender = dummyTransaction' dummyTransactionBIFromSender :: AccountAddress -> Nonce -> BlockItem -dummyTransactionBIFromSender accAddr = normalTransaction . (dummyTransactionFromSender accAddr) +dummyTransactionBIFromSender accAddr = toBlockItem . (dummyTransactionFromSender accAddr) dummyTransaction :: Nonce -> Transaction dummyTransaction = dummyTransaction' dummyAccountAddress dummyTransactionBI :: Nonce -> BlockItem -dummyTransactionBI = normalTransaction . dummyTransaction +dummyTransactionBI = toBlockItem . dummyTransaction dummySuccessTransactionResult :: Nonce -> TVer.VerificationResult dummySuccessTransactionResult n = @@ -571,20 +571,20 @@ dummyUpdateInstruction usn = dummyUpdateInstructionWM :: UpdateSequenceNumber -> WithMetadata UpdateInstruction dummyUpdateInstructionWM usn = - addMetadata ChainUpdate 0 $ dummyUpdateInstruction usn + addMetadata 0 $ dummyUpdateInstruction usn dummyChainUpdate :: UpdateSequenceNumber -> BlockItem -dummyChainUpdate usn = chainUpdate $ dummyUpdateInstructionWM usn +dummyChainUpdate usn = toBlockItem $ dummyUpdateInstructionWM usn -- | A valid 'AccountCreation' with expiry 1596409020 dummyAccountCreation :: AccountCreation dummyAccountCreation = readAccountCreation . BSL.fromStrict $ $(makeRelativeToProject "testdata/transactionverification/verifiable-credential.json" >>= embedFile) credentialDeploymentWM :: WithMetadata AccountCreation -credentialDeploymentWM = addMetadata CredentialDeployment 0 dummyAccountCreation +credentialDeploymentWM = addMetadata 0 dummyAccountCreation dummyCredentialDeployment :: BlockItem -dummyCredentialDeployment = credentialDeployment credentialDeploymentWM +dummyCredentialDeployment = toBlockItem credentialDeploymentWM -- | Testing 'lookupLiveTransaction' -- This test ensures that live transactions can be @@ -810,17 +810,17 @@ testRemoveTransactions :: Spec testRemoveTransactions _ = describe "finalizeTransactions" $ do it "normal transactions" $ do - sd' <- execStateT (finalizeTransactions [normalTransaction tr0]) sd + sd' <- execStateT (finalizeTransactions [toBlockItem tr0]) sd assertEqual "Account non-finalized transactions" (Just TT.AccountNonFinalizedTransactions{_anftMap = Map.singleton 2 (Map.singleton tr1 (dummySuccessTransactionResult 2))}) (sd' ^. transactionTable . TT.ttNonFinalizedTransactions . at sender) assertEqual "transaction hash map" - (HM.fromList [(getHash tr1, (normalTransaction tr1, TT.Received 0 (dummySuccessTransactionResult 2)))]) + (HM.fromList [(getHash tr1, (toBlockItem tr1, TT.Received 0 (dummySuccessTransactionResult 2)))]) (sd' ^. transactionTable . TT.ttHashMap) it "chain updates" $ do - sd' <- execStateT (finalizeTransactions [chainUpdate cu0]) sd1 + sd' <- execStateT (finalizeTransactions [toBlockItem cu0]) sd1 assertEqual "Chain update non-finalized transactions" (Just TT.NonFinalizedChainUpdates{_nfcuNextSequenceNumber = 2, _nfcuMap = Map.singleton 2 (Map.singleton cu1 (dummySuccessTransactionResult 2))}) @@ -828,20 +828,20 @@ testRemoveTransactions _ = describe "finalizeTransactions" $ do assertEqual "transaction hash map" ( HM.fromList - [ (getHash cu1, (chainUpdate cu1, TT.Received 0 (dummySuccessTransactionResult 2))), - (getHash tr1, (normalTransaction tr1, TT.Received 0 (dummySuccessTransactionResult 2))) + [ (getHash cu1, (toBlockItem cu1, TT.Received 0 (dummySuccessTransactionResult 2))), + (getHash tr1, (toBlockItem tr1, TT.Received 0 (dummySuccessTransactionResult 2))) ] ) (sd' ^. transactionTable . TT.ttHashMap) it "credential deployments" $ do - sd' <- execStateT (finalizeTransactions [credentialDeployment cred0]) sd2 + sd' <- execStateT (finalizeTransactions [toBlockItem cred0]) sd2 assertEqual "Non-finalized credential deployments" (sd' ^. transactionTable . TT.ttHashMap . at credDeploymentHash) Nothing assertEqual "transaction hash map" - (HM.fromList [(getHash tr1, (normalTransaction tr1, TT.Received 0 (dummySuccessTransactionResult 2)))]) + (HM.fromList [(getHash tr1, (toBlockItem tr1, TT.Received 0 (dummySuccessTransactionResult 2)))]) (sd' ^. transactionTable . TT.ttHashMap) where sender = accountAddressEmbed dummyAccountAddress @@ -851,8 +851,8 @@ testRemoveTransactions _ = describe "finalizeTransactions" $ do cu0 = dummyUpdateInstructionWM 1 cu1 = dummyUpdateInstructionWM 2 cred0 = credentialDeploymentWM - addTrans t = snd . TT.addTransaction (normalTransaction t) 0 (dummySuccessTransactionResult (transactionNonce t)) - addChainUpdate u = snd . TT.addTransaction (chainUpdate u) 0 (dummySuccessTransactionResult (updateSeqNumber $ uiHeader $ wmdData u)) + addTrans t = snd . TT.addTransaction (toBlockItem t) 0 (dummySuccessTransactionResult (transactionNonce t)) + addChainUpdate u = snd . TT.addTransaction (toBlockItem u) 0 (dummySuccessTransactionResult (updateSeqNumber $ uiHeader $ wmdData u)) addCredential = snd . TT.addTransaction dummyCredentialDeployment 0 dummySuccessCredentialDeployment credDeploymentHash = getHash dummyCredentialDeployment sd = @@ -885,21 +885,21 @@ testAddTransaction :: Spec testAddTransaction _ = describe "addTransaction" $ do it "add transaction" $ do - sd' <- execStateT (addTransaction tr0Round (normalTransaction tr0) (dummySuccessTransactionResult 1)) (dummyInitialSkovData @pv) + sd' <- execStateT (addTransaction tr0Round (toBlockItem tr0) (dummySuccessTransactionResult 1)) (dummyInitialSkovData @pv) assertEqual "Account non-finalized transactions" (Just TT.AccountNonFinalizedTransactions{_anftMap = Map.singleton 1 (Map.singleton tr0 (dummySuccessTransactionResult 1))}) (sd' ^. transactionTable . TT.ttNonFinalizedTransactions . at sender) assertEqual "transaction hash map" - (HM.fromList [(getHash tr0, (normalTransaction tr0, TT.Received (TT.commitPoint tr0Round) (dummySuccessTransactionResult 1)))]) + (HM.fromList [(getHash tr0, (toBlockItem tr0, TT.Received (TT.commitPoint tr0Round) (dummySuccessTransactionResult 1)))]) (sd' ^. transactionTable . TT.ttHashMap) assertEqual "transaction table purge counter is incremented" (1 + (dummyInitialSkovData @pv) ^. transactionTablePurgeCounter) (sd' ^. transactionTablePurgeCounter) - sd'' <- execStateT (finalizeTransactions [normalTransaction tr0]) sd' - added <- evalStateT (addTransaction tr0Round (normalTransaction tr1) (dummySuccessTransactionResult 1)) sd'' + sd'' <- execStateT (finalizeTransactions [toBlockItem tr0]) sd' + added <- evalStateT (addTransaction tr0Round (toBlockItem tr1) (dummySuccessTransactionResult 1)) sd'' assertEqual "tx should be added" True added where tr0Round = 1 @@ -917,14 +917,14 @@ testCommitTransaction :: Spec testCommitTransaction _ = describe "commitTransaction" $ do it "commit transaction" $ do - sd' <- execStateT (commitTransaction 1 bh 0 (normalTransaction tr0)) sd + sd' <- execStateT (commitTransaction 1 bh 0 (toBlockItem tr0)) sd assertEqual "transaction hash map" - (HM.fromList [(getHash tr0, (normalTransaction tr0, TT.Committed 1 (dummySuccessTransactionResult (transactionNonce tr0)) $ HM.fromList [(bh, TransactionIndex 0)]))]) + (HM.fromList [(getHash tr0, (toBlockItem tr0, TT.Committed 1 (dummySuccessTransactionResult (transactionNonce tr0)) $ HM.fromList [(bh, TransactionIndex 0)]))]) (sd' ^. transactionTable . TT.ttHashMap) where tr0 = dummyTransaction 1 - addTrans t = snd . TT.addTransaction (normalTransaction t) 0 (dummySuccessTransactionResult (transactionNonce t)) + addTrans t = snd . TT.addTransaction (toBlockItem t) 0 (dummySuccessTransactionResult (transactionNonce t)) sd = dummyInitialSkovData @pv & transactionTable @@ -945,21 +945,21 @@ testMarkTransactionDead :: Spec testMarkTransactionDead _ = describe "markTransactionDead" $ do it "mark committed transaction dead" $ do - sd' <- execStateT (commitTransaction 1 bh 0 (normalTransaction tr0)) sd - sd'' <- execStateT (markTransactionDead bh (normalTransaction tr0)) sd' + sd' <- execStateT (commitTransaction 1 bh 0 (toBlockItem tr0)) sd + sd'' <- execStateT (markTransactionDead bh (toBlockItem tr0)) sd' assertEqual "transaction hash map" - (HM.fromList [(getHash tr0, (normalTransaction tr0, TT.Received 1 (dummySuccessTransactionResult (transactionNonce tr0))))]) + (HM.fromList [(getHash tr0, (toBlockItem tr0, TT.Received 1 (dummySuccessTransactionResult (transactionNonce tr0))))]) (sd'' ^. transactionTable . TT.ttHashMap) it "mark received transaction dead" $ do - sd' <- execStateT (markTransactionDead bh (normalTransaction tr0)) sd + sd' <- execStateT (markTransactionDead bh (toBlockItem tr0)) sd assertEqual "transaction hash map" - (HM.fromList [(getHash tr0, (normalTransaction tr0, TT.Received 0 (dummySuccessTransactionResult (transactionNonce tr0))))]) + (HM.fromList [(getHash tr0, (toBlockItem tr0, TT.Received 0 (dummySuccessTransactionResult (transactionNonce tr0))))]) (sd' ^. transactionTable . TT.ttHashMap) where tr0 = dummyTransaction 1 - addTrans t = snd . TT.addTransaction (normalTransaction t) 0 (dummySuccessTransactionResult (transactionNonce t)) + addTrans t = snd . TT.addTransaction (toBlockItem t) 0 (dummySuccessTransactionResult (transactionNonce t)) sd = dummyInitialSkovData @pv & transactionTable @@ -979,7 +979,7 @@ testPurgeTransactionTable :: testPurgeTransactionTable _ = describe "purgeTransactionTable" $ do it "force purge the transaction table" $ do -- increment the purge counter. - sd' <- execStateT (addTransaction 0 (normalTransaction tr0) (dummySuccessTransactionResult 1)) sd + sd' <- execStateT (addTransaction 0 (toBlockItem tr0) (dummySuccessTransactionResult 1)) sd sd'' <- execStateT (purgeTransactionTable True theTime) sd' assertEqual "purge counter should be reset" @@ -998,7 +998,7 @@ testPurgeTransactionTable _ = describe "purgeTransactionTable" $ do Nothing (sd'' ^. transactionTable . TT.ttHashMap . at credDeploymentHash) where - addChainUpdate u = snd . TT.addTransaction (chainUpdate u) 0 (dummySuccessTransactionResult (updateSeqNumber $ uiHeader $ wmdData u)) + addChainUpdate u = snd . TT.addTransaction (toBlockItem u) 0 (dummySuccessTransactionResult (updateSeqNumber $ uiHeader $ wmdData u)) addCredential = snd . TT.addTransaction dummyCredentialDeployment 0 dummySuccessCredentialDeployment tr0 = dummyTransaction 1 cu0 = dummyUpdateInstructionWM 1 @@ -1028,7 +1028,7 @@ testClearOnProtocolUpdate :: Spec testClearOnProtocolUpdate _ = describe "clearOnProtocolUpdate" $ it "clears on protocol update" $ do - sd' <- execStateT (commitTransaction 1 bh 0 (normalTransaction tr0)) sd + sd' <- execStateT (commitTransaction 1 bh 0 (toBlockItem tr0)) sd sd'' <- execStateT clearOnProtocolUpdate sd' assertEqual "block table should be empty" @@ -1040,12 +1040,12 @@ testClearOnProtocolUpdate _ = describe "clearOnProtocolUpdate" $ (sd'' ^. branches) assertEqual "committed transactions should be received with commit point 0" - (HM.fromList [(getHash tr0, (normalTransaction tr0, TT.Received 0 (dummySuccessTransactionResult 1)))]) + (HM.fromList [(getHash tr0, (toBlockItem tr0, TT.Received 0 (dummySuccessTransactionResult 1)))]) (sd'' ^. transactionTable . TT.ttHashMap) where tr0 = dummyTransaction 1 bh = BlockHash minBound - addTrans t = snd . TT.addTransaction (normalTransaction t) 0 (dummySuccessTransactionResult (transactionNonce t)) + addTrans t = snd . TT.addTransaction (toBlockItem t) 0 (dummySuccessTransactionResult (transactionNonce t)) sd = skovDataWithTestBlocks @pv & transactionTable diff --git a/concordium-consensus/tests/consensus/ConcordiumTests/ReceiveTransactionsTest.hs b/concordium-consensus/tests/consensus/ConcordiumTests/ReceiveTransactionsTest.hs index 503ac8f55f..f469ddbc44 100644 --- a/concordium-consensus/tests/consensus/ConcordiumTests/ReceiveTransactionsTest.hs +++ b/concordium-consensus/tests/consensus/ConcordiumTests/ReceiveTransactionsTest.hs @@ -116,7 +116,7 @@ test = do now = posixSecondsToUTCTime $ credentialDeploymentExpiryTime - 1 txArrivalTime = utcTimeToTransactionTime now genesis = testGenesisData now myips myars myCryptoParams - txs = [toBlockItem txArrivalTime mycdi, toBlockItem txArrivalTime myicdi] + txs = [makeBlockItem txArrivalTime mycdi, makeBlockItem txArrivalTime myicdi] s <- runTransactions testDoReceiveTransaction txs now genesis let results = fst s resultingState = snd s @@ -164,7 +164,7 @@ test = do let credentialDeploymentExpiryTime = 1596409020 now = posixSecondsToUTCTime $ credentialDeploymentExpiryTime - 1 txArrivalTime = utcTimeToTransactionTime now - txs = [toBlockItem txArrivalTime mycdi, toBlockItem txArrivalTime myicdi] + txs = [makeBlockItem txArrivalTime mycdi, makeBlockItem txArrivalTime myicdi] genesis = testGenesisData now myips myars myCryptoParams s <- runTransactions testDoReceiveTransactionInternal txs now genesis let results = fst s @@ -176,8 +176,8 @@ test = do let now = utcTimeToTransactionTime theTime genesis = testGenesisData theTime dummyIdentityProviders dummyArs dummyCryptographicParameters txs = - [ toBlockItem now $ mkAccountTransaction (now + 1) True 2 True TheCost, - toBlockItem now $ mkAccountTransaction (now + 1) True 1 True TheCost + [ makeBlockItem now $ mkAccountTransaction (now + 1) True 2 True TheCost, + makeBlockItem now $ mkAccountTransaction (now + 1) True 1 True TheCost ] s <- runTransactions testDoReceiveTransactionInternal txs theTime genesis let results = fst s @@ -316,13 +316,13 @@ accountCreations gCtx now = ] where expiry = now + 1 - expiredTransaction = toBlockItem now (mkAccountCreation (now - 1) (regId 1) 0 True True False) - expiredCredentialDeployment = toBlockItem now (mkAccountCreation expiry (regId 1) 0 True True True) - credentialDeploymentWithDuplicateRegId = toBlockItem now (mkAccountCreation expiry duplicateRegId 0 True True False) - credentialWithInvalidIP = toBlockItem now (mkAccountCreation expiry (regId 1) 42 True True False) - credentialWithInvalidAr = toBlockItem now (mkAccountCreation expiry (regId 1) 0 False True False) - credentialWithInvalidSignatures = toBlockItem now (mkAccountCreation expiry (regId 1) 0 True True False) - intialCredentialWithInvalidSignatures = toBlockItem now (mkInitialAccountCreationWithInvalidSignatures expiry (regId 42)) + expiredTransaction = makeBlockItem now (mkAccountCreation (now - 1) (regId 1) 0 True True False) + expiredCredentialDeployment = makeBlockItem now (mkAccountCreation expiry (regId 1) 0 True True True) + credentialDeploymentWithDuplicateRegId = makeBlockItem now (mkAccountCreation expiry duplicateRegId 0 True True False) + credentialWithInvalidIP = makeBlockItem now (mkAccountCreation expiry (regId 1) 42 True True False) + credentialWithInvalidAr = makeBlockItem now (mkAccountCreation expiry (regId 1) 0 False True False) + credentialWithInvalidSignatures = makeBlockItem now (mkAccountCreation expiry (regId 1) 0 True True False) + intialCredentialWithInvalidSignatures = makeBlockItem now (mkInitialAccountCreationWithInvalidSignatures expiry (regId 42)) regId seed = RegIdCred $ generateGroupElementFromSeed gCtx seed chainUpdates :: TransactionTime -> [BlockItem] @@ -335,12 +335,12 @@ chainUpdates now = verifiable ] where - expiredTimeout = toBlockItem now (mkChainUpdate (now - 1) (now - 1) getValidSequenceNumber True) - invalidEffectiveTime = toBlockItem now (mkChainUpdate (now + 1) (now + 2) getValidSequenceNumber True) - sequenceNumberTooOld = toBlockItem now (mkChainUpdate (now + 2) (now + 1) getTooOldSequenceNumber True) - sequenceNumberTooLarge = toBlockItem now (mkChainUpdate (now + 2) (now + 1) getTooLargeSequenceNumber True) - invalidSignature = toBlockItem now (mkChainUpdate (now + 2) (now + 1) getValidSequenceNumber False) - verifiable = toBlockItem now (mkChainUpdate (now + 2) (now + 1) getValidSequenceNumber True) + expiredTimeout = makeBlockItem now (mkChainUpdate (now - 1) (now - 1) getValidSequenceNumber True) + invalidEffectiveTime = makeBlockItem now (mkChainUpdate (now + 1) (now + 2) getValidSequenceNumber True) + sequenceNumberTooOld = makeBlockItem now (mkChainUpdate (now + 2) (now + 1) getTooOldSequenceNumber True) + sequenceNumberTooLarge = makeBlockItem now (mkChainUpdate (now + 2) (now + 1) getTooLargeSequenceNumber True) + invalidSignature = makeBlockItem now (mkChainUpdate (now + 2) (now + 1) getValidSequenceNumber False) + verifiable = makeBlockItem now (mkChainUpdate (now + 2) (now + 1) getValidSequenceNumber True) getValidSequenceNumber = minUpdateSequenceNumber + 1 getTooOldSequenceNumber = minUpdateSequenceNumber getTooLargeSequenceNumber = minUpdateSequenceNumber + 2 @@ -362,35 +362,26 @@ normals now isSingle successNonce = atMaxBlockEnergy ] where - expired = toBlockItem now $ mkAccountTransaction (now - 1) True 1 True TheCost - depositInsufficient = toBlockItem now $ mkAccountTransaction (now + 1) True 1 True TooLittle - invalidSender = toBlockItem now $ mkAccountTransaction (now + 1) True 1 False TheCost + expired = makeBlockItem now $ mkAccountTransaction (now - 1) True 1 True TheCost + depositInsufficient = makeBlockItem now $ mkAccountTransaction (now + 1) True 1 True TooLittle + invalidSender = makeBlockItem now $ mkAccountTransaction (now + 1) True 1 False TheCost -- 'invalidNonce' should be accepted for transactions received individually, but rejected if it was part of a block. - nonceTooLarge = toBlockItem now $ mkAccountTransaction (now + 1) True 3 True TheCost + nonceTooLarge = makeBlockItem now $ mkAccountTransaction (now + 1) True 3 True TheCost -- since the one above was accepted because it was part of a block we must increment the nonce here, -- if the transaction is part of a block invalidSignature = if isSingle - then toBlockItem now $ mkAccountTransaction (now + 1) False 1 True TheCost - else toBlockItem now $ mkAccountTransaction (now + 1) False 3 True TheCost + then makeBlockItem now $ mkAccountTransaction (now + 1) False 1 True TheCost + else makeBlockItem now $ mkAccountTransaction (now + 1) False 3 True TheCost -- This ones also needs a nonce depending of the `TransactionOrigin` - verifiable nonce = toBlockItem now $ mkAccountTransaction (now + 1) True nonce True TheCost + verifiable nonce = makeBlockItem now $ mkAccountTransaction (now + 1) True nonce True TheCost -- Also this one. tooMuchEnergy = if isSingle - then toBlockItem now $ mkAccountTransaction (now + 1) True 2 True TooMuch - else toBlockItem now $ mkAccountTransaction (now + 1) True 5 True TooMuch + then makeBlockItem now $ mkAccountTransaction (now + 1) True 2 True TooMuch + else makeBlockItem now $ mkAccountTransaction (now + 1) True 5 True TooMuch -- transactions which state exactly the max block energy bound should be accepted - atMaxBlockEnergy = toBlockItem now $ mkAccountTransaction (now + 1) True (if isSingle then 3 else 6) True MaxBlockEnergy - -toBlockItem :: TransactionTime -> BareBlockItem -> BlockItem -toBlockItem now bbi = - case bbi of - CredentialDeployment cred -> credentialDeployment $ addMetadata (\x -> CredentialDeployment{biCred = x}) now cred - ChainUpdate ui -> chainUpdate $ addMetadata (\x -> ChainUpdate{biUpdate = x}) now ui - NormalTransaction tx -> normalTransaction $ addMetadata (\x -> NormalTransaction{biTransaction = x}) now tx - ExtendedTransaction _tx -> - error "TODO(SP0-10): transaction verifier support for sponsored transactions" + atMaxBlockEnergy = makeBlockItem now $ mkAccountTransaction (now + 1) True (if isSingle then 3 else 6) True MaxBlockEnergy duplicateRegId :: CredentialRegistrationID duplicateRegId = credId (makeTestCredentialFromSeed 1) diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/AccountTransactionSpecs.hs b/concordium-consensus/tests/scheduler/SchedulerTests/AccountTransactionSpecs.hs index 099769cb98..20108382f7 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/AccountTransactionSpecs.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/AccountTransactionSpecs.hs @@ -45,7 +45,7 @@ cdi7' = transactionsInput :: [CredentialDeploymentWithStatus] transactionsInput = - map ((\x -> (x, Nothing)) . Types.addMetadata Types.CredentialDeployment 0) $ + map ((\x -> (x, Nothing)) . Types.addMetadata 0) $ [ cdi1, cdi2, cdi3, diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/BlockEnergyLimitSpec.hs b/concordium-consensus/tests/scheduler/SchedulerTests/BlockEnergyLimitSpec.hs index 4a54c58747..f5867ae650 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/BlockEnergyLimitSpec.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/BlockEnergyLimitSpec.hs @@ -83,7 +83,7 @@ testMaxBlockEnergy _ pvString = specify (pvString ++ ": One valid, two invalid, -- block energy limit let ts = Types.TGCredentialDeployment - (Types.addMetadata Types.CredentialDeployment 0 cdi1, Nothing) + (Types.addMetadata 0 cdi1, Nothing) : ts' -- dummy arrival time of 0 (Helpers.SchedulerResult{..}, doBlockStateAssertions) <- Helpers.runSchedulerTest @@ -107,7 +107,7 @@ testMaxBlockEnergy _ pvString = specify (pvString ++ ": One valid, two invalid, ] -> do assertEqual "The first transaction should be valid:" - (Types.normalTransaction $ fst t1) + (Types.toBlockItem $ fst t1) $ fst t assertEqual "Correct energy cost: " Helpers.simpleTransferCost energyCost _ -> assertFailure "There should be one valid transaction with a TxSuccess result." @@ -120,7 +120,7 @@ testMaxBlockEnergy _ pvString = specify (pvString ++ ": One valid, two invalid, invalidTs assertEqual "The credential deployment is invalid." - [Types.addMetadata Types.CredentialDeployment 0 cdi1] + [Types.addMetadata 0 cdi1] $ map fst invalidCreds assertEqual "There is one normal transaction whose energy exceeds the block energy limit, and one with non-sequential nonce:" diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/InitialAccountCreationSpec.hs b/concordium-consensus/tests/scheduler/SchedulerTests/InitialAccountCreationSpec.hs index 746e3db7c5..3565904c35 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/InitialAccountCreationSpec.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/InitialAccountCreationSpec.hs @@ -29,7 +29,7 @@ initialBlockState = Helpers.createTestBlockStateWithAccountsM [] transactionsInput :: [CredentialDeploymentWithStatus] transactionsInput = map - ((\x -> (x, Nothing)) . Types.addMetadata Types.CredentialDeployment 0) + ((\x -> (x, Nothing)) . Types.addMetadata 0) [ icdi1, icdi2, icdi3 -- should fail because reuse of prf key diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/TransactionGroupingSpec2.hs b/concordium-consensus/tests/scheduler/SchedulerTests/TransactionGroupingSpec2.hs index 6d0533170a..65003a4073 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/TransactionGroupingSpec2.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/TransactionGroupingSpec2.hs @@ -343,7 +343,7 @@ tests = mkExpected [] ev ei eu = (reverse ev, reverse ei, reverse eu) mkExpected ((t, expectedRes) : rest) ev ei eu = case expectedRes of - Added -> mkExpected rest ((Types.normalTransaction t) : ev) ei eu + Added -> mkExpected rest ((Types.toBlockItem t) : ev) ei eu Failed fk -> mkExpected rest ev ((t, fk) : ei) eu Unprocessed -> mkExpected rest ev ei (t : eu) @@ -366,7 +366,7 @@ tests = case expectedRes of -- NOTE: With a custom expectation could print list of -- invalid/unproc in case of failure. - Added -> (Types.normalTransaction t) `elem` map fst validTs + Added -> (Types.toBlockItem t) `elem` map fst validTs Failed fk -> (t, fk) `elem` map (\(x, y) -> (fst x, y)) invalid Unprocessed -> t `elem` map fst unproc ) diff --git a/concordium-node/src/grpc2.rs b/concordium-node/src/grpc2.rs index 1e22e61322..f89c3e039d 100644 --- a/concordium-node/src/grpc2.rs +++ b/concordium-node/src/grpc2.rs @@ -22,7 +22,7 @@ pub mod types { use crate::configuration::PROTOCOL_MAX_TRANSACTION_SIZE; use super::Require; - use concordium_base::{common::Versioned, transactions::PayloadLike}; + use concordium_base::{common::{Version, Versioned}, transactions::PayloadLike}; use std::convert::{TryFrom, TryInto}; /// Types generated from the protocol-level-tokens.proto file. @@ -640,7 +640,7 @@ pub mod types { ))) } send_block_item_request::BlockItem::RawBlockItem(bytes) => { - let mut data = concordium_base::common::to_bytes(&Versioned::new(0.into(), ())); + let mut data = concordium_base::common::to_bytes(&Version::from(0)); // Add raw bytes in a separate step to avoid encoding the length data.extend_from_slice(&bytes); Ok(data) @@ -2872,6 +2872,7 @@ pub mod server { request: tonic::Request, ) -> Result, tonic::Status> { use ConsensusFfiResponse::*; + debug!("Received block item {:?}", request); if !self.service_config.send_block_item { return Err(tonic::Status::unimplemented( "`SendBlockItem` is not enabled.", @@ -2962,6 +2963,7 @@ pub mod server { mk_err_invalid_argument_response(ConsensusShutDown.to_string()) } (_, consensus_error) => { + warn!("Consensus rejected a transaction due to {}", consensus_error.to_string()); mk_err_invalid_argument_response(consensus_error.to_string()) } } From a856de10f1bf9c46e09908bbbe4151f3c9603b04 Mon Sep 17 00:00:00 2001 From: Thomas Dinsdale-Young Date: Wed, 26 Nov 2025 11:27:55 +0100 Subject: [PATCH 14/26] Fix cost computation --- concordium-base | 2 +- .../src/Concordium/Scheduler/Environment.hs | 15 ++++++++++++--- 2 files changed, 13 insertions(+), 4 deletions(-) diff --git a/concordium-base b/concordium-base index 00795e8890..c031d22388 160000 --- a/concordium-base +++ b/concordium-base @@ -1 +1 @@ -Subproject commit 00795e88900de30de0d1a30320b9524e303ffff8 +Subproject commit c031d22388e5ed219e5112b26df6e3df2602abf1 diff --git a/concordium-consensus/src/Concordium/Scheduler/Environment.hs b/concordium-consensus/src/Concordium/Scheduler/Environment.hs index 46cdf2ab76..293cca7288 100644 --- a/concordium-consensus/src/Concordium/Scheduler/Environment.hs +++ b/concordium-consensus/src/Concordium/Scheduler/Environment.hs @@ -1070,9 +1070,6 @@ withDeposit wtc comp k = do (setTransactionReturnValue . V1.returnValueToByteString) result (ls ^. transactionReturnValue) - let (tsCost, sponsorDetails) - | Just sponsorAddress <- wtc ^. wtcSponsorAddress = (0, Just $ SponsorDetails{sdSponsor = sponsorAddress, sdCost = tsCost}) - | otherwise = (tsCost, Nothing) case res of -- Failure: maximum block energy exceeded Left Nothing -> return Nothing @@ -1081,6 +1078,7 @@ withDeposit wtc comp k = do -- The only effect of this transaction is that the payer is charged for the execution cost -- (energy ticked so far). executionCharge <- computeChargeExecution wtc (ls ^. energyLeft) + let (tsCost, sponsorDetails) = computeCostDetails executionCharge return $! Just $! @@ -1097,6 +1095,7 @@ withDeposit wtc comp k = do Right a -> do -- In this case we charge for the used energy then invoke the continuation. executionCharge <- computeChargeExecution wtc (ls ^. energyLeft) + let (tsCost, sponsorDetails) = computeCostDetails executionCharge tsResult0 <- k ls a return $! Just $! @@ -1111,6 +1110,16 @@ withDeposit wtc comp k = do } where cHasSponsorDetails = sHasSponsorDetails (sTransactionOutcomesVersionFor (protocolVersion @(MPV m))) + computeCostDetails ExecutionCharge{..} + | Just sponsorAddress <- wtc ^. wtcSponsorAddress = + ( 0, + Just $ + SponsorDetails + { sdSponsor = sponsorAddress, + sdCost = ecEnergyCost + } + ) + | otherwise = (ecEnergyCost, Nothing) -- | Default continuation to use with 'withDeposit'. It commits the changes -- from the current changeset and returns the recorded events, the amount corresponding to the From 13c3eb74abea96a3b097a021b3b05f41a0500fda Mon Sep 17 00:00:00 2001 From: Thomas Dinsdale-Young Date: Wed, 26 Nov 2025 11:33:45 +0100 Subject: [PATCH 15/26] Scheduler tests include P10 --- concordium-consensus/tests/scheduler/SchedulerTests/Helpers.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/Helpers.hs b/concordium-consensus/tests/scheduler/SchedulerTests/Helpers.hs index 75785d5e28..9650c9b136 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/Helpers.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/Helpers.hs @@ -142,7 +142,8 @@ forEveryProtocolVersion check = check Types.SP6 "P6", check Types.SP7 "P7", check Types.SP8 "P8", - check Types.SP9 "P9" + check Types.SP9 "P9", + check Types.SP10 "P10" ] -- | Convert an energy value to an amount, based on the exchange rates used in From 48fb610c3acfc5ad718867bf736365c48f374657 Mon Sep 17 00:00:00 2001 From: Thomas Dinsdale-Young Date: Wed, 26 Nov 2025 15:35:38 +0100 Subject: [PATCH 16/26] Clean up --- concordium-base | 2 +- .../src/Concordium/Scheduler.hs | 10 ++++---- .../src/Concordium/Scheduler/Environment.hs | 24 ++++++++++++------- concordium-node/src/grpc2.rs | 2 -- 4 files changed, 22 insertions(+), 16 deletions(-) diff --git a/concordium-base b/concordium-base index c031d22388..9c530b619e 160000 --- a/concordium-base +++ b/concordium-base @@ -1 +1 @@ -Subproject commit c031d22388e5ed219e5112b26df6e3df2602abf1 +Subproject commit 9c530b619e9c6451d099a35c9285dfd7d67718fc diff --git a/concordium-consensus/src/Concordium/Scheduler.hs b/concordium-consensus/src/Concordium/Scheduler.hs index 57051a42cf..470b615e7a 100644 --- a/concordium-consensus/src/Concordium/Scheduler.hs +++ b/concordium-consensus/src/Concordium/Scheduler.hs @@ -176,9 +176,9 @@ checkHeader meta mVerRes = do -- We check if we previously have deemed the transaction valid and check if the -- current account information matches with one at the point of verification. -- Also we check that the nonce is valid and that the sender has enough funds to cover his transfer. - let senderAcc = snd senderAccount - let bodyHash = transactionSignHashToByteString (transactionSignHash meta) + -- Raise an error if the account keys have changed since the previous verification and + -- the signature cannot be verified with the updated keys. validateAccountKeys account expectedKeys signature = do actualKeys <- lift (TVer.getAccountVerificationKeys (snd account)) unless (ID.matchesAccountInformation actualKeys expectedKeys) $ do @@ -187,9 +187,10 @@ checkHeader meta mVerRes = do -- since it could be a subset of keys that have not changed. unless (verifyAccountSignature bodyHash (tsSignatures signature) actualKeys) $ throwError (Just IncorrectSignature) + -- Raise an error if the sender's nonce is incorrect or the payer has insufficient funds. checkNonceAndFunds = do -- Check that the sender's nonce is OK. - nextNonce <- lift (TVer.getNextAccountNonce senderAcc) + nextNonce <- lift (TVer.getNextAccountNonce (snd senderAccount)) let nonce = transactionNonce meta unless (nonce == nextNonce) $ throwError (Just $ NonSequentialNonce nonce) -- Check that the payer account still has enough funds to cover the deposit @@ -321,7 +322,7 @@ dispatchTransactionBody msg CheckHeaderResult{..} = do -- the header and reject the transaction; we have checked that the amount -- exists on the account with 'checkHeader'. payment <- energyToGtu chrCheckHeaderCost - chargeExecutionCostAccount chrPayerAccount payment + chargeExecutionCost chrPayerAccount payment return $ Just $ TransactionSummary @@ -336,7 +337,6 @@ dispatchTransactionBody msg CheckHeaderResult{..} = do } Right payload -> do usedBlockEnergy <- getUsedEnergy - logEvent Scheduler LLInfo $ "Executing transaction with sender " ++ show (thSender meta) ++ " and sponsor " ++ show (transactionSponsor msg) ++ ". Payer index: " ++ show (fst chrPayerAccount) let mkWTC _wtcTransactionType = WithDepositContext { _wtcSenderAccount = chrSenderAccount, diff --git a/concordium-consensus/src/Concordium/Scheduler/Environment.hs b/concordium-consensus/src/Concordium/Scheduler/Environment.hs index 293cca7288..af518df4af 100644 --- a/concordium-consensus/src/Concordium/Scheduler/Environment.hs +++ b/concordium-consensus/src/Concordium/Scheduler/Environment.hs @@ -981,19 +981,27 @@ computeExecutionCharge allocated unused = do -- method is that the account exists and its balance is sufficient to -- cover the costs. These are not checked. -- --- NB: This method should only be used directly when the given account's balance --- is the only one affected by the transaction, either because a transaction was --- rejected, or because it was a transaction which only affects one account's --- balance such as DeployCredential, or DeployModule. -chargeExecutionCostAccount :: forall m. (SchedulerMonad m) => IndexedAccount m -> Amount -> m () -chargeExecutionCostAccount (ai, acc) amnt = do - logEvent Scheduler LLInfo $ "Charging execution cost of " ++ show amnt ++ " to " ++ show ai +-- NB: This function is only called in two ways: +-- +-- - by 'computeChargeExecution' to charge for executing a payload that was deserialized. +-- - by 'dispatchTransactionBody' to charge for a payload that could not be deserialized. +chargeExecutionCost :: + forall m. + (SchedulerMonad m) => + -- | Payer account.` + IndexedAccount m -> + -- | Execution cost. + Amount -> + m () +chargeExecutionCost (ai, acc) amnt = do balance <- getAccountAmount acc let csWithAccountDelta = emptyCS (Proxy @m) & accountUpdates . at ai ?~ (emptyAccountUpdate ai & auAmount ?~ amountDiff 0 amnt) assert (balance >= amnt) $ commitChanges csWithAccountDelta notifyExecutionCost amnt +-- | Compute the amount to charge the transaction payer for executing the transaction, +-- and charge the account. Returns the energy and cost charged. computeChargeExecution :: (SchedulerMonad m) => -- | The context for the transaction execution. @@ -1003,7 +1011,7 @@ computeChargeExecution :: m ExecutionCharge computeChargeExecution wtc unused = do executionCharge <- computeExecutionCharge (_wtcEnergyAmount wtc) unused - chargeExecutionCostAccount (_wtcPayerAccount wtc) (ecEnergyCost executionCharge) + chargeExecutionCost (_wtcPayerAccount wtc) (ecEnergyCost executionCharge) return executionCharge data WithDepositContext m = WithDepositContext diff --git a/concordium-node/src/grpc2.rs b/concordium-node/src/grpc2.rs index f89c3e039d..1058862f92 100644 --- a/concordium-node/src/grpc2.rs +++ b/concordium-node/src/grpc2.rs @@ -2872,7 +2872,6 @@ pub mod server { request: tonic::Request, ) -> Result, tonic::Status> { use ConsensusFfiResponse::*; - debug!("Received block item {:?}", request); if !self.service_config.send_block_item { return Err(tonic::Status::unimplemented( "`SendBlockItem` is not enabled.", @@ -2963,7 +2962,6 @@ pub mod server { mk_err_invalid_argument_response(ConsensusShutDown.to_string()) } (_, consensus_error) => { - warn!("Consensus rejected a transaction due to {}", consensus_error.to_string()); mk_err_invalid_argument_response(consensus_error.to_string()) } } From a46728843fd414f4265708980471526d32e961a5 Mon Sep 17 00:00:00 2001 From: Thomas Dinsdale-Young Date: Wed, 26 Nov 2025 15:40:06 +0100 Subject: [PATCH 17/26] Formatting. --- concordium-node/src/grpc2.rs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/concordium-node/src/grpc2.rs b/concordium-node/src/grpc2.rs index 1058862f92..eb3c98f78d 100644 --- a/concordium-node/src/grpc2.rs +++ b/concordium-node/src/grpc2.rs @@ -22,7 +22,10 @@ pub mod types { use crate::configuration::PROTOCOL_MAX_TRANSACTION_SIZE; use super::Require; - use concordium_base::{common::{Version, Versioned}, transactions::PayloadLike}; + use concordium_base::{ + common::{Version, Versioned}, + transactions::PayloadLike, + }; use std::convert::{TryFrom, TryInto}; /// Types generated from the protocol-level-tokens.proto file. From 5da2f791d0bcfa6b54ad3ac28ae7ff002ac2a885 Mon Sep 17 00:00:00 2001 From: Thomas Dinsdale-Young Date: Thu, 27 Nov 2025 17:20:19 +0100 Subject: [PATCH 18/26] Some testing for grpc conversions. --- concordium-node/src/grpc2.rs | 243 +++++++++++++++++++++++++++++++++++ 1 file changed, 243 insertions(+) diff --git a/concordium-node/src/grpc2.rs b/concordium-node/src/grpc2.rs index eb3c98f78d..e576b12a6c 100644 --- a/concordium-node/src/grpc2.rs +++ b/concordium-node/src/grpc2.rs @@ -651,6 +651,249 @@ pub mod types { } } } + + #[cfg(test)] + mod tests { + use super::*; + use std::collections::HashMap; + #[test] + fn test_send_block_item_request_get_v0_format_account_transaction() { + // Prepare minimal valid AccountTransaction fields. + let sender = Some(AccountAddress { + value: vec![37u8; 32], + }); + let sequence_number = Some(SequenceNumber { value: 1 }); + let energy_amount = Some(Energy { value: 1000 }); + let expiry = Some(TransactionTime { value: 123456 }); + let header = Some(AccountTransactionHeader { + sender, + sequence_number, + energy_amount, + expiry, + }); + + // Use a simple transfer payload. + let receiver = Some(AccountAddress { + value: vec![1u8; 32], + }); + let amount = Some(Amount { value: 42 }); + let payload = Some(AccountTransactionPayload { + payload: Some(account_transaction_payload::Payload::Transfer( + TransferPayload { receiver, amount }, + )), + }); + + let signature = Some(AccountTransactionSignature { + signatures: HashMap::from([( + 0, + AccountSignatureMap { + signatures: HashMap::from([( + 0, + Signature { + value: vec![2u8; 64], + }, + )]), + }, + )]), + }); + + let at = AccountTransaction { + header, + payload, + signature, + }; + + let req = SendBlockItemRequest { + block_item: Some(send_block_item_request::BlockItem::AccountTransaction(at)), + }; + + // Call get_v0_format and check the result. + let result = req.get_v0_format(); + assert!(result.is_ok()); + let data = result.unwrap(); + + assert_eq!( + data, + [ + 0, // Version (0) + 0, // Tag for AccountTransaction (0) + 1, // One account signature + 0, // Credential index 0 + 1, // One credential signature + 0, // Key index 0 + 0, 64, // Signature length (64) + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, // Signature (64 bytes, all 2) + 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, + 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, + 37, // Sender (32 bytes, all 37) + 0, 0, 0, 0, 0, 0, 0, 1, // Sequence number (1) + 0, 0, 0, 0, 0, 0, 3, 232, // Energy amount (1000) + 0, 0, 0, 41, // Payload size (41 bytes) + 0, 0, 0, 0, 0, 1, 226, 64, // Expiry (123456) + 3, // Transfer payload + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, // Receiver (32 bytes, all 1) + 0, 0, 0, 0, 0, 0, 0, 42 // Amount (42) + ] + ); + } + #[test] + fn test_send_block_item_request_get_v0_format_account_transaction_v1() { + // Prepare minimal valid AccountTransactionV1 fields. + let sender = Some(AccountAddress { + value: vec![42u8; 32], + }); + let sequence_number = Some(SequenceNumber { value: 2 }); + let energy_amount = Some(Energy { value: 2000 }); + let expiry = Some(TransactionTime { value: 654321 }); + let sponsor = Some(AccountAddress { + value: vec![99u8; 32], + }); + let header = Some(AccountTransactionHeaderV1 { + sender, + sequence_number, + energy_amount, + expiry, + sponsor, + }); + + // Use a simple transfer with memo payload. + let receiver = Some(AccountAddress { + value: vec![12u8; 32], + }); + let amount = Some(Amount { value: 123 }); + let memo = Some(Memo { + value: vec![7u8; 32], + }); + let payload = Some(AccountTransactionPayload { + payload: Some(account_transaction_payload::Payload::TransferWithMemo( + TransferWithMemoPayload { + receiver, + amount, + memo, + }, + )), + }); + + let signature = Some(AccountTransactionSignature { + signatures: HashMap::from([( + 1, + AccountSignatureMap { + signatures: HashMap::from([( + 2, + Signature { + value: vec![5u8; 64], + }, + )]), + }, + )]), + }); + + let sponsor_signatures = Some(AccountTransactionSignature { + signatures: HashMap::from([( + 0, + AccountSignatureMap { + signatures: HashMap::from([( + 0, + Signature { + value: vec![8u8; 64], + }, + )]), + }, + )]), + }); + + let signatures = Some(AccountTransactionV1Signatures { + sender_signatures: signature, + sponsor_signatures, + }); + + let atv1 = AccountTransactionV1 { + header, + payload, + signatures, + }; + + let req = SendBlockItemRequest { + block_item: Some(send_block_item_request::BlockItem::AccountTransactionV1( + atv1, + )), + }; + + // Call get_v0_format and check the result. + let result = req.get_v0_format(); + assert!(result.is_ok()); + let data = result.unwrap(); + + assert_eq!( + data, + [ + 0, // Version (0) + 3, // Tag for AccountTransactionV1 (3) + 1, // Sender: One account signature + 1, // Credential index 1 + 1, // One credential signature + 2, // Key index 2 + 0, 64, // Signature length (64) + 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, + 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, + 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, // Signature (64 bytes, all 5) + 1, // Sponsor: One account signature + 0, // Credential index 0 + 1, // One credential signature + 0, // Key index 0 + 0, 64, // Signature length (64) + 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, + 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, + 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, // Signature (64 bytes, all 8) + 0, 1, // Bitmap fields (indicating presence of sponsor address) + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, // Sender (32 bytes, all 42) + 0, 0, 0, 0, 0, 0, 0, 2, // Sequence number (2) + 0, 0, 0, 0, 0, 0, 7, 208, // Energy amount (2000) + 0, 0, 0, 75, // Payload size (75 bytes) + 0, 0, 0, 0, 0, 9, 251, 241, // Expiry (123456) + 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, + 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, + 99, // Sponsor (32 bytes, all 99) + 22, // Transfer with memo payload + 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, + 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, + 12, // Receiver (32 bytes, all 12) + 0, 32, // Memo length (32 bytes) + 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, + 7, 7, 7, 7, 7, 7, // Receiver (32 bytes, all 7) + 0, 0, 0, 0, 0, 0, 0, 123 // Amount (123) + ] + ); + } + + #[test] + fn test_send_block_item_request_get_v0_format_raw_block_item() { + use super::*; + // Prepare a raw block item with some bytes. + let raw_bytes = vec![1, 2, 3, 4, 5, 6, 7, 8, 9, 10]; + let req = SendBlockItemRequest { + block_item: Some(send_block_item_request::BlockItem::RawBlockItem( + raw_bytes.clone(), + )), + }; + + // Call get_v0_format and check the result. + let result = req.get_v0_format(); + assert!(result.is_ok()); + let data = result.unwrap(); + + // The result should start with the version prefix (0u8 as Version). + // The rest should be the raw bytes. + // Version serialization is just 1 byte for 0. + assert_eq!(data[0], 0); + assert_eq!(&data[1..], &raw_bytes[..]); + } + } } /// The service generated from the configuration in the `build.rs` file. From cd82e8a8759597547812c424db6f9123b7c66b05 Mon Sep 17 00:00:00 2001 From: Thomas Dinsdale-Young Date: Thu, 27 Nov 2025 17:49:08 +0100 Subject: [PATCH 19/26] Check for extended transaction when executing. Update changelog. --- CHANGELOG.md | 1 + concordium-base | 2 +- concordium-consensus/src/Concordium/Scheduler.hs | 6 ++++++ 3 files changed, 8 insertions(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index e9bb338b0e..af58ea573f 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -10,6 +10,7 @@ - Fixed the `build_catchup_url` in the Ubuntu build release pipeline. - Added boilerplate code for the upcoming P10. - Extended the GRPC API to support submitting sponsored transactions. +- Support for sponsored transactions from protocol version 10. ## 9.0.7 diff --git a/concordium-base b/concordium-base index 9c530b619e..6d8866bb37 160000 --- a/concordium-base +++ b/concordium-base @@ -1 +1 @@ -Subproject commit 9c530b619e9c6451d099a35c9285dfd7d67718fc +Subproject commit 6d8866bb376b2c8d2ee8851028fe1016fcd65fc0 diff --git a/concordium-consensus/src/Concordium/Scheduler.hs b/concordium-consensus/src/Concordium/Scheduler.hs index 470b615e7a..e2d9663731 100644 --- a/concordium-consensus/src/Concordium/Scheduler.hs +++ b/concordium-consensus/src/Concordium/Scheduler.hs @@ -124,6 +124,7 @@ data CheckHeaderResult m = CheckHeaderResult } -- | The function asserts the following +-- * if the transaction is an 'AccountTransactionV1', then the protocol version supports sponsored transactions. -- * the transaction has a valid sender, -- * the amount corresponding to the deposited energy is on the sender account, -- * the transaction is not expired, @@ -145,6 +146,11 @@ checkHeader :: Maybe TVer.VerificationResult -> ExceptT (Maybe FailureKind) m (CheckHeaderResult m) checkHeader meta mVerRes = do + case sSupportsSponsoredTransactions (protocolVersion @(MPV m)) of + SFalse + | transactionIsExtended meta -> + throwError $ Just NotSupportedAtCurrentProtocolVersion + _ -> return () unless (validatePayloadSize (protocolVersion @(MPV m)) (thPayloadSize (transactionHeader meta))) $ throwError $ Just InvalidPayloadSize -- Before even checking the header we calculate the cost that will be charged for this -- and check that at least that much energy is deposited and remaining from the maximum block energy. From 0c9885365cf917536416fef729f1acd270f82b28 Mon Sep 17 00:00:00 2001 From: Thomas Dinsdale-Young Date: Fri, 28 Nov 2025 12:28:23 +0100 Subject: [PATCH 20/26] 10.0.0 devnet release --- CHANGELOG.md | 2 ++ concordium-base | 2 +- concordium-node/Cargo.lock | 2 +- concordium-node/Cargo.toml | 2 +- 4 files changed, 5 insertions(+), 3 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index af58ea573f..b8ecc9f9c0 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,8 @@ ## Unreleased changes +## 10.0.0 (DevNet) + - Updated the token module interface in accordance with adjustments to the PLT specification where token name, metadata and governance account are now optional in the token module initialization parameterts and diff --git a/concordium-base b/concordium-base index 6d8866bb37..e1b1814de2 160000 --- a/concordium-base +++ b/concordium-base @@ -1 +1 @@ -Subproject commit 6d8866bb376b2c8d2ee8851028fe1016fcd65fc0 +Subproject commit e1b1814de2d1e6b27a0ca5dcc058366718f09371 diff --git a/concordium-node/Cargo.lock b/concordium-node/Cargo.lock index dc77a15531..3c42b7ca19 100644 --- a/concordium-node/Cargo.lock +++ b/concordium-node/Cargo.lock @@ -818,7 +818,7 @@ dependencies = [ [[package]] name = "concordium_node" -version = "9.0.7" +version = "10.0.0" dependencies = [ "anyhow", "app_dirs2", diff --git a/concordium-node/Cargo.toml b/concordium-node/Cargo.toml index c4d13156ed..446a1b2b39 100644 --- a/concordium-node/Cargo.toml +++ b/concordium-node/Cargo.toml @@ -1,6 +1,6 @@ [package] name = "concordium_node" -version = "9.0.7" # must be kept in sync with 'is_compatible_version' in 'src/configuration.rs' +version = "10.0.0" # must be kept in sync with 'is_compatible_version' in 'src/configuration.rs' description = "Concordium Node" authors = ["Concordium "] exclude = [".gitignore", ".gitlab-ci.yml", "test/**/*","**/**/.gitignore","**/**/.gitlab-ci.yml"] From 09e88dd42096415473997fe27f2959f877a18d2b Mon Sep 17 00:00:00 2001 From: Thomas Dinsdale-Young Date: Fri, 28 Nov 2025 16:21:11 +0100 Subject: [PATCH 21/26] Windows release image use windows-2022. --- .github/workflows/release.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/release.yaml b/.github/workflows/release.yaml index f6e4e3f170..435ce1b90e 100644 --- a/.github/workflows/release.yaml +++ b/.github/workflows/release.yaml @@ -242,7 +242,7 @@ jobs: path: ${{ env.ARTIFACT_NAME }} node-windows: - runs-on: windows-latest + runs-on: windows-2022 environment: release # This step needs to use the release context to access credentials for code signing. needs: [validate-preconditions] if: contains(fromJSON('["rc", "alpha", "node-windows"]'), needs.validate-preconditions.outputs.release_type) From c573565ef14dcc05836bedcdce6793a4581e73f5 Mon Sep 17 00:00:00 2001 From: Thomas Dinsdale-Young Date: Tue, 2 Dec 2025 16:00:07 +0100 Subject: [PATCH 22/26] Test sponsored transaction execution. --- .gitignore | 3 + .../SchedulerTests/SponsoredTransactions.hs | 828 ++++++++++++++++++ concordium-consensus/tests/scheduler/Spec.hs | 2 + 3 files changed, 833 insertions(+) create mode 100644 concordium-consensus/tests/scheduler/SchedulerTests/SponsoredTransactions.hs diff --git a/.gitignore b/.gitignore index 0ccf8a9467..b4e95ca100 100644 --- a/.gitignore +++ b/.gitignore @@ -65,3 +65,6 @@ xcuserdata/ /scripts/distribution/macOS-package/NodeConfigurationInstallerPlugin/*.gcno # Code coverage report lcov.info +# Test artefacts +.stack-work-coverage* +*.blob \ No newline at end of file diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/SponsoredTransactions.hs b/concordium-consensus/tests/scheduler/SchedulerTests/SponsoredTransactions.hs new file mode 100644 index 0000000000..40e6cd9e12 --- /dev/null +++ b/concordium-consensus/tests/scheduler/SchedulerTests/SponsoredTransactions.hs @@ -0,0 +1,828 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | This module implements tests covering sponsored transactions. +module SchedulerTests.SponsoredTransactions (tests) where + +import Control.Monad.Reader +import qualified Data.Map.Strict as Map +import Lens.Micro.Platform +import Test.HUnit +import Test.Hspec + +import qualified Concordium.Crypto.SignatureScheme as SigScheme +import Concordium.GlobalState.BlockState +import qualified Concordium.GlobalState.Persistent.BlockState as BS +import Concordium.GlobalState.Transactions +import Concordium.GlobalState.Types +import Concordium.ID.Types +import Concordium.Scheduler.Types +import qualified Concordium.TransactionVerification as TVer +import Concordium.Types.HashableTo + +import Concordium.Common.Time +import Concordium.GlobalState.Classes +import Concordium.ID.DummyData (dummyCredential) +import qualified SchedulerTests.Helpers as Helpers + +type SignKeys = [(CredentialIndex, [(KeyIndex, SigScheme.KeyPair)])] + +signAccountTransactionV1 :: (PayloadSize -> TransactionHeaderV1) -> EncodedPayload -> SignKeys -> Maybe SignKeys -> AccountTransactionV1 +signAccountTransactionV1 mkHeader payload sender sponsor = + AccountTransactionV1 + { atrv1Signature = + TransactionSignaturesV1 + { tsv1Sender = txSign sender, + tsv1Sponsor = txSign <$> sponsor + }, + atrv1Header = header, + atrv1Payload = payload, + atrv1SignHash = signHash + } + where + header = mkHeader (payloadSize payload) + signHash = transactionV1SignHashFromHeaderPayload header payload + signHashBytes = transactionSignHashToByteString signHash + credSign = Map.fromList . map (\(idx, key) -> (idx, SigScheme.sign key signHashBytes)) + txSign = TransactionSignature . Map.fromList . map (\(idx, credKeys) -> (idx, credSign credKeys)) + +makeHeaderV1 :: + AccountAddress -> + Maybe AccountAddress -> + Nonce -> + Energy -> + PayloadSize -> + TransactionHeaderV1 +makeHeaderV1 sender sponsor nonce energy pSize = + TransactionHeaderV1 + { thv1HeaderV0 = + TransactionHeader + { thSender = sender, + thNonce = nonce, + thEnergyAmount = energy, + thExpiry = TransactionTime maxBound, + thPayloadSize = pSize + }, + thv1Sponsor = sponsor + } + +initialAmounts :: [Amount] +initialAmounts = [1_000_000, 1_000_000, 500, 0] + +constructInitialBlockState :: forall pv. (IsProtocolVersion pv) => Helpers.PersistentBSM pv (BS.HashedPersistentBlockState pv) +constructInitialBlockState = + Helpers.createTestBlockStateWithAccountsM $ + fmap + (uncurry Helpers.makeTestAccountFromSeed) + (zip initialAmounts [0 ..]) + +-- | Create an 'Expectation' that asserts the account balance in the given block +-- state is as expected. +assertAccountBalance :: (BlockStateOperations m) => UpdatableBlockState m -> AccountIndex -> Amount -> m Expectation +assertAccountBalance bs accIndex expectAmount = do + bsoGetAccountByIndex bs accIndex >>= \case + Nothing -> return $ assertFailure $ "Missing account at index " ++ show accIndex + Just acc -> do + balance <- getAccountAmount acc + return $ + assertEqual + ("Balance of account " ++ show accIndex) + expectAmount + balance + +-- | Create an 'Expectation' that asserts that the accounts have the corresponding balances +-- (in order of account index, starting from 0). +assertAccountBalances :: (BlockStateOperations m) => UpdatableBlockState m -> [Amount] -> m Expectation +assertAccountBalances bs expectAmounts = + sequence_ + <$> mapM (uncurry (assertAccountBalance bs)) (zip [0 ..] expectAmounts) + +-- | Test that a sponsored transaction is discarded in P9. +testSponsoredTransferP9 :: Expectation +testSponsoredTransferP9 = do + expectation <- Helpers.runTestBlockState $ do + initialState <- constructInitialBlockState @'P9 + (result, _finalState) <- Helpers.runScheduler Helpers.defaultTestConfig initialState transactions + return $ do + assertEqual + "Failed transactions" + [((testTransaction, Nothing), NotSupportedAtCurrentProtocolVersion)] + (ftFailed (Helpers.srTransactions result)) + assertEqual "Added transactions" [] (ftAdded (Helpers.srTransactions result)) + expectation + where + transactions = [TGAccountTransactions [(testTransaction, Nothing)]] + acc = Helpers.accountAddressFromSeed + keypair = Helpers.keyPairFromSeed + testTransaction = + fromAccountTransactionV1 0 $ + signAccountTransactionV1 + (makeHeaderV1 (acc 3) (Just (acc 0)) 1 1000) + (encodePayload (Transfer (acc 1) 50)) + [(0, [(0, keypair 3)])] + (Just [(0, [(0, keypair 0)])]) + +-- | Test that an extended (but not sponsored) transaction is discarded in P9. +testExtendedTransactionP9 :: Expectation +testExtendedTransactionP9 = do + expectation <- Helpers.runTestBlockState $ do + initialState <- constructInitialBlockState @'P9 + (result, _finalState) <- Helpers.runScheduler Helpers.defaultTestConfig initialState transactions + return $ do + assertEqual + "Failed transactions" + [((testTransaction, Nothing), NotSupportedAtCurrentProtocolVersion)] + (ftFailed (Helpers.srTransactions result)) + assertEqual "Added transactions" [] (ftAdded (Helpers.srTransactions result)) + expectation + where + transactions = [TGAccountTransactions [(testTransaction, Nothing)]] + acc = Helpers.accountAddressFromSeed + keypair = Helpers.keyPairFromSeed + testTransaction = + fromAccountTransactionV1 0 $ + signAccountTransactionV1 + (makeHeaderV1 (acc 3) Nothing 1 1000) + (encodePayload (Transfer (acc 1) 50)) + [(0, [(0, keypair 3)])] + Nothing + +-- | Test a sponsored transaction where the sender has insufficient balance to cover the transfer +-- amount is rejected (but added to the block) in P10. +testSponsoredTransferRejectP10 :: Expectation +testSponsoredTransferRejectP10 = do + expectation <- Helpers.runTestBlockState $ do + initialState <- constructInitialBlockState @'P10 + (result, finalState) <- Helpers.runScheduler Helpers.defaultTestConfig initialState transactions + expAccBalances <- + assertAccountBalances + finalState + (initialAmounts & ix 0 -~ 63500) + return $ do + let resultTransactions = Helpers.srTransactions result + assertEqual "Failed transactions" [] (ftFailed resultTransactions) + assertEqual + "Added transactions" + [((toBlockItem testTransaction, Nothing), summary)] + (ftAdded resultTransactions) + expAccBalances + expectation + where + transactions = [TGAccountTransactions [(testTransaction, Nothing)]] + acc = Helpers.accountAddressFromSeed + keypair = Helpers.keyPairFromSeed + testTransaction = + fromAccountTransactionV1 0 $ + signAccountTransactionV1 + (makeHeaderV1 (acc 3) (Just (acc 0)) 1 1000) + (encodePayload (Transfer (acc 1) 50)) + [(0, [(0, keypair 3)])] + (Just [(0, [(0, keypair 0)])]) + summary = + TransactionSummary + { tsSender = Just (acc 3), + tsHash = getHash testTransaction, + tsCost = 0, + tsEnergyCost = 635, + tsType = TSTAccountTransaction (Just TTTransfer), + tsResult = TxReject{vrRejectReason = AmountTooLarge (AddressAccount $ acc 3) 50}, + tsIndex = 0, + tsSponsorDetails = + CTrue + ( Just + ( SponsorDetails + { sdSponsor = acc 0, + sdCost = 63500 + } + ) + ) + } + +-- | Test a sponsored transaction success case. +testSponsoredTransferSuccessP10 :: Expectation +testSponsoredTransferSuccessP10 = do + expectation <- Helpers.runTestBlockState $ do + initialState <- constructInitialBlockState @'P10 + (result, finalState) <- Helpers.runScheduler Helpers.defaultTestConfig initialState transactions + expAccBalances <- + assertAccountBalances + finalState + (initialAmounts & ix 0 -~ 63500 & ix 2 -~ 500 & ix 1 +~ 500) + return $ do + let resultTransactions = Helpers.srTransactions result + assertEqual "Failed transactions" [] (ftFailed resultTransactions) + assertEqual + "Added transactions" + [((toBlockItem testTransaction, Nothing), summary)] + (ftAdded resultTransactions) + expAccBalances + expectation + where + transactions = [TGAccountTransactions [(testTransaction, Nothing)]] + acc = Helpers.accountAddressFromSeed + keypair = Helpers.keyPairFromSeed + testTransaction = + fromAccountTransactionV1 0 $ + signAccountTransactionV1 + (makeHeaderV1 (acc 2) (Just (acc 0)) 1 1000) + (encodePayload (Transfer (acc 1) 500)) + [(0, [(0, keypair 2)])] + (Just [(0, [(0, keypair 0)])]) + summary = + TransactionSummary + { tsSender = Just (acc 2), + tsHash = getHash testTransaction, + tsCost = 0, + tsEnergyCost = 635, + tsType = TSTAccountTransaction (Just TTTransfer), + tsResult = + TxSuccess + { vrEvents = + [ Transferred + { etFrom = AddressAccount (acc 2), + etTo = AddressAccount (acc 1), + etAmount = 500 + } + ] + }, + tsIndex = 0, + tsSponsorDetails = + CTrue + ( Just + ( SponsorDetails + { sdSponsor = acc 0, + sdCost = 63500 + } + ) + ) + } + +-- | Test an extended transaction success case in P10. +testExtendedTransactionSuccessP10 :: Expectation +testExtendedTransactionSuccessP10 = do + expectation <- Helpers.runTestBlockState $ do + initialState <- constructInitialBlockState @'P10 + (result, finalState) <- Helpers.runScheduler Helpers.defaultTestConfig initialState transactions + expAccBalances <- + assertAccountBalances + finalState + (initialAmounts & ix 0 -~ 50300 & ix 0 -~ 500 & ix 1 +~ 500) + return $ do + let resultTransactions = Helpers.srTransactions result + assertEqual "Failed transactions" [] (ftFailed resultTransactions) + assertEqual + "Added transactions" + [((toBlockItem testTransaction, Nothing), summary)] + (ftAdded resultTransactions) + expAccBalances + expectation + where + transactions = [TGAccountTransactions [(testTransaction, Nothing)]] + acc = Helpers.accountAddressFromSeed + keypair = Helpers.keyPairFromSeed + testTransaction = + fromAccountTransactionV1 0 $ + signAccountTransactionV1 + (makeHeaderV1 (acc 0) Nothing 1 1000) + (encodePayload (Transfer (acc 1) 500)) + [(0, [(0, keypair 0)])] + (Nothing) + summary = + TransactionSummary + { tsSender = Just (acc 0), + tsHash = getHash testTransaction, + tsCost = 50300, + tsEnergyCost = 503, + tsType = TSTAccountTransaction (Just TTTransfer), + tsResult = + TxSuccess + { vrEvents = + [ Transferred + { etFrom = AddressAccount (acc 0), + etTo = AddressAccount (acc 1), + etAmount = 500 + } + ] + }, + tsIndex = 0, + tsSponsorDetails = CTrue Nothing + } + +-- | Test a sponsored transaction success case where the sender is the sponsor. +testSelfSponsoredTransferSuccessP10 :: Expectation +testSelfSponsoredTransferSuccessP10 = do + expectation <- Helpers.runTestBlockState $ do + initialState <- constructInitialBlockState @'P10 + (result, finalState) <- Helpers.runScheduler Helpers.defaultTestConfig initialState transactions + expAccBalances <- + assertAccountBalances + finalState + (initialAmounts & ix 0 -~ 63500 & ix 0 -~ 500 & ix 1 +~ 500) + return $ do + let resultTransactions = Helpers.srTransactions result + assertEqual "Failed transactions" [] (ftFailed resultTransactions) + assertEqual + "Added transactions" + [((toBlockItem testTransaction, Nothing), summary)] + (ftAdded resultTransactions) + expAccBalances + expectation + where + transactions = [TGAccountTransactions [(testTransaction, Nothing)]] + acc = Helpers.accountAddressFromSeed + keypair = Helpers.keyPairFromSeed + testTransaction = + fromAccountTransactionV1 0 $ + signAccountTransactionV1 + (makeHeaderV1 (acc 0) (Just (acc 0)) 1 1000) + (encodePayload (Transfer (acc 1) 500)) + [(0, [(0, keypair 0)])] + (Just [(0, [(0, keypair 0)])]) + summary = + TransactionSummary + { tsSender = Just (acc 0), + tsHash = getHash testTransaction, + tsCost = 0, + tsEnergyCost = 635, + tsType = TSTAccountTransaction (Just TTTransfer), + tsResult = + TxSuccess + { vrEvents = + [ Transferred + { etFrom = AddressAccount (acc 0), + etTo = AddressAccount (acc 1), + etAmount = 500 + } + ] + }, + tsIndex = 0, + tsSponsorDetails = + CTrue + ( Just + ( SponsorDetails + { sdSponsor = acc 0, + sdCost = 63500 + } + ) + ) + } + +newtype TestAccountNonceQueryT bs m a = TestAccountNonceQueryT {runTestAccountNonceQueryT :: bs -> m a} + deriving (Functor, Applicative, Monad) via (ReaderT bs m) + deriving (MonadTrans) via (ReaderT bs) + +-- Instance for deducing the protocol version from the parameterized @m@ of the 'AccountNonceQueryT'. +deriving via (MGSTrans (TestAccountNonceQueryT bs) m) instance (MonadProtocolVersion m) => MonadProtocolVersion (TestAccountNonceQueryT bs m) + +-- Instances required in order to use the 'AccountNonceQueryT' monad from within a block state context. +deriving via (MGSTrans (TestAccountNonceQueryT bs) m) instance BlockStateTypes (TestAccountNonceQueryT bs m) +deriving via (MGSTrans (TestAccountNonceQueryT bs) m) instance (TokenStateOperations ts m) => TokenStateOperations ts (TestAccountNonceQueryT bs m) +deriving via (MGSTrans (TestAccountNonceQueryT bs) m) instance (PLTQuery bs' ts m) => PLTQuery bs' ts (TestAccountNonceQueryT bs m) +deriving via (MGSTrans (TestAccountNonceQueryT bs) m) instance (BlockStateQuery m) => BlockStateQuery (TestAccountNonceQueryT bs m) +deriving via (MGSTrans (TestAccountNonceQueryT bs) m) instance (ContractStateOperations m) => ContractStateOperations (TestAccountNonceQueryT bs m) +deriving via (MGSTrans (TestAccountNonceQueryT bs) m) instance (AccountOperations m) => AccountOperations (TestAccountNonceQueryT bs m) +deriving via (MGSTrans (TestAccountNonceQueryT bs) m) instance (ModuleQuery m) => ModuleQuery (TestAccountNonceQueryT bs m) + +instance (bs ~ BlockState m, BlockStateQuery m) => AccountNonceQuery (TestAccountNonceQueryT bs m) where + getNextAccountNonce :: + (bs ~ BlockState m, BlockStateQuery m) => + AccountAddressEq -> TestAccountNonceQueryT bs m (Nonce, Bool) + getNextAccountNonce (AccountAddressEq addr) = TestAccountNonceQueryT $ \bs -> do + getAccount bs addr >>= \case + Nothing -> return (minNonce, True) + Just (_, acct) -> do + nonce <- getAccountNonce acct + return (nonce, True) + +verifyTx :: (BlockStateQuery m, BlockState m ~ BS.HashedPersistentBlockState (MPV m)) => BlockState m -> Transaction -> m TVer.VerificationResult +verifyTx bs tx = do + runTestAccountNonceQueryT (runTransactionVerifierT (TVer.verifyExtendedTransaction tx) ctx) bs + where + ctx = + Context + { _ctxTransactionOrigin = TVer.Individual, + _ctxMaxBlockEnergy = 10_000, + _ctxBs = bs + } + +-- | Test a sponsored transaction success case where the transaction is first verified. +testVerifySponsoredTransferSuccessP10 :: Expectation +testVerifySponsoredTransferSuccessP10 = do + expectation <- Helpers.runTestBlockState $ do + initialState <- constructInitialBlockState @'P10 + verRes <- verifyTx initialState testTransaction + case verRes of + TVer.Ok (TVer.ExtendedTransactionSuccess{}) -> return () + _ -> liftIO . assertFailure $ "Expected ExtendedTransactionSuccess{..} but saw " ++ show verRes + let transactions = [TGAccountTransactions [(testTransaction, Just verRes)]] + (result, finalState) <- Helpers.runScheduler Helpers.defaultTestConfig initialState transactions + expAccBalances <- + assertAccountBalances + finalState + (initialAmounts & ix 0 -~ 63500 & ix 2 -~ 500 & ix 1 +~ 500) + return $ do + let resultTransactions = Helpers.srTransactions result + assertEqual "Failed transactions" [] (ftFailed resultTransactions) + assertEqual + "Added transactions" + [((toBlockItem testTransaction, Just verRes), summary)] + (ftAdded resultTransactions) + expAccBalances + expectation + where + acc = Helpers.accountAddressFromSeed + keypair = Helpers.keyPairFromSeed + testTransaction = + fromAccountTransactionV1 0 $ + signAccountTransactionV1 + (makeHeaderV1 (acc 2) (Just (acc 0)) 1 1000) + (encodePayload (Transfer (acc 1) 500)) + [(0, [(0, keypair 2)])] + (Just [(0, [(0, keypair 0)])]) + summary = + TransactionSummary + { tsSender = Just (acc 2), + tsHash = getHash testTransaction, + tsCost = 0, + tsEnergyCost = 635, + tsType = TSTAccountTransaction (Just TTTransfer), + tsResult = + TxSuccess + { vrEvents = + [ Transferred + { etFrom = AddressAccount (acc 2), + etTo = AddressAccount (acc 1), + etAmount = 500 + } + ] + }, + tsIndex = 0, + tsSponsorDetails = + CTrue + ( Just + ( SponsorDetails + { sdSponsor = acc 0, + sdCost = 63500 + } + ) + ) + } + +-- | Test a sponsored transaction success case where the transaction is first verified, then the +-- sponsor's keys are changed (while keeping the signature valid). +testVerifyChangeSponsorKeySponsoredTransferSuccessP10 :: Expectation +testVerifyChangeSponsorKeySponsoredTransferSuccessP10 = do + expectation <- Helpers.runTestBlockState $ do + initialState <- constructInitialBlockState @'P10 + verRes <- verifyTx initialState testTransaction + case verRes of + TVer.Ok (TVer.ExtendedTransactionSuccess{}) -> return () + _ -> liftIO . assertFailure $ "Expected ExtendedTransactionSuccess{..} but saw " ++ show verRes + let transactions = [TGAccountTransactions [(testTransaction, Just verRes)]] + keyChangeState <- do + mbs0 <- thawBlockState initialState + let newKeys = + CredentialPublicKeys + { credKeys = + Map.fromList + [ (0, SigScheme.correspondingVerifyKey (keypair 0)), + (1, SigScheme.correspondingVerifyKey (keypair 100)) + ], + credThreshold = 1 + } + mbs1 <- bsoSetAccountCredentialKeys mbs0 0 0 newKeys + gc <- bsoGetCryptoParams mbs1 + let cred = dummyCredential gc (acc 0) (SigScheme.correspondingVerifyKey (keypair 200)) (YearMonth 3000 1) (YearMonth 2000 1) + let addCreds = Map.singleton 1 cred + mbs2 <- bsoUpdateAccountCredentials mbs1 0 [] addCreds 1 + freezeBlockState mbs2 + (result, finalState) <- Helpers.runScheduler Helpers.defaultTestConfig keyChangeState transactions + expAccBalances <- + assertAccountBalances + finalState + (initialAmounts & ix 0 -~ 63500 & ix 2 -~ 500 & ix 1 +~ 500) + return $ do + let resultTransactions = Helpers.srTransactions result + assertEqual "Failed transactions" [] (ftFailed resultTransactions) + assertEqual + "Added transactions" + [((toBlockItem testTransaction, Just verRes), summary)] + (ftAdded resultTransactions) + expAccBalances + expectation + where + acc = Helpers.accountAddressFromSeed + keypair = Helpers.keyPairFromSeed + testTransaction = + fromAccountTransactionV1 0 $ + signAccountTransactionV1 + (makeHeaderV1 (acc 2) (Just (acc 0)) 1 1000) + (encodePayload (Transfer (acc 1) 500)) + [(0, [(0, keypair 2)])] + (Just [(0, [(0, keypair 0)])]) + summary = + TransactionSummary + { tsSender = Just (acc 2), + tsHash = getHash testTransaction, + tsCost = 0, + tsEnergyCost = 635, + tsType = TSTAccountTransaction (Just TTTransfer), + tsResult = + TxSuccess + { vrEvents = + [ Transferred + { etFrom = AddressAccount (acc 2), + etTo = AddressAccount (acc 1), + etAmount = 500 + } + ] + }, + tsIndex = 0, + tsSponsorDetails = + CTrue + ( Just + ( SponsorDetails + { sdSponsor = acc 0, + sdCost = 63500 + } + ) + ) + } + +-- | Test a sponsored transaction case where the transaction is first verified, then the +-- sponsor's keys are changed increasing the threshold and rendering the transaction invalid. +testVerifyChangeSponsorKeySponsoredTransferFailureIncreaseThresholdP10 :: Expectation +testVerifyChangeSponsorKeySponsoredTransferFailureIncreaseThresholdP10 = do + expectation <- Helpers.runTestBlockState $ do + initialState <- constructInitialBlockState @'P10 + verRes <- verifyTx initialState testTransaction + case verRes of + TVer.Ok (TVer.ExtendedTransactionSuccess{}) -> return () + _ -> liftIO . assertFailure $ "Expected ExtendedTransactionSuccess{..} but saw " ++ show verRes + let transactions = [TGAccountTransactions [(testTransaction, Just verRes)]] + keyChangeState <- do + mbs0 <- thawBlockState initialState + let newKeys = + CredentialPublicKeys + { credKeys = + Map.fromList + [ (0, SigScheme.correspondingVerifyKey (keypair 0)), + (1, SigScheme.correspondingVerifyKey (keypair 100)) + ], + credThreshold = 2 + } + mbs1 <- bsoSetAccountCredentialKeys mbs0 0 0 newKeys + freezeBlockState mbs1 + (result, finalState) <- Helpers.runScheduler Helpers.defaultTestConfig keyChangeState transactions + expAccBalances <- assertAccountBalances finalState initialAmounts + return $ do + let resultTransactions = Helpers.srTransactions result + assertEqual + "Failed transactions" + [((testTransaction, Just verRes), IncorrectSignature)] + (ftFailed resultTransactions) + assertEqual "Added transactions" [] (ftAdded resultTransactions) + expAccBalances + expectation + where + acc = Helpers.accountAddressFromSeed + keypair = Helpers.keyPairFromSeed + testTransaction = + fromAccountTransactionV1 0 $ + signAccountTransactionV1 + (makeHeaderV1 (acc 2) (Just (acc 0)) 1 1000) + (encodePayload (Transfer (acc 1) 500)) + [(0, [(0, keypair 2)])] + (Just [(0, [(0, keypair 0)])]) + +-- | Test a sponsored transaction case where the transaction is first verified, then the +-- sponsor's keys are changed increasing the credential threshold and rendering the transaction invalid. +testVerifyChangeSponsorKeySponsoredTransferFailureIncreaseCredentialThresholdP10 :: Expectation +testVerifyChangeSponsorKeySponsoredTransferFailureIncreaseCredentialThresholdP10 = do + expectation <- Helpers.runTestBlockState $ do + initialState <- constructInitialBlockState @'P10 + verRes <- verifyTx initialState testTransaction + case verRes of + TVer.Ok (TVer.ExtendedTransactionSuccess{}) -> return () + _ -> liftIO . assertFailure $ "Expected ExtendedTransactionSuccess{..} but saw " ++ show verRes + let transactions = [TGAccountTransactions [(testTransaction, Just verRes)]] + keyChangeState <- do + mbs0 <- thawBlockState initialState + gc <- bsoGetCryptoParams mbs0 + let cred = dummyCredential gc (acc 0) (SigScheme.correspondingVerifyKey (keypair 200)) (YearMonth 3000 1) (YearMonth 2000 1) + let addCreds = Map.singleton 1 cred + mbs1 <- bsoUpdateAccountCredentials mbs0 0 [] addCreds 2 + freezeBlockState mbs1 + (result, finalState) <- Helpers.runScheduler Helpers.defaultTestConfig keyChangeState transactions + expAccBalances <- assertAccountBalances finalState initialAmounts + return $ do + let resultTransactions = Helpers.srTransactions result + assertEqual + "Failed transactions" + [((testTransaction, Just verRes), IncorrectSignature)] + (ftFailed resultTransactions) + assertEqual "Added transactions" [] (ftAdded resultTransactions) + expAccBalances + expectation + where + acc = Helpers.accountAddressFromSeed + keypair = Helpers.keyPairFromSeed + testTransaction = + fromAccountTransactionV1 0 $ + signAccountTransactionV1 + (makeHeaderV1 (acc 2) (Just (acc 0)) 1 1000) + (encodePayload (Transfer (acc 1) 500)) + [(0, [(0, keypair 2)])] + (Just [(0, [(0, keypair 0)])]) + +-- | Test a sponsored transaction success case where the transaction is first verified, then the +-- sender's keys are changed (while keeping the signature valid). +testVerifyChangeSenderKeySponsoredTransferSuccessP10 :: Expectation +testVerifyChangeSenderKeySponsoredTransferSuccessP10 = do + expectation <- Helpers.runTestBlockState $ do + initialState <- constructInitialBlockState @'P10 + verRes <- verifyTx initialState testTransaction + case verRes of + TVer.Ok (TVer.ExtendedTransactionSuccess{}) -> return () + _ -> liftIO . assertFailure $ "Expected ExtendedTransactionSuccess{..} but saw " ++ show verRes + let transactions = [TGAccountTransactions [(testTransaction, Just verRes)]] + keyChangeState <- do + mbs0 <- thawBlockState initialState + let newKeys = + CredentialPublicKeys + { credKeys = + Map.fromList + [ (0, SigScheme.correspondingVerifyKey (keypair 2)), + (1, SigScheme.correspondingVerifyKey (keypair 100)) + ], + credThreshold = 1 + } + mbs1 <- bsoSetAccountCredentialKeys mbs0 2 0 newKeys + gc <- bsoGetCryptoParams mbs1 + let cred = dummyCredential gc (acc 0) (SigScheme.correspondingVerifyKey (keypair 200)) (YearMonth 3000 1) (YearMonth 2000 1) + let addCreds = Map.singleton 1 cred + mbs2 <- bsoUpdateAccountCredentials mbs1 2 [] addCreds 1 + freezeBlockState mbs2 + (result, finalState) <- Helpers.runScheduler Helpers.defaultTestConfig keyChangeState transactions + expAccBalances <- + assertAccountBalances + finalState + (initialAmounts & ix 0 -~ 63500 & ix 2 -~ 500 & ix 1 +~ 500) + return $ do + let resultTransactions = Helpers.srTransactions result + assertEqual "Failed transactions" [] (ftFailed resultTransactions) + assertEqual + "Added transactions" + [((toBlockItem testTransaction, Just verRes), summary)] + (ftAdded resultTransactions) + expAccBalances + expectation + where + acc = Helpers.accountAddressFromSeed + keypair = Helpers.keyPairFromSeed + testTransaction = + fromAccountTransactionV1 0 $ + signAccountTransactionV1 + (makeHeaderV1 (acc 2) (Just (acc 0)) 1 1000) + (encodePayload (Transfer (acc 1) 500)) + [(0, [(0, keypair 2)])] + (Just [(0, [(0, keypair 0)])]) + summary = + TransactionSummary + { tsSender = Just (acc 2), + tsHash = getHash testTransaction, + tsCost = 0, + tsEnergyCost = 635, + tsType = TSTAccountTransaction (Just TTTransfer), + tsResult = + TxSuccess + { vrEvents = + [ Transferred + { etFrom = AddressAccount (acc 2), + etTo = AddressAccount (acc 1), + etAmount = 500 + } + ] + }, + tsIndex = 0, + tsSponsorDetails = + CTrue + ( Just + ( SponsorDetails + { sdSponsor = acc 0, + sdCost = 63500 + } + ) + ) + } + +-- | Test a sponsored transaction case where the transaction is first verified, then the +-- sender's keys are changed increasing the threshold and rendering the transaction invalid. +testVerifyChangeSenderKeySponsoredTransferFailureIncreaseThresholdP10 :: Expectation +testVerifyChangeSenderKeySponsoredTransferFailureIncreaseThresholdP10 = do + expectation <- Helpers.runTestBlockState $ do + initialState <- constructInitialBlockState @'P10 + verRes <- verifyTx initialState testTransaction + case verRes of + TVer.Ok (TVer.ExtendedTransactionSuccess{}) -> return () + _ -> liftIO . assertFailure $ "Expected ExtendedTransactionSuccess{..} but saw " ++ show verRes + let transactions = [TGAccountTransactions [(testTransaction, Just verRes)]] + keyChangeState <- do + mbs0 <- thawBlockState initialState + let newKeys = + CredentialPublicKeys + { credKeys = + Map.fromList + [ (0, SigScheme.correspondingVerifyKey (keypair 2)), + (1, SigScheme.correspondingVerifyKey (keypair 100)) + ], + credThreshold = 2 + } + mbs1 <- bsoSetAccountCredentialKeys mbs0 2 0 newKeys + freezeBlockState mbs1 + (result, finalState) <- Helpers.runScheduler Helpers.defaultTestConfig keyChangeState transactions + expAccBalances <- assertAccountBalances finalState initialAmounts + return $ do + let resultTransactions = Helpers.srTransactions result + assertEqual + "Failed transactions" + [((testTransaction, Just verRes), IncorrectSignature)] + (ftFailed resultTransactions) + assertEqual "Added transactions" [] (ftAdded resultTransactions) + expAccBalances + expectation + where + acc = Helpers.accountAddressFromSeed + keypair = Helpers.keyPairFromSeed + testTransaction = + fromAccountTransactionV1 0 $ + signAccountTransactionV1 + (makeHeaderV1 (acc 2) (Just (acc 0)) 1 1000) + (encodePayload (Transfer (acc 1) 500)) + [(0, [(0, keypair 2)])] + (Just [(0, [(0, keypair 0)])]) + +-- | Test a sponsored transaction case where the transaction is first verified, then the +-- sender's keys are changed increasing the credential threshold and rendering the transaction invalid. +testVerifyChangeSenderKeySponsoredTransferFailureIncreaseCredentialThresholdP10 :: Expectation +testVerifyChangeSenderKeySponsoredTransferFailureIncreaseCredentialThresholdP10 = do + expectation <- Helpers.runTestBlockState $ do + initialState <- constructInitialBlockState @'P10 + verRes <- verifyTx initialState testTransaction + case verRes of + TVer.Ok (TVer.ExtendedTransactionSuccess{}) -> return () + _ -> liftIO . assertFailure $ "Expected ExtendedTransactionSuccess{..} but saw " ++ show verRes + let transactions = [TGAccountTransactions [(testTransaction, Just verRes)]] + keyChangeState <- do + mbs0 <- thawBlockState initialState + gc <- bsoGetCryptoParams mbs0 + let cred = dummyCredential gc (acc 2) (SigScheme.correspondingVerifyKey (keypair 200)) (YearMonth 3000 1) (YearMonth 2000 1) + let addCreds = Map.singleton 1 cred + mbs1 <- bsoUpdateAccountCredentials mbs0 2 [] addCreds 2 + freezeBlockState mbs1 + (result, finalState) <- Helpers.runScheduler Helpers.defaultTestConfig keyChangeState transactions + expAccBalances <- assertAccountBalances finalState initialAmounts + return $ do + let resultTransactions = Helpers.srTransactions result + assertEqual + "Failed transactions" + [((testTransaction, Just verRes), IncorrectSignature)] + (ftFailed resultTransactions) + assertEqual "Added transactions" [] (ftAdded resultTransactions) + expAccBalances + expectation + where + acc = Helpers.accountAddressFromSeed + keypair = Helpers.keyPairFromSeed + testTransaction = + fromAccountTransactionV1 0 $ + signAccountTransactionV1 + (makeHeaderV1 (acc 2) (Just (acc 0)) 1 1000) + (encodePayload (Transfer (acc 1) 500)) + [(0, [(0, keypair 2)])] + (Just [(0, [(0, keypair 0)])]) + +tests :: Spec +tests = parallel $ do + it "Sponsored transfer @P9" testSponsoredTransferP9 + it "Extended transaction (transfer, no sponsor) @P9" testExtendedTransactionP9 + + it "Sponsored transfer (reject) @P10" testSponsoredTransferRejectP10 + it "Sponsored transfer (success) @P10" testSponsoredTransferSuccessP10 + it "Extended transaction (transfer, no sponsor, success) @P10" testExtendedTransactionSuccessP10 + it "Self-sponsored transfer (success) @P10" testSelfSponsoredTransferSuccessP10 + it "Pre-verified sponosored transfer (success) @P10" testVerifySponsoredTransferSuccessP10 + it "Verify sponsored then change sponsor keys (success) @P10" testVerifyChangeSponsorKeySponsoredTransferSuccessP10 + it "Verify sponsored then change sponsor keys - increase threshold (failure) @P10" testVerifyChangeSponsorKeySponsoredTransferFailureIncreaseThresholdP10 + it "Verify sponsored then change sponsor keys - increase credential threshold (failure) @P10" testVerifyChangeSponsorKeySponsoredTransferFailureIncreaseCredentialThresholdP10 + it "Verify sponsored then change sender keys (success) @P10" testVerifyChangeSenderKeySponsoredTransferSuccessP10 + it "Verify sponsored then change sender keys - increase threshold (failure) @P10" testVerifyChangeSenderKeySponsoredTransferFailureIncreaseThresholdP10 + it "Verify sponsored then change sender keys - increase credential threshold (failure) @P10" testVerifyChangeSenderKeySponsoredTransferFailureIncreaseCredentialThresholdP10 diff --git a/concordium-consensus/tests/scheduler/Spec.hs b/concordium-consensus/tests/scheduler/Spec.hs index 9026be1f3c..59daf5337d 100644 --- a/concordium-consensus/tests/scheduler/Spec.hs +++ b/concordium-consensus/tests/scheduler/Spec.hs @@ -19,6 +19,7 @@ import qualified SchedulerTests.RejectReasons (tests) import qualified SchedulerTests.RejectReasonsRustContract (tests) import qualified SchedulerTests.SimpleTransferSpec (tests) import qualified SchedulerTests.SimpleTransfersTest (tests) +import qualified SchedulerTests.SponsoredTransactions (tests) import qualified SchedulerTests.StakedAmountLocked (tests) import qualified SchedulerTests.TokenCreation (tests) import qualified SchedulerTests.TokenHolderTransactions (tests) @@ -86,6 +87,7 @@ main = hspec $ do SchedulerTests.StakedAmountLocked.tests SchedulerTests.RejectReasons.tests SchedulerTests.RejectReasonsRustContract.tests + SchedulerTests.SponsoredTransactions.tests SchedulerTests.SmartContracts.V0.SmartContractTests.tests SchedulerTests.SmartContracts.V0.RelaxedRestrictions.tests SchedulerTests.SmartContracts.V1.Counter.tests From 77947e9de4492bb12506d7f06de1d6eae92dc795 Mon Sep 17 00:00:00 2001 From: Thomas Dinsdale-Young Date: Tue, 2 Dec 2025 16:52:16 +0100 Subject: [PATCH 23/26] (Hopefully) fix Windows build signing on windows-latest. --- .github/workflows/release.yaml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/release.yaml b/.github/workflows/release.yaml index 435ce1b90e..53b5a78f6a 100644 --- a/.github/workflows/release.yaml +++ b/.github/workflows/release.yaml @@ -242,7 +242,7 @@ jobs: path: ${{ env.ARTIFACT_NAME }} node-windows: - runs-on: windows-2022 + runs-on: windows-latest environment: release # This step needs to use the release context to access credentials for code signing. needs: [validate-preconditions] if: contains(fromJSON('["rc", "alpha", "node-windows"]'), needs.validate-preconditions.outputs.release_type) @@ -268,7 +268,7 @@ jobs: - name: Install DigiCert Client tools (Windows only) id: digicert_client - uses: digicert/ssm-code-signing@v1.0.0 + uses: digicert/code-signing-software-trust-action@v1.0.0 - name: Import Windows certificate (Windows only) id: windows_certificate From 08a66a1e1d8f98ab707cda1ca250ff0344b3cf03 Mon Sep 17 00:00:00 2001 From: Thomas Dinsdale-Young Date: Wed, 3 Dec 2025 10:55:21 +0100 Subject: [PATCH 24/26] Make scheduler tests parallelizable. --- .../tests/scheduler/SchedulerTests/Helpers.hs | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/Helpers.hs b/concordium-consensus/tests/scheduler/SchedulerTests/Helpers.hs index 9650c9b136..b3209055e3 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/Helpers.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/Helpers.hs @@ -28,6 +28,7 @@ import qualified Data.Map.Strict as Map import qualified Data.Set as Set import Data.Word import Lens.Micro.Platform +import System.IO.Temp import Test.HUnit import qualified Concordium.Crypto.SHA256 as Hash @@ -206,9 +207,10 @@ runTestBlockStateWithCacheSize :: Int -> PersistentBSM pv a -> IO a runTestBlockStateWithCacheSize cacheSize computation = runSilentLogger $ Blob.runBlobStoreTemp "." $ - BS.withNewAccountCacheAndLMDBAccountMap cacheSize "accountmap" $ - BS.runPersistentBlockStateMonad $ - _runPersistentBSM computation + withTempDirectory "." "accountmap" $ \amPath -> + BS.withNewAccountCacheAndLMDBAccountMap cacheSize amPath $ + BS.runPersistentBlockStateMonad $ + _runPersistentBSM computation -- | Run test block state computation with a account cache size and module cache size of 100. -- From e5c77705b9fda098250e02cdbc21337c4d4f11f8 Mon Sep 17 00:00:00 2001 From: Thomas Dinsdale-Young Date: Wed, 3 Dec 2025 16:28:20 +0100 Subject: [PATCH 25/26] Address review comments. --- .../SchedulerTests/SponsoredTransactions.hs | 15 ++++++++++++--- 1 file changed, 12 insertions(+), 3 deletions(-) diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/SponsoredTransactions.hs b/concordium-consensus/tests/scheduler/SchedulerTests/SponsoredTransactions.hs index 40e6cd9e12..a3f923acb5 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/SponsoredTransactions.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/SponsoredTransactions.hs @@ -155,8 +155,8 @@ testExtendedTransactionP9 = do [(0, [(0, keypair 3)])] Nothing --- | Test a sponsored transaction where the sender has insufficient balance to cover the transfer --- amount is rejected (but added to the block) in P10. +-- | Test that a sponsored transaction where the sender has insufficient balance to cover the +-- transfer amount is rejected (but added to the block) in P10. testSponsoredTransferRejectP10 :: Expectation testSponsoredTransferRejectP10 = do expectation <- Helpers.runTestBlockState $ do @@ -498,10 +498,12 @@ testVerifyChangeSponsorKeySponsoredTransferSuccessP10 = do ], credThreshold = 1 } + -- Add a new key to credential 0 of the sponsor. mbs1 <- bsoSetAccountCredentialKeys mbs0 0 0 newKeys gc <- bsoGetCryptoParams mbs1 let cred = dummyCredential gc (acc 0) (SigScheme.correspondingVerifyKey (keypair 200)) (YearMonth 3000 1) (YearMonth 2000 1) let addCreds = Map.singleton 1 cred + -- Add a new credential to the sponsor account. mbs2 <- bsoUpdateAccountCredentials mbs1 0 [] addCreds 1 freezeBlockState mbs2 (result, finalState) <- Helpers.runScheduler Helpers.defaultTestConfig keyChangeState transactions @@ -579,6 +581,7 @@ testVerifyChangeSponsorKeySponsoredTransferFailureIncreaseThresholdP10 = do ], credThreshold = 2 } + -- Add a new key to credential 0 of the sponsor, updating the threshold to 2. mbs1 <- bsoSetAccountCredentialKeys mbs0 0 0 newKeys freezeBlockState mbs1 (result, finalState) <- Helpers.runScheduler Helpers.defaultTestConfig keyChangeState transactions @@ -619,6 +622,7 @@ testVerifyChangeSponsorKeySponsoredTransferFailureIncreaseCredentialThresholdP10 gc <- bsoGetCryptoParams mbs0 let cred = dummyCredential gc (acc 0) (SigScheme.correspondingVerifyKey (keypair 200)) (YearMonth 3000 1) (YearMonth 2000 1) let addCreds = Map.singleton 1 cred + -- Add a new credential to the sponsor account, updating the threshold to 2. mbs1 <- bsoUpdateAccountCredentials mbs0 0 [] addCreds 2 freezeBlockState mbs1 (result, finalState) <- Helpers.runScheduler Helpers.defaultTestConfig keyChangeState transactions @@ -665,10 +669,12 @@ testVerifyChangeSenderKeySponsoredTransferSuccessP10 = do ], credThreshold = 1 } + -- Add a new key to credential 0 of the sender. mbs1 <- bsoSetAccountCredentialKeys mbs0 2 0 newKeys gc <- bsoGetCryptoParams mbs1 let cred = dummyCredential gc (acc 0) (SigScheme.correspondingVerifyKey (keypair 200)) (YearMonth 3000 1) (YearMonth 2000 1) let addCreds = Map.singleton 1 cred + -- Add a new credential to the sender account. mbs2 <- bsoUpdateAccountCredentials mbs1 2 [] addCreds 1 freezeBlockState mbs2 (result, finalState) <- Helpers.runScheduler Helpers.defaultTestConfig keyChangeState transactions @@ -746,6 +752,7 @@ testVerifyChangeSenderKeySponsoredTransferFailureIncreaseThresholdP10 = do ], credThreshold = 2 } + -- Add a new key to credential 0 of the sender increasing the threshold to 2. mbs1 <- bsoSetAccountCredentialKeys mbs0 2 0 newKeys freezeBlockState mbs1 (result, finalState) <- Helpers.runScheduler Helpers.defaultTestConfig keyChangeState transactions @@ -784,8 +791,10 @@ testVerifyChangeSenderKeySponsoredTransferFailureIncreaseCredentialThresholdP10 keyChangeState <- do mbs0 <- thawBlockState initialState gc <- bsoGetCryptoParams mbs0 - let cred = dummyCredential gc (acc 2) (SigScheme.correspondingVerifyKey (keypair 200)) (YearMonth 3000 1) (YearMonth 2000 1) + let dummyPubKey = SigScheme.correspondingVerifyKey (keypair 200) + let cred = dummyCredential gc (acc 2) dummyPubKey (YearMonth 3000 1) (YearMonth 2000 1) let addCreds = Map.singleton 1 cred + -- Add a new credential to the sender increasing the threshold to 2. mbs1 <- bsoUpdateAccountCredentials mbs0 2 [] addCreds 2 freezeBlockState mbs1 (result, finalState) <- Helpers.runScheduler Helpers.defaultTestConfig keyChangeState transactions From 8cd951044eb22177a57dc1ad7062ccae7ce2ee76 Mon Sep 17 00:00:00 2001 From: Thomas Dinsdale-Young Date: Wed, 3 Dec 2025 16:51:54 +0100 Subject: [PATCH 26/26] Add haskell code coverage. --- .github/workflows/build-test.yaml | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/.github/workflows/build-test.yaml b/.github/workflows/build-test.yaml index 20ea47c249..d7b656309b 100644 --- a/.github/workflows/build-test.yaml +++ b/.github/workflows/build-test.yaml @@ -227,9 +227,14 @@ jobs: ${{ runner.os }}-${{ env.dummy }}-stack-work-${{ matrix.plan.ghc }} # Compile Haskell sources. This must be done before running checks or tests on the Rust sources. - - name: Build consensus and run tests + - name: Build consensus and run tests (with code coverage) run: | - stack build concordium-consensus --test --bench --force-dirty --no-run-benchmarks --ghc-options "-Werror" --ghc-options -j + stack build concordium-consensus --test --bench --force-dirty --no-run-benchmarks --ghc-options "-Werror" --ghc-options -j --coverage + + - name: Generate Haskell codecov report + run: | + stack install hpc-codecov + hpc-codecov stack:all -o codecov-haskell.json # RUST # @@ -284,3 +289,4 @@ jobs: fail_ci_if_error: false token: ${{ secrets.CODECOV_TOKEN }} verbose: true + files: lcov.info,codecov-haskell.json