{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

module Cardano.Ledger.ShelleyMA.Rules.Utxo where

import Cardano.Binary (FromCBOR (..), ToCBOR (..), encodeListLen, serialize)
import Cardano.Ledger.Address (Addr)
import Cardano.Ledger.BaseTypes
  ( Network,
    ShelleyBase,
    StrictMaybe (..),
    networkId,
  )
import Cardano.Ledger.Coin
import qualified Cardano.Ledger.Core as Core
import qualified Cardano.Ledger.Crypto as CC
import Cardano.Ledger.Era (Era (..))
import Cardano.Ledger.Keys (KeyHash, KeyRole (..))
import Cardano.Ledger.Rules.ValidationMode
  ( Inject (..),
    InjectMaybe (..),
    Test,
    runTest,
  )
import Cardano.Ledger.Shelley.Constraints
  ( TransValue,
    UsesAuxiliary,
    UsesPParams,
    UsesScript,
    UsesTxBody,
    UsesTxOut,
    UsesValue,
  )
import Cardano.Ledger.Shelley.LedgerState (PPUPState)
import qualified Cardano.Ledger.Shelley.LedgerState as Shelley
import Cardano.Ledger.Shelley.PParams (PParams, PParams' (..), Update)
import Cardano.Ledger.Shelley.Rules.Ppup (PPUP, PPUPEnv (..), PpupPredicateFailure)
import qualified Cardano.Ledger.Shelley.Rules.Utxo as Shelley
import Cardano.Ledger.Shelley.Tx (Tx (..), TxIn, TxOut)
import Cardano.Ledger.Shelley.TxBody (DCert, RewardAcnt, Wdrl)
import Cardano.Ledger.Shelley.UTxO (UTxO (..), totalDeposits, txouts, txup)
import qualified Cardano.Ledger.Shelley.UTxO as Shelley
import Cardano.Ledger.ShelleyMA.Timelocks
import Cardano.Ledger.ShelleyMA.TxBody (TxBody)
import qualified Cardano.Ledger.Val as Val
import Cardano.Slotting.Slot (SlotNo)
import Control.Monad.Trans.Reader (asks)
import Control.State.Transition.Extended
import qualified Data.ByteString.Lazy as BSL (length)
import Data.Coders
  ( decodeList,
    decodeRecordSum,
    decodeSet,
    encodeFoldable,
    invalidKey,
  )
import Data.Foldable (toList)
import Data.Int (Int64)
import qualified Data.Map.Strict as Map
import Data.Sequence.Strict (StrictSeq)
import Data.Set (Set)
import Data.Typeable (Typeable)
import Data.Word (Word8)
import GHC.Generics (Generic)
import GHC.Records
import NoThunks.Class (NoThunks)
import Numeric.Natural (Natural)
import Validation

{- The scaledMinDeposit calculation uses the minUTxOValue protocol parameter
(passed to it as Coin mv) as a specification of "the cost of
making a Shelley-sized UTxO entry", calculated here by "utxoEntrySizeWithoutVal + uint",
using the constants in the "where" clause.
In the case when a UTxO entry contains coins only (and the Shelley
UTxO entry format is used - we will extend this to be correct for other
UTxO formats shortly), the deposit should be exactly the minUTxOValue.
This is the "inject (coin v) == v" case.
Otherwise, we calculate the per-byte deposit by multiplying the minimum deposit (which is
for the number of Shelley UTxO-entry bytes) by the size of a Shelley UTxO entry.
This is the "(mv * (utxoEntrySizeWithoutVal + uint))" calculation.
We then calculate the total deposit required for making a UTxO entry with a Val-class
member v by dividing "(mv * (utxoEntrySizeWithoutVal + uint))" by the
estimated total size of the UTxO entry containing v, ie by
"(utxoEntrySizeWithoutVal + size v)".
See the formal specification for details.
-}

-- This scaling function is right for UTxO, not EUTxO
--
scaledMinDeposit :: (Val.Val v) => v -> Coin -> Coin
scaledMinDeposit :: v -> Coin -> Coin
scaledMinDeposit v
v (Coin Integer
mv)
  | Coin -> v
forall t. Val t => Coin -> t
Val.inject (v -> Coin
forall t. Val t => t -> Coin
Val.coin v
v) v -> v -> Bool
forall a. Eq a => a -> a -> Bool
== v
v = Integer -> Coin
Coin Integer
mv -- without non-Coin assets, scaled deposit should be exactly minUTxOValue
  -- The calculation should represent this equation
  -- minValueParameter / coinUTxOSize = actualMinValue / valueUTxOSize
  -- actualMinValue = (minValueParameter / coinUTxOSize) * valueUTxOSize
  | Bool
otherwise = Integer -> Coin
Coin (Integer -> Coin) -> Integer -> Coin
forall a b. (a -> b) -> a -> b
$ Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
max Integer
mv (Integer
coinsPerUTxOWord Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* (Integer
utxoEntrySizeWithoutVal Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ v -> Integer
forall t. Val t => t -> Integer
Val.size v
v))
  where
    -- lengths obtained from tracing on HeapWords of inputs and outputs
    -- obtained experimentally, and number used here
    -- units are Word64s
    txoutLenNoVal :: Integer
txoutLenNoVal = Integer
14
    txinLen :: Integer
txinLen = Integer
7

    -- unpacked CompactCoin Word64 size in Word64s
    coinSize :: Integer
    coinSize :: Integer
coinSize = Integer
0

    utxoEntrySizeWithoutVal :: Integer
    utxoEntrySizeWithoutVal :: Integer
utxoEntrySizeWithoutVal = Integer
6 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
txoutLenNoVal Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
txinLen

    -- how much ada does a Word64 of UTxO space cost, calculated from minAdaValue PP
    -- round down
    coinsPerUTxOWord :: Integer
    coinsPerUTxOWord :: Integer
coinsPerUTxOWord = Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
quot Integer
mv (Integer
utxoEntrySizeWithoutVal Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
coinSize)

-- ==========================================================

data UtxoPredicateFailure era
  = BadInputsUTxO
      !(Set (TxIn (Crypto era))) -- The bad transaction inputs
  | OutsideValidityIntervalUTxO
      !ValidityInterval -- transaction's validity interval
      !SlotNo -- current slot
  | MaxTxSizeUTxO
      !Integer -- the actual transaction size
      !Integer -- the max transaction size
  | InputSetEmptyUTxO
  | FeeTooSmallUTxO
      !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
  | WrongNetwork
      !Network -- the expected network id
      !(Set (Addr (Crypto era))) -- the set of addresses with incorrect network IDs
  | WrongNetworkWithdrawal
      !Network -- the expected network id
      !(Set (RewardAcnt (Crypto era))) -- the set of reward addresses with incorrect network IDs
  | OutputTooSmallUTxO
      ![Core.TxOut era] -- list of supplied transaction outputs that are too small
  | UpdateFailure !(PredicateFailure (Core.EraRule "PPUP" era)) -- Subtransition Failures
  | OutputBootAddrAttrsTooBig
      ![Core.TxOut era] -- list of supplied bad transaction outputs
  | TriesToForgeADA
  | OutputTooBigUTxO
      ![Core.TxOut era] -- list of supplied bad transaction outputs
  deriving ((forall x.
 UtxoPredicateFailure era -> Rep (UtxoPredicateFailure era) x)
-> (forall x.
    Rep (UtxoPredicateFailure era) x -> UtxoPredicateFailure era)
-> Generic (UtxoPredicateFailure era)
forall x.
Rep (UtxoPredicateFailure era) x -> UtxoPredicateFailure era
forall x.
UtxoPredicateFailure era -> Rep (UtxoPredicateFailure era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x.
Rep (UtxoPredicateFailure era) x -> UtxoPredicateFailure era
forall era x.
UtxoPredicateFailure era -> Rep (UtxoPredicateFailure era) x
$cto :: forall era x.
Rep (UtxoPredicateFailure era) x -> UtxoPredicateFailure era
$cfrom :: forall era x.
UtxoPredicateFailure era -> Rep (UtxoPredicateFailure era) x
Generic)

deriving stock instance
  ( Show (Core.TxOut era),
    Show (Core.Value era),
    Show (Shelley.UTxOState era),
    Show (PredicateFailure (Core.EraRule "PPUP" era))
  ) =>
  Show (UtxoPredicateFailure era)

deriving stock instance
  ( Eq (Core.TxOut era),
    Eq (Core.Value era),
    Eq (Shelley.UTxOState era),
    Eq (PredicateFailure (Core.EraRule "PPUP" era))
  ) =>
  Eq (UtxoPredicateFailure era)

instance
  ( NoThunks (Core.TxOut era),
    NoThunks (Core.Value era),
    NoThunks (Shelley.UTxOState era),
    NoThunks (PredicateFailure (Core.EraRule "PPUP" era))
  ) =>
  NoThunks (UtxoPredicateFailure era)

newtype UtxoEvent era
  = UpdateEvent (Event (Core.EraRule "PPUP" era))

-- | Calculate the value consumed by the transation.
--
--   This differs from the corresponding Shelley function @Shelley.consumed@
--   since it also considers the "mint" field which creates or destroys non-Ada
--   tokens.
--
--   Note that this is slightly confusing, since it also covers non-Ada assets
--   _created_ by the transaction, depending on the sign of the quantities in
--   the mint field.
consumed ::
  forall era.
  ( Era era,
    HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))),
    HasField "inputs" (Core.TxBody era) (Set (TxIn (Crypto era))),
    HasField "mint" (Core.TxBody era) (Core.Value era),
    HasField "wdrls" (Core.TxBody era) (Wdrl (Crypto era)),
    HasField "_keyDeposit" (Core.PParams era) Coin
  ) =>
  Core.PParams era ->
  UTxO era ->
  Core.TxBody era ->
  Core.Value era
consumed :: PParams era -> UTxO era -> TxBody era -> Value era
consumed PParams era
pp UTxO era
u TxBody era
tx = PParams era -> UTxO era -> TxBody era -> Value era
forall era pp.
(Era era,
 HasField "certs" (TxBody era) (StrictSeq (DCert (Crypto era))),
 HasField "inputs" (TxBody era) (Set (TxIn (Crypto era))),
 HasField "wdrls" (TxBody era) (Wdrl (Crypto era)),
 HasField "_keyDeposit" pp Coin) =>
pp -> UTxO era -> TxBody era -> Value era
Shelley.consumed PParams era
pp UTxO era
u TxBody era
tx Value era -> Value era -> Value era
forall a. Semigroup a => a -> a -> a
<> TxBody era -> Value era
forall k (x :: k) r a. HasField x r a => r -> a
getField @"mint" TxBody era
tx

-- | The UTxO transition rule for the Shelley-MA (Mary and Allegra) eras.
utxoTransition ::
  forall era.
  ( UsesTxBody era,
    UsesValue era,
    STS (UTXO era),
    Core.Tx era ~ Tx era,
    Embed (Core.EraRule "PPUP" era) (UTXO era),
    Environment (Core.EraRule "PPUP" era) ~ PPUPEnv era,
    State (Core.EraRule "PPUP" era) ~ PPUPState era,
    Signal (Core.EraRule "PPUP" era) ~ Maybe (Update era),
    HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))),
    HasField "inputs" (Core.TxBody era) (Set (TxIn (Crypto era))),
    HasField "mint" (Core.TxBody era) (Core.Value era),
    HasField "wdrls" (Core.TxBody era) (Wdrl (Crypto era)),
    HasField "vldt" (Core.TxBody era) ValidityInterval,
    HasField "update" (Core.TxBody era) (StrictMaybe (Update era)),
    HasField "_minfeeA" (Core.PParams era) Natural,
    HasField "_minfeeB" (Core.PParams era) Natural,
    HasField "_keyDeposit" (Core.PParams era) Coin,
    HasField "_poolDeposit" (Core.PParams era) Coin,
    HasField "_minUTxOValue" (Core.PParams era) Coin,
    HasField "_maxTxSize" (Core.PParams era) Natural
  ) =>
  TransitionRule (UTXO era)
utxoTransition :: TransitionRule (UTXO era)
utxoTransition = do
  TRC (Shelley.UtxoEnv slot pp stakepools genDelegs, State (UTXO era)
u, Signal (UTXO era)
tx) <- F (Clause (UTXO era) 'Transition) (TRC (UTXO era))
forall sts (rtype :: RuleType).
Rule sts rtype (RuleContext rtype sts)
judgmentContext
  let Shelley.UTxOState UTxO era
utxo Coin
_ Coin
_ State (EraRule "PPUP" era)
ppup IncrementalStake (Crypto era)
_ = UTxOState era
State (UTXO era)
u
  let txb :: TxBody era
txb = Tx era -> TxBody era
forall k (x :: k) r a. HasField x r a => r -> a
getField @"body" Tx era
Signal (UTXO era)
tx

  {- ininterval slot (txvld tx) -}
  Test (UtxoPredicateFailure era) -> Rule (UTXO era) 'Transition ()
forall t sts (ctx :: RuleType).
Inject t (PredicateFailure sts) =>
Test t -> Rule sts ctx ()
runTest (Test (UtxoPredicateFailure era) -> Rule (UTXO era) 'Transition ())
-> Test (UtxoPredicateFailure era)
-> Rule (UTXO era) 'Transition ()
forall a b. (a -> b) -> a -> b
$ SlotNo -> TxBody era -> Test (UtxoPredicateFailure era)
forall era.
HasField "vldt" (TxBody era) ValidityInterval =>
SlotNo -> TxBody era -> Test (UtxoPredicateFailure era)
validateOutsideValidityIntervalUTxO SlotNo
slot TxBody era
txb

  {- txins txb ≠ ∅ -}
  -- runValidationTransMaybe fromShelleyFailure $ Shelley.validateInputSetEmptyUTxO txb
  Test (UtxoPredicateFailure era) -> Rule (UTXO era) 'Transition ()
forall t sts (ctx :: RuleType).
Inject t (PredicateFailure sts) =>
Test t -> Rule sts ctx ()
runTest (Test (UtxoPredicateFailure era) -> Rule (UTXO era) 'Transition ())
-> Test (UtxoPredicateFailure era)
-> Rule (UTXO era) 'Transition ()
forall a b. (a -> b) -> a -> b
$ TxBody era -> Test (UtxoPredicateFailure era)
forall era.
HasField "inputs" (TxBody era) (Set (TxIn (Crypto era))) =>
TxBody era -> Test (UtxoPredicateFailure era)
Shelley.validateInputSetEmptyUTxO TxBody era
txb

  {- minfee pp tx ≤ txfee txb -}
  Test (UtxoPredicateFailure era) -> Rule (UTXO era) 'Transition ()
forall t sts (ctx :: RuleType).
Inject t (PredicateFailure sts) =>
Test t -> Rule sts ctx ()
runTest (Test (UtxoPredicateFailure era) -> Rule (UTXO era) 'Transition ())
-> Test (UtxoPredicateFailure era)
-> Rule (UTXO era) 'Transition ()
forall a b. (a -> b) -> a -> b
$ PParams era -> Tx era -> Test (UtxoPredicateFailure era)
forall era.
(HasField "body" (Tx era) (TxBody era),
 HasField "txfee" (TxBody era) Coin,
 HasField "_minfeeA" (PParams era) Natural,
 HasField "_minfeeB" (PParams era) Natural,
 HasField "txsize" (Tx era) Integer) =>
PParams era -> Tx era -> Test (UtxoPredicateFailure era)
Shelley.validateFeeTooSmallUTxO PParams era
pp Tx era
Signal (UTXO era)
tx

  {- txins txb ⊆ dom utxo -}
  Test (UtxoPredicateFailure era) -> Rule (UTXO era) 'Transition ()
forall t sts (ctx :: RuleType).
Inject t (PredicateFailure sts) =>
Test t -> Rule sts ctx ()
runTest (Test (UtxoPredicateFailure era) -> Rule (UTXO era) 'Transition ())
-> Test (UtxoPredicateFailure era)
-> Rule (UTXO era) 'Transition ()
forall a b. (a -> b) -> a -> b
$ UTxO era
-> Set (TxIn (Crypto era)) -> Test (UtxoPredicateFailure era)
forall era.
UTxO era
-> Set (TxIn (Crypto era)) -> Test (UtxoPredicateFailure era)
Shelley.validateBadInputsUTxO UTxO era
utxo (Set (TxIn (Crypto era)) -> Test (UtxoPredicateFailure era))
-> Set (TxIn (Crypto era)) -> Test (UtxoPredicateFailure era)
forall a b. (a -> b) -> a -> b
$ TxBody era -> Set (TxIn (Crypto era))
forall k (x :: k) r a. HasField x r a => r -> a
getField @"inputs" TxBody era
txb

  Network
netId <- BaseM (UTXO era) Network -> Rule (UTXO era) 'Transition Network
forall sts a (ctx :: RuleType).
STS sts =>
BaseM sts a -> Rule sts ctx a
liftSTS (BaseM (UTXO era) Network -> Rule (UTXO era) 'Transition Network)
-> BaseM (UTXO era) Network -> Rule (UTXO era) 'Transition Network
forall a b. (a -> b) -> a -> b
$ (Globals -> Network) -> ReaderT Globals Identity Network
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Globals -> Network
networkId

  {- ∀(_ → (a, _)) ∈ txouts txb, netId a = NetworkId -}
  Test (UtxoPredicateFailure era) -> Rule (UTXO era) 'Transition ()
forall t sts (ctx :: RuleType).
Inject t (PredicateFailure sts) =>
Test t -> Rule sts ctx ()
runTest (Test (UtxoPredicateFailure era) -> Rule (UTXO era) 'Transition ())
-> Test (UtxoPredicateFailure era)
-> Rule (UTXO era) 'Transition ()
forall a b. (a -> b) -> a -> b
$ Network -> [TxOut era] -> Test (UtxoPredicateFailure era)
forall era.
Era era =>
Network -> [TxOut era] -> Test (UtxoPredicateFailure era)
Shelley.validateWrongNetwork Network
netId ([TxOut era] -> Test (UtxoPredicateFailure era))
-> (StrictSeq (TxOut era) -> [TxOut era])
-> StrictSeq (TxOut era)
-> Test (UtxoPredicateFailure era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrictSeq (TxOut era) -> [TxOut era]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (StrictSeq (TxOut era) -> Test (UtxoPredicateFailure era))
-> StrictSeq (TxOut era) -> Test (UtxoPredicateFailure era)
forall a b. (a -> b) -> a -> b
$ TxBody era -> StrictSeq (TxOut era)
forall k (x :: k) r a. HasField x r a => r -> a
getField @"outputs" TxBody era
txb

  {- ∀(a → ) ∈ txwdrls txb, netId a = NetworkId -}
  Test (UtxoPredicateFailure era) -> Rule (UTXO era) 'Transition ()
forall t sts (ctx :: RuleType).
Inject t (PredicateFailure sts) =>
Test t -> Rule sts ctx ()
runTest (Test (UtxoPredicateFailure era) -> Rule (UTXO era) 'Transition ())
-> Test (UtxoPredicateFailure era)
-> Rule (UTXO era) 'Transition ()
forall a b. (a -> b) -> a -> b
$ Network -> TxBody era -> Test (UtxoPredicateFailure era)
forall era.
HasField "wdrls" (TxBody era) (Wdrl (Crypto era)) =>
Network -> TxBody era -> Test (UtxoPredicateFailure era)
Shelley.validateWrongNetworkWithdrawal Network
netId TxBody era
txb

  {- consumed pp utxo txb = produced pp poolParams txb -}
  Test (UtxoPredicateFailure era) -> Rule (UTXO era) 'Transition ()
forall t sts (ctx :: RuleType).
Inject t (PredicateFailure sts) =>
Test t -> Rule sts ctx ()
runTest (Test (UtxoPredicateFailure era) -> Rule (UTXO era) 'Transition ())
-> Test (UtxoPredicateFailure era)
-> Rule (UTXO era) 'Transition ()
forall a b. (a -> b) -> a -> b
$ PParams era
-> UTxO era
-> Map (KeyHash 'StakePool (Crypto era)) (PoolParams (Crypto era))
-> TxBody era
-> Test (UtxoPredicateFailure era)
forall era a.
(Era era, HasField "_keyDeposit" (PParams era) Coin,
 HasField "_poolDeposit" (PParams era) Coin,
 HasField "certs" (TxBody era) (StrictSeq (DCert (Crypto era))),
 HasField "inputs" (TxBody era) (Set (TxIn (Crypto era))),
 HasField "wdrls" (TxBody era) (Wdrl (Crypto era)),
 HasField "mint" (TxBody era) (Value era)) =>
PParams era
-> UTxO era
-> Map (KeyHash 'StakePool (Crypto era)) a
-> TxBody era
-> Test (UtxoPredicateFailure era)
validateValueNotConservedUTxO PParams era
pp UTxO era
utxo Map (KeyHash 'StakePool (Crypto era)) (PoolParams (Crypto era))
stakepools TxBody era
txb

  -- process Protocol Parameter Update Proposals
  PPUPState era
ppup' <-
    forall sub super (rtype :: RuleType).
Embed sub super =>
RuleContext rtype sub -> Rule super rtype (State sub)
forall super (rtype :: RuleType).
Embed (EraRule "PPUP" era) super =>
RuleContext rtype (EraRule "PPUP" era)
-> Rule super rtype (State (EraRule "PPUP" era))
trans @(Core.EraRule "PPUP" era) (RuleContext 'Transition (EraRule "PPUP" era)
 -> Rule (UTXO era) 'Transition (State (EraRule "PPUP" era)))
-> RuleContext 'Transition (EraRule "PPUP" era)
-> Rule (UTXO era) 'Transition (State (EraRule "PPUP" era))
forall a b. (a -> b) -> a -> b
$ (Environment (EraRule "PPUP" era), State (EraRule "PPUP" era),
 Signal (EraRule "PPUP" era))
-> TRC (EraRule "PPUP" era)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (SlotNo -> PParams era -> GenDelegs (Crypto era) -> PPUPEnv era
forall era.
SlotNo -> PParams era -> GenDelegs (Crypto era) -> PPUPEnv era
PPUPEnv SlotNo
slot PParams era
pp GenDelegs (Crypto era)
genDelegs, State (EraRule "PPUP" era)
ppup, Tx era -> Maybe (Update era)
forall era tx.
(HasField "update" (TxBody era) (StrictMaybe (Update era)),
 HasField "body" tx (TxBody era)) =>
tx -> Maybe (Update era)
txup Tx era
Signal (UTXO era)
tx)

  Test (UtxoPredicateFailure era) -> Rule (UTXO era) 'Transition ()
forall t sts (ctx :: RuleType).
Inject t (PredicateFailure sts) =>
Test t -> Rule sts ctx ()
runTest (Test (UtxoPredicateFailure era) -> Rule (UTXO era) 'Transition ())
-> Test (UtxoPredicateFailure era)
-> Rule (UTXO era) 'Transition ()
forall a b. (a -> b) -> a -> b
$ TxBody era -> Test (UtxoPredicateFailure era)
forall era.
(Val (Value era), HasField "mint" (TxBody era) (Value era)) =>
TxBody era -> Test (UtxoPredicateFailure era)
validateTriesToForgeADA TxBody era
txb

  let outputs :: UTxO era
outputs = TxBody era -> UTxO era
forall era. Era era => TxBody era -> UTxO era
txouts TxBody era
txb
  {- ∀ txout ∈ txouts txb, getValue txout ≥ inject (scaledMinDeposit v (minUTxOValue pp)) -}
  Test (UtxoPredicateFailure era) -> Rule (UTXO era) 'Transition ()
forall t sts (ctx :: RuleType).
Inject t (PredicateFailure sts) =>
Test t -> Rule sts ctx ()
runTest (Test (UtxoPredicateFailure era) -> Rule (UTXO era) 'Transition ())
-> Test (UtxoPredicateFailure era)
-> Rule (UTXO era) 'Transition ()
forall a b. (a -> b) -> a -> b
$ PParams era -> UTxO era -> Test (UtxoPredicateFailure era)
forall era.
(HasField "_minUTxOValue" (PParams era) Coin,
 HasField "value" (TxOut era) (Value era), Val (Value era)) =>
PParams era -> UTxO era -> Test (UtxoPredicateFailure era)
validateOutputTooSmallUTxO PParams era
pp UTxO era
outputs

  {- ∀ txout ∈ txouts txb, serSize (getValue txout) ≤ MaxValSize -}
  -- MaxValSize = 4000
  Test (UtxoPredicateFailure era) -> Rule (UTXO era) 'Transition ()
forall t sts (ctx :: RuleType).
Inject t (PredicateFailure sts) =>
Test t -> Rule sts ctx ()
runTest (Test (UtxoPredicateFailure era) -> Rule (UTXO era) 'Transition ())
-> Test (UtxoPredicateFailure era)
-> Rule (UTXO era) 'Transition ()
forall a b. (a -> b) -> a -> b
$ UTxO era -> Test (UtxoPredicateFailure era)
forall era.
(HasField "value" (TxOut era) (Value era), ToCBOR (Value era)) =>
UTxO era -> Test (UtxoPredicateFailure era)
validateOutputTooBigUTxO UTxO era
outputs

  {- ∀ ( _ ↦ (a,_)) ∈ txoutstxb,  a ∈ Addrbootstrap → bootstrapAttrsSize a ≤ 64 -}
  Test (UtxoPredicateFailure era) -> Rule (UTXO era) 'Transition ()
forall t sts (ctx :: RuleType).
Inject t (PredicateFailure sts) =>
Test t -> Rule sts ctx ()
runTest (Test (UtxoPredicateFailure era) -> Rule (UTXO era) 'Transition ())
-> Test (UtxoPredicateFailure era)
-> Rule (UTXO era) 'Transition ()
forall a b. (a -> b) -> a -> b
$ UTxO era -> Test (UtxoPredicateFailure era)
forall era. Era era => UTxO era -> Test (UtxoPredicateFailure era)
Shelley.validateOutputBootAddrAttrsTooBig UTxO era
outputs

  {- txsize tx ≤ maxTxSize pp -}
  Test (UtxoPredicateFailure era) -> Rule (UTXO era) 'Transition ()
forall t sts (ctx :: RuleType).
Inject t (PredicateFailure sts) =>
Test t -> Rule sts ctx ()
runTest (Test (UtxoPredicateFailure era) -> Rule (UTXO era) 'Transition ())
-> Test (UtxoPredicateFailure era)
-> Rule (UTXO era) 'Transition ()
forall a b. (a -> b) -> a -> b
$ PParams era -> Tx era -> Test (UtxoPredicateFailure era)
forall era.
(HasField "_maxTxSize" (PParams era) Natural,
 HasField "txsize" (Tx era) Integer) =>
PParams era -> Tx era -> Test (UtxoPredicateFailure era)
Shelley.validateMaxTxSizeUTxO PParams era
pp Tx era
Signal (UTXO era)
tx

  let refunded :: Coin
refunded = PParams era -> TxBody era -> Coin
forall txb crypto pp.
(HasField "certs" txb (StrictSeq (DCert crypto)),
 HasField "_keyDeposit" pp Coin) =>
pp -> txb -> Coin
Shelley.keyRefunds PParams era
pp TxBody era
txb
  let txCerts :: [DCert (Crypto era)]
txCerts = StrictSeq (DCert (Crypto era)) -> [DCert (Crypto era)]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (StrictSeq (DCert (Crypto era)) -> [DCert (Crypto era)])
-> StrictSeq (DCert (Crypto era)) -> [DCert (Crypto era)]
forall a b. (a -> b) -> a -> b
$ TxBody era -> StrictSeq (DCert (Crypto era))
forall k (x :: k) r a. HasField x r a => r -> a
getField @"certs" TxBody era
txb
  let depositChange :: Coin
depositChange = PParams era
-> (KeyHash 'StakePool (Crypto era) -> Bool)
-> [DCert (Crypto era)]
-> Coin
forall pp crypto.
(HasField "_poolDeposit" pp Coin,
 HasField "_keyDeposit" pp Coin) =>
pp -> (KeyHash 'StakePool crypto -> Bool) -> [DCert crypto] -> Coin
totalDeposits PParams era
pp (KeyHash 'StakePool (Crypto era)
-> Map (KeyHash 'StakePool (Crypto era)) (PoolParams (Crypto era))
-> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.notMember` Map (KeyHash 'StakePool (Crypto era)) (PoolParams (Crypto era))
stakepools) [DCert (Crypto era)]
txCerts Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
Val.<-> Coin
refunded
  UTxOState era -> F (Clause (UTXO era) 'Transition) (UTxOState era)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UTxOState era
 -> F (Clause (UTXO era) 'Transition) (UTxOState era))
-> UTxOState era
-> F (Clause (UTXO era) 'Transition) (UTxOState era)
forall a b. (a -> b) -> a -> b
$! UTxOState era
-> TxBody era
-> Coin
-> State (EraRule "PPUP" era)
-> UTxOState era
forall era.
(Era era,
 HasField "inputs" (TxBody era) (Set (TxIn (Crypto era)))) =>
UTxOState era
-> TxBody era
-> Coin
-> State (EraRule "PPUP" era)
-> UTxOState era
Shelley.updateUTxOState UTxOState era
State (UTXO era)
u TxBody era
txb Coin
depositChange PPUPState era
State (EraRule "PPUP" era)
ppup'

-- | Ensure the transaction is within the validity window.
--
-- > ininterval slot (txvld tx)
validateOutsideValidityIntervalUTxO ::
  HasField "vldt" (Core.TxBody era) ValidityInterval =>
  SlotNo ->
  Core.TxBody era ->
  Test (UtxoPredicateFailure era)
validateOutsideValidityIntervalUTxO :: SlotNo -> TxBody era -> Test (UtxoPredicateFailure era)
validateOutsideValidityIntervalUTxO SlotNo
slot TxBody era
txb =
  Bool -> UtxoPredicateFailure era -> Test (UtxoPredicateFailure era)
forall e. Bool -> e -> Validation (NonEmpty e) ()
failureUnless (SlotNo -> ValidityInterval -> Bool
inInterval SlotNo
slot (TxBody era -> ValidityInterval
txvldt TxBody era
txb)) (UtxoPredicateFailure era -> Test (UtxoPredicateFailure era))
-> UtxoPredicateFailure era -> Test (UtxoPredicateFailure era)
forall a b. (a -> b) -> a -> b
$
    ValidityInterval -> SlotNo -> UtxoPredicateFailure era
forall era. ValidityInterval -> SlotNo -> UtxoPredicateFailure era
OutsideValidityIntervalUTxO (TxBody era -> ValidityInterval
txvldt TxBody era
txb) SlotNo
slot
  where
    txvldt :: TxBody era -> ValidityInterval
txvldt = forall k (x :: k) r a. HasField x r a => r -> a
forall r a. HasField "vldt" r a => r -> a
getField @"vldt"

-- | Check that the mint field does not try to mint ADA. This is equivalent to
-- the check:
--
-- > adaPolicy ∉ supp mint tx
validateTriesToForgeADA ::
  (Val.Val (Core.Value era), HasField "mint" (Core.TxBody era) (Core.Value era)) =>
  Core.TxBody era ->
  Test (UtxoPredicateFailure era)
validateTriesToForgeADA :: TxBody era -> Test (UtxoPredicateFailure era)
validateTriesToForgeADA TxBody era
txb =
  Bool -> UtxoPredicateFailure era -> Test (UtxoPredicateFailure era)
forall e. Bool -> e -> Validation (NonEmpty e) ()
failureUnless (Value era -> Coin
forall t. Val t => t -> Coin
Val.coin (TxBody era -> Value era
forall k (x :: k) r a. HasField x r a => r -> a
getField @"mint" TxBody era
txb) Coin -> Coin -> Bool
forall a. Eq a => a -> a -> Bool
== Coin
forall t. Val t => t
Val.zero) UtxoPredicateFailure era
forall era. UtxoPredicateFailure era
TriesToForgeADA

-- | Ensure that there are no `Core.TxOut`s that have `Value` of size larger than @MaxValSize@
--
-- > ∀ txout ∈ txouts txb, serSize (getValue txout) ≤ MaxValSize
validateOutputTooBigUTxO ::
  ( HasField "value" (Core.TxOut era) (Core.Value era),
    ToCBOR (Core.Value era)
  ) =>
  UTxO era ->
  Test (UtxoPredicateFailure era)
validateOutputTooBigUTxO :: UTxO era -> Test (UtxoPredicateFailure era)
validateOutputTooBigUTxO (UTxO Map (TxIn (Crypto era)) (TxOut era)
outputs) =
  Bool -> UtxoPredicateFailure era -> Test (UtxoPredicateFailure era)
forall e. Bool -> e -> Validation (NonEmpty e) ()
failureUnless ([TxOut era] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TxOut era]
outputsTooBig) (UtxoPredicateFailure era -> Test (UtxoPredicateFailure era))
-> UtxoPredicateFailure era -> Test (UtxoPredicateFailure era)
forall a b. (a -> b) -> a -> b
$ [TxOut era] -> UtxoPredicateFailure era
forall era. [TxOut era] -> UtxoPredicateFailure era
OutputTooBigUTxO [TxOut era]
outputsTooBig
  where
    maxValSize :: Int64
maxValSize = Int64
4000 :: Int64
    outputsTooBig :: [TxOut era]
outputsTooBig =
      (TxOut era -> Bool) -> [TxOut era] -> [TxOut era]
forall a. (a -> Bool) -> [a] -> [a]
filter
        ( \TxOut era
out ->
            let v :: Value era
v = TxOut era -> Value era
forall k (x :: k) r a. HasField x r a => r -> a
getField @"value" TxOut era
out
             in ByteString -> Int64
BSL.length (Value era -> ByteString
forall a. ToCBOR a => a -> ByteString
serialize Value era
v) Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
> Int64
maxValSize
        )
        (Map (TxIn (Crypto era)) (TxOut era) -> [TxOut era]
forall k a. Map k a -> [a]
Map.elems Map (TxIn (Crypto era)) (TxOut era)
outputs)

-- | Ensure that there are no `Core.TxOut`s that have value less than the scaled @minUTxOValue@
--
-- > ∀ txout ∈ txouts txb, getValue txout ≥ inject (scaledMinDeposit v (minUTxOValue pp))
validateOutputTooSmallUTxO ::
  ( HasField "_minUTxOValue" (Core.PParams era) Coin,
    HasField "value" (Core.TxOut era) (Core.Value era),
    Val.Val (Core.Value era)
  ) =>
  Core.PParams era ->
  UTxO era ->
  Test (UtxoPredicateFailure era)
validateOutputTooSmallUTxO :: PParams era -> UTxO era -> Test (UtxoPredicateFailure era)
validateOutputTooSmallUTxO PParams era
pp (UTxO Map (TxIn (Crypto era)) (TxOut era)
outputs) =
  Bool -> UtxoPredicateFailure era -> Test (UtxoPredicateFailure era)
forall e. Bool -> e -> Validation (NonEmpty e) ()
failureUnless ([TxOut era] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TxOut era]
outputsTooSmall) (UtxoPredicateFailure era -> Test (UtxoPredicateFailure era))
-> UtxoPredicateFailure era -> Test (UtxoPredicateFailure era)
forall a b. (a -> b) -> a -> b
$ [TxOut era] -> UtxoPredicateFailure era
forall era. [TxOut era] -> UtxoPredicateFailure era
OutputTooSmallUTxO [TxOut era]
outputsTooSmall
  where
    minUTxOValue :: Coin
minUTxOValue = PParams era -> Coin
forall k (x :: k) r a. HasField x r a => r -> a
getField @"_minUTxOValue" PParams era
pp
    outputsTooSmall :: [TxOut era]
outputsTooSmall =
      (TxOut era -> Bool) -> [TxOut era] -> [TxOut era]
forall a. (a -> Bool) -> [a] -> [a]
filter
        ( \TxOut era
out ->
            let v :: Value era
v = TxOut era -> Value era
forall k (x :: k) r a. HasField x r a => r -> a
getField @"value" TxOut era
out
             in (Integer -> Integer -> Bool) -> Value era -> Value era -> Bool
forall t. Val t => (Integer -> Integer -> Bool) -> t -> t -> Bool
Val.pointwise Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
(<) Value era
v (Coin -> Value era
forall t. Val t => Coin -> t
Val.inject (Coin -> Value era) -> Coin -> Value era
forall a b. (a -> b) -> a -> b
$ Value era -> Coin -> Coin
forall v. Val v => v -> Coin -> Coin
scaledMinDeposit Value era
v Coin
minUTxOValue)
        )
        (Map (TxIn (Crypto era)) (TxOut era) -> [TxOut era]
forall k a. Map k a -> [a]
Map.elems Map (TxIn (Crypto era)) (TxOut era)
outputs)

-- | Ensure that value consumed and produced matches up exactly. Note that this
-- is different from Shelley, since implementation of `consumed` has changed.
--
-- > consumed pp utxo txb = produced pp poolParams txb
validateValueNotConservedUTxO ::
  ( Era era,
    HasField "_keyDeposit" (Core.PParams era) Coin,
    HasField "_poolDeposit" (Core.PParams era) Coin,
    HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))),
    HasField "inputs" (Core.TxBody era) (Set (TxIn (Crypto era))),
    HasField "wdrls" (Core.TxBody era) (Wdrl (Crypto era)),
    HasField "mint" (Core.TxBody era) (Core.Value era)
  ) =>
  Core.PParams era ->
  UTxO era ->
  Map.Map (KeyHash 'StakePool (Crypto era)) a ->
  Core.TxBody era ->
  Test (UtxoPredicateFailure era)
validateValueNotConservedUTxO :: PParams era
-> UTxO era
-> Map (KeyHash 'StakePool (Crypto era)) a
-> TxBody era
-> Test (UtxoPredicateFailure era)
validateValueNotConservedUTxO PParams era
pp UTxO era
utxo Map (KeyHash 'StakePool (Crypto era)) a
stakepools TxBody era
txb =
  Bool -> UtxoPredicateFailure era -> Test (UtxoPredicateFailure era)
forall e. Bool -> e -> Validation (NonEmpty e) ()
failureUnless (Value era
consumedValue Value era -> Value era -> Bool
forall a. Eq a => a -> a -> Bool
== Value era
producedValue) (UtxoPredicateFailure era -> Test (UtxoPredicateFailure era))
-> UtxoPredicateFailure era -> Test (UtxoPredicateFailure era)
forall a b. (a -> b) -> a -> b
$
    Value era -> Value era -> UtxoPredicateFailure era
forall era. Value era -> Value era -> UtxoPredicateFailure era
ValueNotConservedUTxO Value era
consumedValue Value era
producedValue
  where
    consumedValue :: Value era
consumedValue = PParams era -> UTxO era -> TxBody era -> Value era
forall era.
(Era era,
 HasField "certs" (TxBody era) (StrictSeq (DCert (Crypto era))),
 HasField "inputs" (TxBody era) (Set (TxIn (Crypto era))),
 HasField "mint" (TxBody era) (Value era),
 HasField "wdrls" (TxBody era) (Wdrl (Crypto era)),
 HasField "_keyDeposit" (PParams era) Coin) =>
PParams era -> UTxO era -> TxBody era -> Value era
consumed PParams era
pp UTxO era
utxo TxBody era
txb
    producedValue :: Value era
producedValue = PParams era
-> (KeyHash 'StakePool (Crypto era) -> Bool)
-> TxBody era
-> Value era
forall era pp.
(Era era,
 HasField "certs" (TxBody era) (StrictSeq (DCert (Crypto era))),
 HasField "_keyDeposit" pp Coin, HasField "_poolDeposit" pp Coin) =>
pp
-> (KeyHash 'StakePool (Crypto era) -> Bool)
-> TxBody era
-> Value era
Shelley.produced PParams era
pp (KeyHash 'StakePool (Crypto era)
-> Map (KeyHash 'StakePool (Crypto era)) a -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.notMember` Map (KeyHash 'StakePool (Crypto era)) a
stakepools) TxBody era
txb

--------------------------------------------------------------------------------
-- UTXO STS
--------------------------------------------------------------------------------
data UTXO era

instance
  forall era.
  ( Era era,
    UsesAuxiliary era,
    UsesScript era,
    UsesTxOut era,
    UsesValue era,
    UsesPParams era,
    TransValue ToCBOR era,
    Core.PParams era ~ PParams era,
    Core.TxBody era ~ TxBody era,
    Core.TxOut era ~ TxOut era,
    Core.Tx era ~ Tx era,
    Embed (Core.EraRule "PPUP" era) (UTXO era),
    Environment (Core.EraRule "PPUP" era) ~ PPUPEnv era,
    State (Core.EraRule "PPUP" era) ~ PPUPState era,
    Signal (Core.EraRule "PPUP" era) ~ Maybe (Update era)
  ) =>
  STS (UTXO era)
  where
  type State (UTXO era) = Shelley.UTxOState era
  type Signal (UTXO era) = Tx era
  type Environment (UTXO era) = Shelley.UtxoEnv era
  type BaseM (UTXO era) = ShelleyBase
  type PredicateFailure (UTXO era) = UtxoPredicateFailure era
  type Event (UTXO era) = UtxoEvent era

  initialRules :: [InitialRule (UTXO era)]
initialRules = []
  transitionRules :: [TransitionRule (UTXO era)]
transitionRules = [TransitionRule (UTXO era)
forall era.
(UsesTxBody era, UsesValue era, STS (UTXO era), Tx era ~ Tx era,
 Embed (EraRule "PPUP" era) (UTXO era),
 Environment (EraRule "PPUP" era) ~ PPUPEnv era,
 State (EraRule "PPUP" era) ~ PPUPState era,
 Signal (EraRule "PPUP" era) ~ Maybe (Update era),
 HasField "certs" (TxBody era) (StrictSeq (DCert (Crypto era))),
 HasField "inputs" (TxBody era) (Set (TxIn (Crypto era))),
 HasField "mint" (TxBody era) (Value era),
 HasField "wdrls" (TxBody era) (Wdrl (Crypto era)),
 HasField "vldt" (TxBody era) ValidityInterval,
 HasField "update" (TxBody era) (StrictMaybe (Update era)),
 HasField "_minfeeA" (PParams era) Natural,
 HasField "_minfeeB" (PParams era) Natural,
 HasField "_keyDeposit" (PParams era) Coin,
 HasField "_poolDeposit" (PParams era) Coin,
 HasField "_minUTxOValue" (PParams era) Coin,
 HasField "_maxTxSize" (PParams era) Natural) =>
TransitionRule (UTXO era)
utxoTransition]

instance
  ( Era era,
    STS (PPUP era),
    PredicateFailure (Core.EraRule "PPUP" era) ~ PpupPredicateFailure era,
    Event (Core.EraRule "PPUP" era) ~ Event (PPUP era)
  ) =>
  Embed (PPUP era) (UTXO era)
  where
  wrapFailed :: PredicateFailure (PPUP era) -> PredicateFailure (UTXO era)
wrapFailed = PredicateFailure (PPUP era) -> PredicateFailure (UTXO era)
forall era.
PredicateFailure (EraRule "PPUP" era) -> UtxoPredicateFailure era
UpdateFailure
  wrapEvent :: Event (PPUP era) -> Event (UTXO era)
wrapEvent = Event (PPUP era) -> Event (UTXO era)
forall era. Event (EraRule "PPUP" era) -> UtxoEvent era
UpdateEvent

--------------------------------------------------------------------------------
-- Serialisation
--------------------------------------------------------------------------------
instance
  ( Typeable era,
    CC.Crypto (Crypto era),
    ToCBOR (Core.Value era),
    ToCBOR (Core.TxOut era),
    ToCBOR (Shelley.UTxOState era),
    ToCBOR (PredicateFailure (Core.EraRule "PPUP" era))
  ) =>
  ToCBOR (UtxoPredicateFailure era)
  where
  toCBOR :: UtxoPredicateFailure era -> Encoding
toCBOR = \case
    BadInputsUTxO Set (TxIn (Crypto era))
ins ->
      Word -> Encoding
encodeListLen Word
2 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word8 -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (Word8
0 :: Word8) Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Set (TxIn (Crypto era)) -> Encoding
forall a (f :: * -> *). (ToCBOR a, Foldable f) => f a -> Encoding
encodeFoldable Set (TxIn (Crypto era))
ins
    (OutsideValidityIntervalUTxO ValidityInterval
a SlotNo
b) ->
      Word -> Encoding
encodeListLen Word
3 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word8 -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (Word8
1 :: Word8)
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> ValidityInterval -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR ValidityInterval
a
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> SlotNo -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR SlotNo
b
    (MaxTxSizeUTxO Integer
a Integer
b) ->
      Word -> Encoding
encodeListLen Word
3 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word8 -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (Word8
2 :: Word8)
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Integer -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Integer
a
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Integer -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Integer
b
    UtxoPredicateFailure era
InputSetEmptyUTxO -> Word -> Encoding
encodeListLen Word
1 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word8 -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (Word8
3 :: Word8)
    (FeeTooSmallUTxO Coin
a Coin
b) ->
      Word -> Encoding
encodeListLen Word
3 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word8 -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (Word8
4 :: Word8)
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Coin -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Coin
a
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Coin -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Coin
b
    (ValueNotConservedUTxO Value era
a Value era
b) ->
      Word -> Encoding
encodeListLen Word
3 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word8 -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (Word8
5 :: Word8)
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Value era -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Value era
a
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Value era -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Value era
b
    OutputTooSmallUTxO [TxOut era]
outs ->
      Word -> Encoding
encodeListLen Word
2 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word8 -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (Word8
6 :: Word8)
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> [TxOut era] -> Encoding
forall a (f :: * -> *). (ToCBOR a, Foldable f) => f a -> Encoding
encodeFoldable [TxOut era]
outs
    (UpdateFailure PredicateFailure (EraRule "PPUP" era)
a) ->
      Word -> Encoding
encodeListLen Word
2 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word8 -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (Word8
7 :: Word8)
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> PredicateFailure (EraRule "PPUP" era) -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR PredicateFailure (EraRule "PPUP" era)
a
    (WrongNetwork Network
right Set (Addr (Crypto era))
wrongs) ->
      Word -> Encoding
encodeListLen Word
3 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word8 -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (Word8
8 :: Word8)
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Network -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Network
right
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Set (Addr (Crypto era)) -> Encoding
forall a (f :: * -> *). (ToCBOR a, Foldable f) => f a -> Encoding
encodeFoldable Set (Addr (Crypto era))
wrongs
    (WrongNetworkWithdrawal Network
right Set (RewardAcnt (Crypto era))
wrongs) ->
      Word -> Encoding
encodeListLen Word
3 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word8 -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (Word8
9 :: Word8)
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Network -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Network
right
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Set (RewardAcnt (Crypto era)) -> Encoding
forall a (f :: * -> *). (ToCBOR a, Foldable f) => f a -> Encoding
encodeFoldable Set (RewardAcnt (Crypto era))
wrongs
    OutputBootAddrAttrsTooBig [TxOut era]
outs ->
      Word -> Encoding
encodeListLen Word
2 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word8 -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (Word8
10 :: Word8)
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> [TxOut era] -> Encoding
forall a (f :: * -> *). (ToCBOR a, Foldable f) => f a -> Encoding
encodeFoldable [TxOut era]
outs
    UtxoPredicateFailure era
TriesToForgeADA -> Word -> Encoding
encodeListLen Word
1 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word8 -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (Word8
11 :: Word8)
    OutputTooBigUTxO [TxOut era]
outs ->
      Word -> Encoding
encodeListLen Word
2 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word8 -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (Word8
12 :: Word8)
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> [TxOut era] -> Encoding
forall a (f :: * -> *). (ToCBOR a, Foldable f) => f a -> Encoding
encodeFoldable [TxOut era]
outs

instance
  ( TransValue FromCBOR era,
    Shelley.TransUTxO FromCBOR era,
    Val.DecodeNonNegative (Core.Value era),
    Show (Core.Value era),
    FromCBOR (PredicateFailure (Core.EraRule "PPUP" era))
  ) =>
  FromCBOR (UtxoPredicateFailure era)
  where
  fromCBOR :: Decoder s (UtxoPredicateFailure era)
fromCBOR =
    String
-> (Word -> Decoder s (Int, UtxoPredicateFailure era))
-> Decoder s (UtxoPredicateFailure era)
forall s a. String -> (Word -> Decoder s (Int, a)) -> Decoder s a
decodeRecordSum String
"PredicateFailureUTXO" ((Word -> Decoder s (Int, UtxoPredicateFailure era))
 -> Decoder s (UtxoPredicateFailure era))
-> (Word -> Decoder s (Int, UtxoPredicateFailure era))
-> Decoder s (UtxoPredicateFailure era)
forall a b. (a -> b) -> a -> b
$
      \case
        Word
0 -> do
          Set (TxIn (Crypto era))
ins <- Decoder s (TxIn (Crypto era))
-> Decoder s (Set (TxIn (Crypto era)))
forall a s. Ord a => Decoder s a -> Decoder s (Set a)
decodeSet Decoder s (TxIn (Crypto era))
forall a s. FromCBOR a => Decoder s a
fromCBOR
          (Int, UtxoPredicateFailure era)
-> Decoder s (Int, UtxoPredicateFailure era)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
2, Set (TxIn (Crypto era)) -> UtxoPredicateFailure era
forall era. Set (TxIn (Crypto era)) -> UtxoPredicateFailure era
BadInputsUTxO Set (TxIn (Crypto era))
ins) -- The (2,..) indicates the number of things decoded, INCLUDING the tags, which are decoded by decodeRecordSumNamed
        Word
1 -> do
          ValidityInterval
a <- Decoder s ValidityInterval
forall a s. FromCBOR a => Decoder s a
fromCBOR
          SlotNo
b <- Decoder s SlotNo
forall a s. FromCBOR a => Decoder s a
fromCBOR
          (Int, UtxoPredicateFailure era)
-> Decoder s (Int, UtxoPredicateFailure era)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
3, ValidityInterval -> SlotNo -> UtxoPredicateFailure era
forall era. ValidityInterval -> SlotNo -> UtxoPredicateFailure era
OutsideValidityIntervalUTxO ValidityInterval
a SlotNo
b)
        Word
2 -> do
          Integer
a <- Decoder s Integer
forall a s. FromCBOR a => Decoder s a
fromCBOR
          Integer
b <- Decoder s Integer
forall a s. FromCBOR a => Decoder s a
fromCBOR
          (Int, UtxoPredicateFailure era)
-> Decoder s (Int, UtxoPredicateFailure era)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
3, Integer -> Integer -> UtxoPredicateFailure era
forall era. Integer -> Integer -> UtxoPredicateFailure era
MaxTxSizeUTxO Integer
a Integer
b)
        Word
3 -> (Int, UtxoPredicateFailure era)
-> Decoder s (Int, UtxoPredicateFailure era)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
1, UtxoPredicateFailure era
forall era. UtxoPredicateFailure era
InputSetEmptyUTxO)
        Word
4 -> do
          Coin
a <- Decoder s Coin
forall a s. FromCBOR a => Decoder s a
fromCBOR
          Coin
b <- Decoder s Coin
forall a s. FromCBOR a => Decoder s a
fromCBOR
          (Int, UtxoPredicateFailure era)
-> Decoder s (Int, UtxoPredicateFailure era)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
3, Coin -> Coin -> UtxoPredicateFailure era
forall era. Coin -> Coin -> UtxoPredicateFailure era
FeeTooSmallUTxO Coin
a Coin
b)
        Word
5 -> do
          Value era
a <- Decoder s (Value era)
forall a s. FromCBOR a => Decoder s a
fromCBOR
          Value era
b <- Decoder s (Value era)
forall a s. FromCBOR a => Decoder s a
fromCBOR
          (Int, UtxoPredicateFailure era)
-> Decoder s (Int, UtxoPredicateFailure era)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
3, Value era -> Value era -> UtxoPredicateFailure era
forall era. Value era -> Value era -> UtxoPredicateFailure era
ValueNotConservedUTxO Value era
a Value era
b)
        Word
6 -> do
          [TxOut era]
outs <- Decoder s (TxOut era) -> Decoder s [TxOut era]
forall s a. Decoder s a -> Decoder s [a]
decodeList Decoder s (TxOut era)
forall a s. FromCBOR a => Decoder s a
fromCBOR
          (Int, UtxoPredicateFailure era)
-> Decoder s (Int, UtxoPredicateFailure era)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
2, [TxOut era] -> UtxoPredicateFailure era
forall era. [TxOut era] -> UtxoPredicateFailure era
OutputTooSmallUTxO [TxOut era]
outs)
        Word
7 -> do
          PredicateFailure (EraRule "PPUP" era)
a <- Decoder s (PredicateFailure (EraRule "PPUP" era))
forall a s. FromCBOR a => Decoder s a
fromCBOR
          (Int, UtxoPredicateFailure era)
-> Decoder s (Int, UtxoPredicateFailure era)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
2, PredicateFailure (EraRule "PPUP" era) -> UtxoPredicateFailure era
forall era.
PredicateFailure (EraRule "PPUP" era) -> UtxoPredicateFailure era
UpdateFailure PredicateFailure (EraRule "PPUP" era)
a)
        Word
8 -> do
          Network
right <- Decoder s Network
forall a s. FromCBOR a => Decoder s a
fromCBOR
          Set (Addr (Crypto era))
wrongs <- Decoder s (Addr (Crypto era))
-> Decoder s (Set (Addr (Crypto era)))
forall a s. Ord a => Decoder s a -> Decoder s (Set a)
decodeSet Decoder s (Addr (Crypto era))
forall a s. FromCBOR a => Decoder s a
fromCBOR
          (Int, UtxoPredicateFailure era)
-> Decoder s (Int, UtxoPredicateFailure era)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
3, Network -> Set (Addr (Crypto era)) -> UtxoPredicateFailure era
forall era.
Network -> Set (Addr (Crypto era)) -> UtxoPredicateFailure era
WrongNetwork Network
right Set (Addr (Crypto era))
wrongs)
        Word
9 -> do
          Network
right <- Decoder s Network
forall a s. FromCBOR a => Decoder s a
fromCBOR
          Set (RewardAcnt (Crypto era))
wrongs <- Decoder s (RewardAcnt (Crypto era))
-> Decoder s (Set (RewardAcnt (Crypto era)))
forall a s. Ord a => Decoder s a -> Decoder s (Set a)
decodeSet Decoder s (RewardAcnt (Crypto era))
forall a s. FromCBOR a => Decoder s a
fromCBOR
          (Int, UtxoPredicateFailure era)
-> Decoder s (Int, UtxoPredicateFailure era)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
3, Network
-> Set (RewardAcnt (Crypto era)) -> UtxoPredicateFailure era
forall era.
Network
-> Set (RewardAcnt (Crypto era)) -> UtxoPredicateFailure era
WrongNetworkWithdrawal Network
right Set (RewardAcnt (Crypto era))
wrongs)
        Word
10 -> do
          [TxOut era]
outs <- Decoder s (TxOut era) -> Decoder s [TxOut era]
forall s a. Decoder s a -> Decoder s [a]
decodeList Decoder s (TxOut era)
forall a s. FromCBOR a => Decoder s a
fromCBOR
          (Int, UtxoPredicateFailure era)
-> Decoder s (Int, UtxoPredicateFailure era)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
2, [TxOut era] -> UtxoPredicateFailure era
forall era. [TxOut era] -> UtxoPredicateFailure era
OutputBootAddrAttrsTooBig [TxOut era]
outs)
        Word
11 -> (Int, UtxoPredicateFailure era)
-> Decoder s (Int, UtxoPredicateFailure era)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
1, UtxoPredicateFailure era
forall era. UtxoPredicateFailure era
TriesToForgeADA)
        Word
12 -> do
          [TxOut era]
outs <- Decoder s (TxOut era) -> Decoder s [TxOut era]
forall s a. Decoder s a -> Decoder s [a]
decodeList Decoder s (TxOut era)
forall a s. FromCBOR a => Decoder s a
fromCBOR
          (Int, UtxoPredicateFailure era)
-> Decoder s (Int, UtxoPredicateFailure era)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
2, [TxOut era] -> UtxoPredicateFailure era
forall era. [TxOut era] -> UtxoPredicateFailure era
OutputTooBigUTxO [TxOut era]
outs)
        Word
k -> Word -> Decoder s (Int, UtxoPredicateFailure era)
forall s a. Word -> Decoder s a
invalidKey Word
k

-- ===============================================
-- Inject instances

fromShelleyFailure :: Shelley.UtxoPredicateFailure era -> Maybe (UtxoPredicateFailure era)
fromShelleyFailure :: UtxoPredicateFailure era -> Maybe (UtxoPredicateFailure era)
fromShelleyFailure = \case
  Shelley.BadInputsUTxO Set (TxIn (Crypto era))
ins -> UtxoPredicateFailure era -> Maybe (UtxoPredicateFailure era)
forall a. a -> Maybe a
Just (UtxoPredicateFailure era -> Maybe (UtxoPredicateFailure era))
-> UtxoPredicateFailure era -> Maybe (UtxoPredicateFailure era)
forall a b. (a -> b) -> a -> b
$ Set (TxIn (Crypto era)) -> UtxoPredicateFailure era
forall era. Set (TxIn (Crypto era)) -> UtxoPredicateFailure era
BadInputsUTxO Set (TxIn (Crypto era))
ins
  Shelley.ExpiredUTxO {} -> Maybe (UtxoPredicateFailure era)
forall a. Maybe a
Nothing -- Rule was replaced with `OutsideValidityIntervalUTxO`
  Shelley.MaxTxSizeUTxO Integer
a Integer
m -> UtxoPredicateFailure era -> Maybe (UtxoPredicateFailure era)
forall a. a -> Maybe a
Just (UtxoPredicateFailure era -> Maybe (UtxoPredicateFailure era))
-> UtxoPredicateFailure era -> Maybe (UtxoPredicateFailure era)
forall a b. (a -> b) -> a -> b
$ Integer -> Integer -> UtxoPredicateFailure era
forall era. Integer -> Integer -> UtxoPredicateFailure era
MaxTxSizeUTxO Integer
a Integer
m
  UtxoPredicateFailure era
Shelley.InputSetEmptyUTxO -> UtxoPredicateFailure era -> Maybe (UtxoPredicateFailure era)
forall a. a -> Maybe a
Just UtxoPredicateFailure era
forall era. UtxoPredicateFailure era
InputSetEmptyUTxO
  Shelley.FeeTooSmallUTxO Coin
mf Coin
af -> UtxoPredicateFailure era -> Maybe (UtxoPredicateFailure era)
forall a. a -> Maybe a
Just (UtxoPredicateFailure era -> Maybe (UtxoPredicateFailure era))
-> UtxoPredicateFailure era -> Maybe (UtxoPredicateFailure era)
forall a b. (a -> b) -> a -> b
$ Coin -> Coin -> UtxoPredicateFailure era
forall era. Coin -> Coin -> UtxoPredicateFailure era
FeeTooSmallUTxO Coin
mf Coin
af
  Shelley.ValueNotConservedUTxO {} -> Maybe (UtxoPredicateFailure era)
forall a. Maybe a
Nothing -- Rule was updated
  Shelley.WrongNetwork Network
n Set (Addr (Crypto era))
as -> UtxoPredicateFailure era -> Maybe (UtxoPredicateFailure era)
forall a. a -> Maybe a
Just (UtxoPredicateFailure era -> Maybe (UtxoPredicateFailure era))
-> UtxoPredicateFailure era -> Maybe (UtxoPredicateFailure era)
forall a b. (a -> b) -> a -> b
$ Network -> Set (Addr (Crypto era)) -> UtxoPredicateFailure era
forall era.
Network -> Set (Addr (Crypto era)) -> UtxoPredicateFailure era
WrongNetwork Network
n Set (Addr (Crypto era))
as
  Shelley.WrongNetworkWithdrawal Network
n Set (RewardAcnt (Crypto era))
as -> UtxoPredicateFailure era -> Maybe (UtxoPredicateFailure era)
forall a. a -> Maybe a
Just (UtxoPredicateFailure era -> Maybe (UtxoPredicateFailure era))
-> UtxoPredicateFailure era -> Maybe (UtxoPredicateFailure era)
forall a b. (a -> b) -> a -> b
$ Network
-> Set (RewardAcnt (Crypto era)) -> UtxoPredicateFailure era
forall era.
Network
-> Set (RewardAcnt (Crypto era)) -> UtxoPredicateFailure era
WrongNetworkWithdrawal Network
n Set (RewardAcnt (Crypto era))
as
  Shelley.OutputTooSmallUTxO {} -> Maybe (UtxoPredicateFailure era)
forall a. Maybe a
Nothing -- Rule was updated
  Shelley.UpdateFailure PredicateFailure (EraRule "PPUP" era)
ppf -> UtxoPredicateFailure era -> Maybe (UtxoPredicateFailure era)
forall a. a -> Maybe a
Just (UtxoPredicateFailure era -> Maybe (UtxoPredicateFailure era))
-> UtxoPredicateFailure era -> Maybe (UtxoPredicateFailure era)
forall a b. (a -> b) -> a -> b
$ PredicateFailure (EraRule "PPUP" era) -> UtxoPredicateFailure era
forall era.
PredicateFailure (EraRule "PPUP" era) -> UtxoPredicateFailure era
UpdateFailure PredicateFailure (EraRule "PPUP" era)
ppf
  Shelley.OutputBootAddrAttrsTooBig [TxOut era]
outs -> UtxoPredicateFailure era -> Maybe (UtxoPredicateFailure era)
forall a. a -> Maybe a
Just (UtxoPredicateFailure era -> Maybe (UtxoPredicateFailure era))
-> UtxoPredicateFailure era -> Maybe (UtxoPredicateFailure era)
forall a b. (a -> b) -> a -> b
$ [TxOut era] -> UtxoPredicateFailure era
forall era. [TxOut era] -> UtxoPredicateFailure era
OutputBootAddrAttrsTooBig [TxOut era]
outs

instance InjectMaybe (Shelley.UtxoPredicateFailure era) (UtxoPredicateFailure era) where
  injectMaybe :: UtxoPredicateFailure era -> Maybe (UtxoPredicateFailure era)
injectMaybe = UtxoPredicateFailure era -> Maybe (UtxoPredicateFailure era)
forall era.
UtxoPredicateFailure era -> Maybe (UtxoPredicateFailure era)
fromShelleyFailure

instance Inject (UtxoPredicateFailure era) (UtxoPredicateFailure era) where
  inject :: UtxoPredicateFailure era -> UtxoPredicateFailure era
inject = UtxoPredicateFailure era -> UtxoPredicateFailure era
forall a. a -> a
id

instance Inject (Shelley.UtxoPredicateFailure era) (UtxoPredicateFailure era) where
  inject :: UtxoPredicateFailure era -> UtxoPredicateFailure era
inject (Shelley.BadInputsUTxO Set (TxIn (Crypto era))
ins) = Set (TxIn (Crypto era)) -> UtxoPredicateFailure era
forall era. Set (TxIn (Crypto era)) -> UtxoPredicateFailure era
BadInputsUTxO Set (TxIn (Crypto era))
ins
  inject (Shelley.ExpiredUTxO SlotNo
ttl SlotNo
current) = ValidityInterval -> SlotNo -> UtxoPredicateFailure era
forall era. ValidityInterval -> SlotNo -> UtxoPredicateFailure era
OutsideValidityIntervalUTxO (StrictMaybe SlotNo -> StrictMaybe SlotNo -> ValidityInterval
ValidityInterval StrictMaybe SlotNo
forall a. StrictMaybe a
SNothing (SlotNo -> StrictMaybe SlotNo
forall a. a -> StrictMaybe a
SJust SlotNo
ttl)) SlotNo
current
  inject (Shelley.MaxTxSizeUTxO Integer
a Integer
m) = Integer -> Integer -> UtxoPredicateFailure era
forall era. Integer -> Integer -> UtxoPredicateFailure era
MaxTxSizeUTxO Integer
a Integer
m
  inject (UtxoPredicateFailure era
Shelley.InputSetEmptyUTxO) = UtxoPredicateFailure era
forall era. UtxoPredicateFailure era
InputSetEmptyUTxO
  inject (Shelley.FeeTooSmallUTxO Coin
mf Coin
af) = Coin -> Coin -> UtxoPredicateFailure era
forall era. Coin -> Coin -> UtxoPredicateFailure era
FeeTooSmallUTxO Coin
mf Coin
af
  inject (Shelley.ValueNotConservedUTxO Value era
vc Value era
vp) = Value era -> Value era -> UtxoPredicateFailure era
forall era. Value era -> Value era -> UtxoPredicateFailure era
ValueNotConservedUTxO Value era
vc Value era
vp
  inject (Shelley.WrongNetwork Network
n Set (Addr (Crypto era))
as) = Network -> Set (Addr (Crypto era)) -> UtxoPredicateFailure era
forall era.
Network -> Set (Addr (Crypto era)) -> UtxoPredicateFailure era
WrongNetwork Network
n Set (Addr (Crypto era))
as
  inject (Shelley.WrongNetworkWithdrawal Network
n Set (RewardAcnt (Crypto era))
as) = Network
-> Set (RewardAcnt (Crypto era)) -> UtxoPredicateFailure era
forall era.
Network
-> Set (RewardAcnt (Crypto era)) -> UtxoPredicateFailure era
WrongNetworkWithdrawal Network
n Set (RewardAcnt (Crypto era))
as
  inject (Shelley.OutputTooSmallUTxO [TxOut era]
x) = [TxOut era] -> UtxoPredicateFailure era
forall era. [TxOut era] -> UtxoPredicateFailure era
OutputTooSmallUTxO [TxOut era]
x
  inject (Shelley.UpdateFailure PredicateFailure (EraRule "PPUP" era)
x) = PredicateFailure (EraRule "PPUP" era) -> UtxoPredicateFailure era
forall era.
PredicateFailure (EraRule "PPUP" era) -> UtxoPredicateFailure era
UpdateFailure PredicateFailure (EraRule "PPUP" era)
x
  inject (Shelley.OutputBootAddrAttrsTooBig [TxOut era]
outs) = [TxOut era] -> UtxoPredicateFailure era
forall era. [TxOut era] -> UtxoPredicateFailure era
OutputTooBigUTxO [TxOut era]
outs