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

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
 

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))

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

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

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

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

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)
  }
 

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', ())

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)

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)

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

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 =