From b57ab4eeec4b4e5ba68f23b4a5abbcde727cd068 Mon Sep 17 00:00:00 2001 From: Jared Corduan Date: Thu, 29 Oct 2020 16:53:56 -0400 Subject: [PATCH] fix ValueNotConservedUTxO serialization The ValueNotConservedUTxO predicate failure contains two values of type Coin (in the Shelley era, but Core.Value in general). Though the Coin values in the ledger state are always within the proper bounds (ie Word64), the failure could produce values outside of this range. This caused a serialization error for ValueNotConservedUTxO, since we do not allow the serialization of coins out of the Word64 range. For the Coin type, we already had a wrapper DeltaCoin which can be used when we want to intentionally serialize any Coin. This is now generalized to a Torsor type class, which ValueNotConservedUTxO now uses. Resolves: CAD-2168 --- .../impl/src/Cardano/Ledger/Mary/Value.hs | 7 +++++++ .../Cardano/Ledger/ShelleyMA/Rules/Utxow.hs | 4 ++++ .../executable-spec/shelley-spec-ledger.cabal | 1 + .../src/Cardano/Ledger/Shelley.hs | 4 ++++ .../src/Cardano/Ledger/Torsor.hs | 15 +++++++++++++++ .../src/Shelley/Spec/Ledger/Coin.hs | 18 ++++++++++++------ .../src/Shelley/Spec/Ledger/LedgerState.hs | 12 ++++++------ .../src/Shelley/Spec/Ledger/STS/NewEpoch.hs | 2 +- .../src/Shelley/Spec/Ledger/STS/Utxo.hs | 9 +++++---- .../Spec/Ledger/Serialisation/Generators.hs | 12 ++++++++++-- .../Spec/Ledger/Examples/PoolLifetime.hs | 6 +++--- .../test/Test/Shelley/Spec/Ledger/UnitTests.hs | 4 ++-- 12 files changed, 70 insertions(+), 24 deletions(-) create mode 100644 shelley/chain-and-ledger/executable-spec/src/Cardano/Ledger/Torsor.hs diff --git a/shelley-ma/impl/src/Cardano/Ledger/Mary/Value.hs b/shelley-ma/impl/src/Cardano/Ledger/Mary/Value.hs index fa27524822f..fdddd0d5946 100644 --- a/shelley-ma/impl/src/Cardano/Ledger/Mary/Value.hs +++ b/shelley-ma/impl/src/Cardano/Ledger/Mary/Value.hs @@ -29,6 +29,7 @@ import Cardano.Binary import Cardano.Ledger.Compactible (Compactible (..)) import qualified Cardano.Ledger.Core as Core import Cardano.Ledger.Era +import Cardano.Ledger.Torsor (Torsor (..)) import Cardano.Ledger.Val (Val (..)) import Control.DeepSeq (NFData (..)) import Data.ByteString (ByteString) @@ -170,6 +171,12 @@ instance Compactible (Value era) where toCompact = CompactValue fromCompact = getCompactValue +instance (Era era) => Torsor (Value era) where + -- TODO a proper torsor form + type Delta (Value era) = (Value era) + addDelta = (<+>) + toDelta = id + -- ======================================================================== -- Operations on Values diff --git a/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/Rules/Utxow.hs b/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/Rules/Utxow.hs index 91518ebcbfc..8a8c92db5db 100644 --- a/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/Rules/Utxow.hs +++ b/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/Rules/Utxow.hs @@ -20,6 +20,7 @@ import Cardano.Ledger.ShelleyMA (MaryOrAllegra, ShelleyMAEra) import Cardano.Ledger.ShelleyMA.Rules.Utxo () import Cardano.Ledger.ShelleyMA.Scripts () import Cardano.Ledger.ShelleyMA.TxBody () +import Cardano.Ledger.Torsor (Torsor (..)) import Cardano.Ledger.Val (Val) import Control.State.Transition.Extended import Data.Foldable (Foldable (toList)) @@ -122,8 +123,11 @@ instance Val (Core.Value (ShelleyMAEra ma c)), GetPolicies (Core.Value (ShelleyMAEra ma c)) (ShelleyMAEra ma c), Core.ChainData (Core.Value (ShelleyMAEra ma c)), + Core.ChainData (Delta (Core.Value (ShelleyMAEra ma c))), Core.SerialisableData (Core.Value (ShelleyMAEra ma c)), + Core.SerialisableData (Delta (Core.Value (ShelleyMAEra ma c))), Core.SerialisableData (CompactForm (Core.Value (ShelleyMAEra ma c))), + Torsor (Core.Value (ShelleyMAEra ma c)), DSignable c (Hash c EraIndependentTxBody) ) => STS (UTXOW (ShelleyMAEra ma c)) diff --git a/shelley/chain-and-ledger/executable-spec/shelley-spec-ledger.cabal b/shelley/chain-and-ledger/executable-spec/shelley-spec-ledger.cabal index 5cf19ae4a43..08b6b15f374 100644 --- a/shelley/chain-and-ledger/executable-spec/shelley-spec-ledger.cabal +++ b/shelley/chain-and-ledger/executable-spec/shelley-spec-ledger.cabal @@ -23,6 +23,7 @@ library Cardano.Ledger.Crypto Cardano.Ledger.Era Cardano.Ledger.Shelley + Cardano.Ledger.Torsor Cardano.Ledger.Val Shelley.Spec.Ledger.Address Shelley.Spec.Ledger.Address.Bootstrap diff --git a/shelley/chain-and-ledger/executable-spec/src/Cardano/Ledger/Shelley.hs b/shelley/chain-and-ledger/executable-spec/src/Cardano/Ledger/Shelley.hs index 5b062668d9e..f0409cd4a7f 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Cardano/Ledger/Shelley.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Cardano/Ledger/Shelley.hs @@ -10,6 +10,7 @@ import Cardano.Ledger.Compactible import Cardano.Ledger.Core import qualified Cardano.Ledger.Crypto as CryptoClass import Cardano.Ledger.Era +import Cardano.Ledger.Torsor (Torsor (..)) import Cardano.Ledger.Val (Val) import Shelley.Spec.Ledger.Coin (Coin) import Shelley.Spec.Ledger.Hashing (EraIndependentTxBody, HashAnnotated (..)) @@ -40,6 +41,9 @@ type ShelleyBased era = ChainData (Value era), SerialisableData (Value era), SerialisableData (CompactForm (Value era)), + ChainData (Delta (Value era)), + SerialisableData (Delta (Value era)), + Torsor (Value era), -- TxBody constraints TxBodyConstraints era, -- Script constraints diff --git a/shelley/chain-and-ledger/executable-spec/src/Cardano/Ledger/Torsor.hs b/shelley/chain-and-ledger/executable-spec/src/Cardano/Ledger/Torsor.hs new file mode 100644 index 00000000000..333cf74c063 --- /dev/null +++ b/shelley/chain-and-ledger/executable-spec/src/Cardano/Ledger/Torsor.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} + +module Cardano.Ledger.Torsor where + +import Data.Kind (Type) + +class Torsor a where + type Delta a :: Type + addDelta :: a -> Delta a -> a + toDelta :: a -> Delta a diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Coin.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Coin.hs index bd9180acbde..a5d56e1938c 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Coin.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Coin.hs @@ -12,13 +12,14 @@ module Shelley.Spec.Ledger.Coin word64ToCoin, coinToRational, rationalToCoinViaFloor, - addDelta, - toDelta, + addDeltaCoin, + toDeltaCoin, ) where import Cardano.Binary (FromCBOR (..), ToCBOR (..)) import Cardano.Ledger.Compactible +import qualified Cardano.Ledger.Torsor as Torsor import Control.DeepSeq (NFData) import Data.Aeson (FromJSON, ToJSON) import Data.Group (Abelian, Group (..)) @@ -52,11 +53,16 @@ newtype DeltaCoin = DeltaCoin Integer deriving (Semigroup, Monoid, Group, Abelian) via Sum Integer deriving newtype (PartialOrd) -addDelta :: Coin -> DeltaCoin -> Coin -addDelta (Coin x) (DeltaCoin y) = Coin (x + y) +addDeltaCoin :: Coin -> DeltaCoin -> Coin +addDeltaCoin (Coin x) (DeltaCoin y) = Coin (x + y) -toDelta :: Coin -> DeltaCoin -toDelta (Coin x) = DeltaCoin x +toDeltaCoin :: Coin -> DeltaCoin +toDeltaCoin (Coin x) = DeltaCoin x + +instance Torsor.Torsor Coin where + type Delta Coin = DeltaCoin + addDelta = addDeltaCoin + toDelta = toDeltaCoin word64ToCoin :: Word64 -> Coin word64ToCoin w = Coin $ fromIntegral w diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs index 7959eafe296..8a8b2c503e4 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs @@ -145,9 +145,9 @@ import Shelley.Spec.Ledger.BaseTypes import Shelley.Spec.Ledger.Coin ( Coin (..), DeltaCoin (..), - addDelta, + addDeltaCoin, rationalToCoinViaFloor, - toDelta, + toDeltaCoin, ) import Shelley.Spec.Ledger.Credential (Credential (..)) import Shelley.Spec.Ledger.Delegation.Certificates @@ -1026,12 +1026,12 @@ applyRUpd ru (EpochState as ss ls pr pp _nm) = EpochState as' ss ls' pr pp nm' as' = as { _treasury = _treasury as <> deltaT ru <> fold (range unregRU), - _reserves = addDelta (_reserves as) (deltaR ru) + _reserves = addDeltaCoin (_reserves as) (deltaR ru) } ls' = ls { _utxoState = - utxoState_ {_fees = _fees utxoState_ `addDelta` deltaF ru}, + utxoState_ {_fees = _fees utxoState_ `addDeltaCoin` deltaF ru}, _delegationState = delegState { _dstate = @@ -1113,9 +1113,9 @@ createRUpd slotsPerEpoch b@(BlocksMade b') es@(EpochState acnt ss ls pr _ nm) ma pure $ RewardUpdate { deltaT = (Coin deltaT1), - deltaR = ((invert $ toDelta deltaR1) <> toDelta deltaR2), + deltaR = ((invert $ toDeltaCoin deltaR1) <> toDeltaCoin deltaR2), rs = rs_, - deltaF = (invert (toDelta $ _feeSS ss)), + deltaF = (invert (toDeltaCoin $ _feeSS ss)), nonMyopic = (updateNonMypopic nm _R newLikelihoods) } diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/NewEpoch.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/NewEpoch.hs index d8535d9e919..b52916275ee 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/NewEpoch.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/NewEpoch.hs @@ -97,7 +97,7 @@ newEpochTransition = do SNothing -> pure es SJust ru' -> do let RewardUpdate dt dr rs_ df _ = ru' - Val.isZero (dt `addDelta` (dr <> (toDelta $ fold rs_) <> df)) ?! CorruptRewardUpdate ru' + Val.isZero (dt `addDeltaCoin` (dr <> (toDeltaCoin $ fold rs_) <> df)) ?! CorruptRewardUpdate ru' pure $ applyRUpd ru' es es'' <- trans @(MIR era) $ TRC ((), es', ()) diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Utxo.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Utxo.hs index 0b0bb68e736..984497779a8 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Utxo.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Utxo.hs @@ -31,6 +31,7 @@ import qualified Cardano.Ledger.Core as Core import qualified Cardano.Ledger.Crypto as CryptoClass import Cardano.Ledger.Era (Crypto) import Cardano.Ledger.Shelley (ShelleyBased, ShelleyEra) +import Cardano.Ledger.Torsor (Torsor (..)) import Cardano.Ledger.Val ((<->)) import qualified Cardano.Ledger.Val as Val import Control.Monad.Trans.Reader (asks) @@ -134,8 +135,8 @@ data UtxoPredicateFailure era !Coin -- the minimum fee for this transaction !Coin -- the fee supplied in this transaction | ValueNotConservedUTxO - !(Core.Value era) -- the Coin consumed by this transaction - !(Core.Value era) -- the Coin produced by this transaction + !(Delta (Core.Value era)) -- the Coin consumed by this transaction + !(Delta (Core.Value era)) -- the Coin produced by this transaction | WrongNetwork !Network -- the expected network id !(Set (Addr era)) -- the set of addresses with incorrect network IDs @@ -157,7 +158,7 @@ deriving stock instance ShelleyBased era => Eq (UtxoPredicateFailure era) -instance NoThunks (Core.Value era) => NoThunks (UtxoPredicateFailure era) +instance NoThunks (Delta (Core.Value era)) => NoThunks (UtxoPredicateFailure era) instance ShelleyBased era => @@ -341,7 +342,7 @@ utxoInductive = do let consumed_ = consumed pp utxo txb produced_ = produced pp stakepools txb - consumed_ == produced_ ?! ValueNotConservedUTxO consumed_ produced_ + consumed_ == produced_ ?! ValueNotConservedUTxO (toDelta consumed_) (toDelta produced_) -- process Protocol Parameter Update Proposals ppup' <- trans @(PPUP era) $ TRC (PPUPEnv slot pp genDelegs, ppup, txup tx) diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Serialisation/Generators.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Serialisation/Generators.hs index 09dd167adf7..b07024b8f2c 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Serialisation/Generators.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Serialisation/Generators.hs @@ -43,6 +43,7 @@ import qualified Cardano.Ledger.Crypto as CC (Crypto) import Cardano.Ledger.Era (Crypto, Era) import Cardano.Ledger.Shelley (ShelleyEra) import qualified Cardano.Ledger.Shelley as Shelley +import Cardano.Ledger.Torsor (Torsor (..)) import Cardano.Slotting.Block (BlockNo (..)) import Cardano.Slotting.Slot (EpochNo (..), EpochSize (..), SlotNo (..)) import Control.SetAlgebra (biMapFromList) @@ -77,6 +78,7 @@ import Shelley.Spec.Ledger.BaseTypes textToDns, textToUrl, ) +import Shelley.Spec.Ledger.Coin (DeltaCoin (..)) import Shelley.Spec.Ledger.Delegation.Certificates (IndividualPoolStake (..)) import Shelley.Spec.Ledger.EpochBoundary (BlocksMade (..)) import Shelley.Spec.Ledger.LedgerState @@ -382,11 +384,14 @@ instance Era era => Arbitrary (STS.PpupPredicateFailure era) where shrink = genericShrink instance - (ShelleyTest era, Mock (Crypto era), Arbitrary (Core.Value era)) => + ( ShelleyTest era, + Mock (Crypto era), + Arbitrary (Core.Value era), + Arbitrary (Delta (Core.Value era)) + ) => Arbitrary (STS.UtxoPredicateFailure era) where arbitrary = genericArbitraryU - -- we don't have a shrinker for Value, so we do not shrink this -- predicate failure, as its constructor contains Value shrink pf = [pf] @@ -456,6 +461,9 @@ instance Arbitrary Coin where -- Cannot be negative even though it is an 'Integer' arbitrary = Coin <$> choose (0, 1000) +instance Arbitrary DeltaCoin where + arbitrary = DeltaCoin <$> choose (-1000, 1000) + instance Arbitrary SlotNo where -- Cannot be negative even though it is an 'Integer' arbitrary = SlotNo <$> choose (1, 100000) diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Examples/PoolLifetime.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Examples/PoolLifetime.hs index 9e5e564f11b..60b5d7af263 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Examples/PoolLifetime.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Examples/PoolLifetime.hs @@ -38,7 +38,7 @@ import Shelley.Spec.Ledger.BlockChain bheader, hashHeaderToNonce, ) -import Shelley.Spec.Ledger.Coin (Coin (..), DeltaCoin (..), toDelta, addDelta) +import Shelley.Spec.Ledger.Coin (Coin (..), DeltaCoin (..), toDeltaCoin, addDeltaCoin) import Shelley.Spec.Ledger.Credential (Ptr (..)) import Shelley.Spec.Ledger.Delegation.Certificates ( IndividualPoolStake (..), @@ -568,7 +568,7 @@ rewardUpdateEx6 = { deltaT = Coin 1, deltaR = DeltaCoin 4, rs = Map.empty, - deltaF = invert $ toDelta feeTx4, + deltaF = invert $ toDeltaCoin feeTx4, nonMyopic = emptyNonMyopic {rewardPotNM = Coin 4} } @@ -884,7 +884,7 @@ blockEx11 = (mkOCert (coreNodeKeysBySchedule @era ppEx 490) 2 (KESPeriod 19)) reserves12 :: Coin -reserves12 = addDelta reserves7 deltaR8 +reserves12 = addDeltaCoin reserves7 deltaR8 alicePerfEx11 :: forall era. ShelleyTest era => Likelihood alicePerfEx11 = applyDecay decayFactor alicePerfEx8 <> epoch4Likelihood diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/UnitTests.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/UnitTests.hs index 632500b2056..3a7721681f3 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/UnitTests.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/UnitTests.hs @@ -404,7 +404,7 @@ testInvalidTx errs tx = testSpendNonexistentInput :: Assertion testSpendNonexistentInput = testInvalidTx - [ UtxowFailure (UtxoFailure (ValueNotConservedUTxO (Coin 0) (Coin 10000))), + [ UtxowFailure (UtxoFailure (ValueNotConservedUTxO (DeltaCoin 0) (DeltaCoin 10000))), UtxowFailure (UtxoFailure $ BadInputsUTxO (Set.singleton $ TxIn genesisId 42)) ] $ aliceGivesBobLovelace $ @@ -724,7 +724,7 @@ testProducedOverMaxWord64 = tx = Tx @C txbody wits SNothing st = runShelleyBase $ applySTSTest @(LEDGER C) (TRC (ledgerEnv, (utxoState, dpState), tx)) -- We test that the serialization of the predicate failure does not return bottom - in serialize' st @?= serialize' st + in serialize' st @?= serialize' st testsInvalidLedger :: TestTree testsInvalidLedger =