{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Cardano.Ledger.Alonzo.Rules.Utxos (
  AlonzoUTXOS,
  AlonzoUtxosPredFailure (..),
  lbl2Phase,
  TagMismatchDescription (..),
  validBegin,
  validEnd,
  invalidBegin,
  invalidEnd,
  AlonzoUtxosEvent (..),
  when2Phase,
  FailureDescription (..),
  scriptFailureToFailureDescription,
) where

import Cardano.Ledger.Alonzo.Core
import Cardano.Ledger.Alonzo.Era (AlonzoEra, AlonzoUTXOS)
import Cardano.Ledger.Alonzo.Plutus.Context (ContextError, EraPlutusContext)
import Cardano.Ledger.Alonzo.Plutus.Evaluate (
  CollectError (..),
  collectPlutusScriptsWithContext,
  evalPlutusScripts,
 )
import Cardano.Ledger.Alonzo.Rules.Ppup ()
import Cardano.Ledger.Alonzo.State
import Cardano.Ledger.Alonzo.UTxO (AlonzoEraUTxO (..), AlonzoScriptsNeeded)
import Cardano.Ledger.BaseTypes (
  Globals,
  ShelleyBase,
  StrictMaybe,
  epochInfo,
  kindObject,
  systemStart,
 )
import Cardano.Ledger.Binary (
  DecCBOR (..),
  EncCBOR (..),
 )
import Cardano.Ledger.Binary.Coders
import qualified Cardano.Ledger.Binary.Plain as Plain
import Cardano.Ledger.Coin (Coin)
import Cardano.Ledger.Plutus.Evaluate (
  PlutusWithContext,
  ScriptFailure (..),
  ScriptResult (..),
 )
import Cardano.Ledger.Rules.ValidationMode (lblStatic)
import Cardano.Ledger.Shelley.LedgerState (UTxOState (..))
import qualified Cardano.Ledger.Shelley.LedgerState as Shelley
import Cardano.Ledger.Shelley.PParams (Update)
import Cardano.Ledger.Shelley.Rules (
  PpupEnv (..),
  PpupEvent,
  ShelleyPPUP,
  ShelleyPpupPredFailure,
  UtxoEnv (..),
  updateUTxOState,
 )
import Cardano.Ledger.Shelley.TxCert (ShelleyTxCert)
import Cardano.Slotting.EpochInfo.Extend (unsafeLinearExtendEpochInfo)
import Cardano.Slotting.Slot (SlotNo)
import Control.DeepSeq (NFData)
import Control.Monad.Trans.Reader (ReaderT, asks)
import Control.State.Transition.Extended
import Data.Aeson (ToJSON (..), (.=))
import qualified Data.Aeson as Aeson
import Data.ByteString as BS (ByteString)
import qualified Data.ByteString.Base64 as B64
import Data.List (intercalate)
import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
import qualified Data.List.NonEmpty as NE
import Data.MapExtras (extractKeys)
import Data.Text (Text)
import qualified Debug.Trace as Debug
import GHC.Generics (Generic)
import Lens.Micro
import NoThunks.Class (NoThunks)

--------------------------------------------------------------------------------
-- The AlonzoUTXOS transition system
--------------------------------------------------------------------------------

instance
  ( AlonzoEraTx era
  , AlonzoEraPParams era
  , ShelleyEraTxBody era
  , AlonzoEraUTxO era
  , ScriptsNeeded era ~ AlonzoScriptsNeeded era
  , AlonzoEraScript era
  , TxCert era ~ ShelleyTxCert era
  , EraGov era
  , GovState era ~ ShelleyGovState era
  , State (EraRule "PPUP" era) ~ ShelleyGovState era
  , Embed (EraRule "PPUP" era) (AlonzoUTXOS era)
  , Environment (EraRule "PPUP" era) ~ PpupEnv era
  , Signal (EraRule "PPUP" era) ~ StrictMaybe (Update era)
  , EncCBOR (PredicateFailure (EraRule "PPUP" era)) -- Serializing the PredicateFailure,
  , Eq (EraRuleFailure "PPUP" era)
  , Show (EraRuleFailure "PPUP" era)
  , EraPlutusContext era
  , EraCertState era
  , EraStake era
  ) =>
  STS (AlonzoUTXOS era)
  where
  type BaseM (AlonzoUTXOS era) = ShelleyBase
  type Environment (AlonzoUTXOS era) = UtxoEnv era
  type State (AlonzoUTXOS era) = UTxOState era
  type Signal (AlonzoUTXOS era) = Tx TopTx era
  type PredicateFailure (AlonzoUTXOS era) = AlonzoUtxosPredFailure era
  type Event (AlonzoUTXOS era) = AlonzoUtxosEvent era
  transitionRules :: [TransitionRule (AlonzoUTXOS era)]
transitionRules = [TransitionRule (AlonzoUTXOS era)
forall era.
(AlonzoEraTx era, ShelleyEraTxBody era, AlonzoEraUTxO era,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era,
 TxCert era ~ ShelleyTxCert era, EraGov era,
 GovState era ~ ShelleyGovState era,
 State (EraRule "PPUP" era) ~ ShelleyGovState era,
 Environment (EraRule "PPUP" era) ~ PpupEnv era,
 Signal (EraRule "PPUP" era) ~ StrictMaybe (Update era),
 Embed (EraRule "PPUP" era) (AlonzoUTXOS era),
 EncCBOR (PredicateFailure (EraRule "PPUP" era)),
 Eq (EraRuleFailure "PPUP" era), Show (EraRuleFailure "PPUP" era),
 EraPlutusContext era, EraCertState era, EraStake era) =>
TransitionRule (AlonzoUTXOS era)
utxosTransition]

data AlonzoUtxosEvent era
  = AlonzoPpupToUtxosEvent (EraRuleEvent "PPUP" era)
  | TotalDeposits (SafeHash EraIndependentTxBody) Coin
  | SuccessfulPlutusScriptsEvent (NonEmpty PlutusWithContext)
  | FailedPlutusScriptsEvent (NonEmpty PlutusWithContext)
  | -- | The UTxOs consumed and created by a signal tx
    TxUTxODiff
      -- | UTxO consumed
      (UTxO era)
      -- | UTxO created
      (UTxO era)
  deriving ((forall x. AlonzoUtxosEvent era -> Rep (AlonzoUtxosEvent era) x)
-> (forall x. Rep (AlonzoUtxosEvent era) x -> AlonzoUtxosEvent era)
-> Generic (AlonzoUtxosEvent era)
forall x. Rep (AlonzoUtxosEvent era) x -> AlonzoUtxosEvent era
forall x. AlonzoUtxosEvent era -> Rep (AlonzoUtxosEvent era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x. Rep (AlonzoUtxosEvent era) x -> AlonzoUtxosEvent era
forall era x. AlonzoUtxosEvent era -> Rep (AlonzoUtxosEvent era) x
$cfrom :: forall era x. AlonzoUtxosEvent era -> Rep (AlonzoUtxosEvent era) x
from :: forall x. AlonzoUtxosEvent era -> Rep (AlonzoUtxosEvent era) x
$cto :: forall era x. Rep (AlonzoUtxosEvent era) x -> AlonzoUtxosEvent era
to :: forall x. Rep (AlonzoUtxosEvent era) x -> AlonzoUtxosEvent era
Generic)

deriving instance
  ( Era era
  , Eq (TxOut era)
  , Eq (EraRuleEvent "PPUP" era)
  ) =>
  Eq (AlonzoUtxosEvent era)

instance
  ( Era era
  , NFData (TxOut era)
  , NFData (EraRuleEvent "PPUP" era)
  ) =>
  NFData (AlonzoUtxosEvent era)

instance
  ( Era era
  , STS (ShelleyPPUP era)
  , EraRuleFailure "PPUP" era ~ ShelleyPpupPredFailure era
  , Event (EraRule "PPUP" era) ~ Event (ShelleyPPUP era)
  , EraRuleEvent "PPUP" era ~ PpupEvent era
  ) =>
  Embed (ShelleyPPUP era) (AlonzoUTXOS era)
  where
  wrapFailed :: PredicateFailure (ShelleyPPUP era)
-> PredicateFailure (AlonzoUTXOS era)
wrapFailed = EraRuleFailure "PPUP" era -> AlonzoUtxosPredFailure era
PredicateFailure (ShelleyPPUP era)
-> PredicateFailure (AlonzoUTXOS era)
forall era. EraRuleFailure "PPUP" era -> AlonzoUtxosPredFailure era
UpdateFailure
  wrapEvent :: Event (ShelleyPPUP era) -> Event (AlonzoUTXOS era)
wrapEvent = EraRuleEvent "PPUP" era -> AlonzoUtxosEvent era
Event (ShelleyPPUP era) -> Event (AlonzoUTXOS era)
forall era. EraRuleEvent "PPUP" era -> AlonzoUtxosEvent era
AlonzoPpupToUtxosEvent

utxosTransition ::
  forall era.
  ( AlonzoEraTx era
  , ShelleyEraTxBody era
  , AlonzoEraUTxO era
  , ScriptsNeeded era ~ AlonzoScriptsNeeded era
  , TxCert era ~ ShelleyTxCert era
  , EraGov era
  , GovState era ~ ShelleyGovState era
  , State (EraRule "PPUP" era) ~ ShelleyGovState era
  , Environment (EraRule "PPUP" era) ~ PpupEnv era
  , Signal (EraRule "PPUP" era) ~ StrictMaybe (Update era)
  , Embed (EraRule "PPUP" era) (AlonzoUTXOS era)
  , EncCBOR (PredicateFailure (EraRule "PPUP" era)) -- Serializing the PredicateFailure
  , Eq (EraRuleFailure "PPUP" era)
  , Show (EraRuleFailure "PPUP" era)
  , EraPlutusContext era
  , EraCertState era
  , EraStake era
  ) =>
  TransitionRule (AlonzoUTXOS era)
utxosTransition :: forall era.
(AlonzoEraTx era, ShelleyEraTxBody era, AlonzoEraUTxO era,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era,
 TxCert era ~ ShelleyTxCert era, EraGov era,
 GovState era ~ ShelleyGovState era,
 State (EraRule "PPUP" era) ~ ShelleyGovState era,
 Environment (EraRule "PPUP" era) ~ PpupEnv era,
 Signal (EraRule "PPUP" era) ~ StrictMaybe (Update era),
 Embed (EraRule "PPUP" era) (AlonzoUTXOS era),
 EncCBOR (PredicateFailure (EraRule "PPUP" era)),
 Eq (EraRuleFailure "PPUP" era), Show (EraRuleFailure "PPUP" era),
 EraPlutusContext era, EraCertState era, EraStake era) =>
TransitionRule (AlonzoUTXOS era)
utxosTransition =
  Rule
  (AlonzoUTXOS era)
  'Transition
  (RuleContext 'Transition (AlonzoUTXOS era))
F (Clause (AlonzoUTXOS era) 'Transition) (TRC (AlonzoUTXOS era))
forall sts (rtype :: RuleType).
Rule sts rtype (RuleContext rtype sts)
judgmentContext F (Clause (AlonzoUTXOS era) 'Transition) (TRC (AlonzoUTXOS era))
-> (TRC (AlonzoUTXOS era)
    -> F (Clause (AlonzoUTXOS era) 'Transition) (UTxOState era))
-> F (Clause (AlonzoUTXOS era) 'Transition) (UTxOState era)
forall a b.
F (Clause (AlonzoUTXOS era) 'Transition) a
-> (a -> F (Clause (AlonzoUTXOS era) 'Transition) b)
-> F (Clause (AlonzoUTXOS era) 'Transition) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(TRC (Environment (AlonzoUTXOS era)
_, State (AlonzoUTXOS era)
_, Signal (AlonzoUTXOS era)
tx)) -> do
    case Tx TopTx era
Signal (AlonzoUTXOS era)
tx Tx TopTx era -> Getting IsValid (Tx TopTx era) IsValid -> IsValid
forall s a. s -> Getting a s a -> a
^. Getting IsValid (Tx TopTx era) IsValid
forall era. AlonzoEraTx era => Lens' (Tx TopTx era) IsValid
Lens' (Tx TopTx era) IsValid
isValidTxL of
      IsValid Bool
True -> F (Clause (AlonzoUTXOS era) 'Transition) (State (AlonzoUTXOS era))
F (Clause (AlonzoUTXOS era) 'Transition) (UTxOState era)
forall era.
(AlonzoEraTx era, AlonzoEraUTxO era, ShelleyEraTxBody era,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era, STS (AlonzoUTXOS era),
 Environment (EraRule "PPUP" era) ~ PpupEnv era,
 Signal (EraRule "PPUP" era) ~ StrictMaybe (Update era),
 Embed (EraRule "PPUP" era) (AlonzoUTXOS era),
 GovState era ~ ShelleyGovState era,
 State (EraRule "PPUP" era) ~ ShelleyGovState era,
 EraPlutusContext era, EraCertState era, EraStake era) =>
TransitionRule (AlonzoUTXOS era)
alonzoEvalScriptsTxValid
      IsValid Bool
False -> F (Clause (AlonzoUTXOS era) 'Transition) (State (AlonzoUTXOS era))
F (Clause (AlonzoUTXOS era) 'Transition) (UTxOState era)
forall era.
(AlonzoEraTx era, AlonzoEraUTxO era,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era, STS (AlonzoUTXOS era),
 EraPlutusContext era, EraStake era) =>
TransitionRule (AlonzoUTXOS era)
alonzoEvalScriptsTxInvalid

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

scriptsTransition ::
  ( STS sts
  , Monad m
  , AlonzoEraTxBody era
  , AlonzoEraTxWits era
  , AlonzoEraUTxO era
  , ScriptsNeeded era ~ AlonzoScriptsNeeded era
  , BaseM sts ~ ReaderT Globals m
  , PredicateFailure sts ~ AlonzoUtxosPredFailure era
  , EraPlutusContext era
  ) =>
  SlotNo ->
  PParams era ->
  Tx TopTx era ->
  UTxO era ->
  (ScriptResult -> Rule sts ctx ()) ->
  Rule sts ctx ()
scriptsTransition :: forall sts (m :: * -> *) era (ctx :: RuleType).
(STS sts, Monad m, AlonzoEraTxBody era, AlonzoEraTxWits era,
 AlonzoEraUTxO era, ScriptsNeeded era ~ AlonzoScriptsNeeded era,
 BaseM sts ~ ReaderT Globals m,
 PredicateFailure sts ~ AlonzoUtxosPredFailure era,
 EraPlutusContext era) =>
SlotNo
-> PParams era
-> Tx TopTx era
-> UTxO era
-> (ScriptResult -> Rule sts ctx ())
-> Rule sts ctx ()
scriptsTransition SlotNo
slot PParams era
pp Tx TopTx era
tx UTxO era
utxo ScriptResult -> Rule sts ctx ()
action = do
  sysSt <- BaseM sts SystemStart -> Rule sts ctx SystemStart
forall sts a (ctx :: RuleType).
STS sts =>
BaseM sts a -> Rule sts ctx a
liftSTS (BaseM sts SystemStart -> Rule sts ctx SystemStart)
-> BaseM sts SystemStart -> Rule sts ctx SystemStart
forall a b. (a -> b) -> a -> b
$ (Globals -> SystemStart) -> ReaderT Globals m SystemStart
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Globals -> SystemStart
systemStart
  ei <- liftSTS $ asks epochInfo
  case collectPlutusScriptsWithContext (unsafeLinearExtendEpochInfo slot ei) sysSt pp tx utxo of
    Right [PlutusWithContext]
sLst ->
      Rule sts ctx () -> Rule sts ctx ()
forall sts (ctx :: RuleType). Rule sts ctx () -> Rule sts ctx ()
when2Phase (Rule sts ctx () -> Rule sts ctx ())
-> Rule sts ctx () -> Rule sts ctx ()
forall a b. (a -> b) -> a -> b
$ ScriptResult -> Rule sts ctx ()
action (ScriptResult -> Rule sts ctx ())
-> ScriptResult -> Rule sts ctx ()
forall a b. (a -> b) -> a -> b
$ [PlutusWithContext] -> ScriptResult
evalPlutusScripts [PlutusWithContext]
sLst
    Left [CollectError era]
info
      | [CollectError era]
alonzoFailures <- (CollectError era -> Bool)
-> [CollectError era] -> [CollectError era]
forall a. (a -> Bool) -> [a] -> [a]
filter CollectError era -> Bool
forall {era}. CollectError era -> Bool
isNotBadTranslation [CollectError era]
info
      , Bool -> Bool
not ([CollectError era] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CollectError era]
alonzoFailures) ->
          PredicateFailure sts -> Rule sts ctx ()
forall sts (ctx :: RuleType).
PredicateFailure sts -> Rule sts ctx ()
failBecause ([CollectError era] -> AlonzoUtxosPredFailure era
forall era. [CollectError era] -> AlonzoUtxosPredFailure era
CollectErrors [CollectError era]
alonzoFailures)
      | Bool
otherwise -> () -> Rule sts ctx ()
forall a. a -> F (Clause sts ctx) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  where
    -- BadTranslation was introduced in Babbage, thus we need to filter those failures out.
    isNotBadTranslation :: CollectError era -> Bool
isNotBadTranslation = \case
      BadTranslation {} -> Bool
False
      CollectError era
_ -> Bool
True

alonzoEvalScriptsTxValid ::
  forall era.
  ( AlonzoEraTx era
  , AlonzoEraUTxO era
  , ShelleyEraTxBody era
  , ScriptsNeeded era ~ AlonzoScriptsNeeded era
  , STS (AlonzoUTXOS era)
  , Environment (EraRule "PPUP" era) ~ PpupEnv era
  , Signal (EraRule "PPUP" era) ~ StrictMaybe (Update era)
  , Embed (EraRule "PPUP" era) (AlonzoUTXOS era)
  , GovState era ~ ShelleyGovState era
  , State (EraRule "PPUP" era) ~ ShelleyGovState era
  , EraPlutusContext era
  , EraCertState era
  , EraStake era
  ) =>
  TransitionRule (AlonzoUTXOS era)
alonzoEvalScriptsTxValid :: forall era.
(AlonzoEraTx era, AlonzoEraUTxO era, ShelleyEraTxBody era,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era, STS (AlonzoUTXOS era),
 Environment (EraRule "PPUP" era) ~ PpupEnv era,
 Signal (EraRule "PPUP" era) ~ StrictMaybe (Update era),
 Embed (EraRule "PPUP" era) (AlonzoUTXOS era),
 GovState era ~ ShelleyGovState era,
 State (EraRule "PPUP" era) ~ ShelleyGovState era,
 EraPlutusContext era, EraCertState era, EraStake era) =>
TransitionRule (AlonzoUTXOS era)
alonzoEvalScriptsTxValid = do
  TRC (UtxoEnv slot pp certState, utxos@(UTxOState utxo _ _ pup _ _), tx) <-
    Rule
  (AlonzoUTXOS era)
  'Transition
  (RuleContext 'Transition (AlonzoUTXOS era))
F (Clause (AlonzoUTXOS era) 'Transition) (TRC (AlonzoUTXOS era))
forall sts (rtype :: RuleType).
Rule sts rtype (RuleContext rtype sts)
judgmentContext
  let txBody = Tx TopTx era
Signal (AlonzoUTXOS era)
tx Tx TopTx era
-> Getting (TxBody TopTx era) (Tx TopTx era) (TxBody TopTx era)
-> TxBody TopTx era
forall s a. s -> Getting a s a -> a
^. Getting (TxBody TopTx era) (Tx TopTx era) (TxBody TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL
      genDelegs = CertState era
certState CertState era
-> Getting GenDelegs (CertState era) GenDelegs -> GenDelegs
forall s a. s -> Getting a s a -> a
^. (DState era -> Const GenDelegs (DState era))
-> CertState era -> Const GenDelegs (CertState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL ((DState era -> Const GenDelegs (DState era))
 -> CertState era -> Const GenDelegs (CertState era))
-> ((GenDelegs -> Const GenDelegs GenDelegs)
    -> DState era -> Const GenDelegs (DState era))
-> Getting GenDelegs (CertState era) GenDelegs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenDelegs -> Const GenDelegs GenDelegs)
-> DState era -> Const GenDelegs (DState era)
forall era (f :: * -> *).
Functor f =>
(GenDelegs -> f GenDelegs) -> DState era -> f (DState era)
Shelley.dsGenDelegsL

  () <- pure $! Debug.traceEvent validBegin ()

  scriptsTransition slot pp tx utxo $ \case
    Fails [PlutusWithContext]
_ps NonEmpty ScriptFailure
fs ->
      PredicateFailure (AlonzoUTXOS era)
-> F (Clause (AlonzoUTXOS era) 'Transition) ()
forall sts (ctx :: RuleType).
PredicateFailure sts -> Rule sts ctx ()
failBecause (PredicateFailure (AlonzoUTXOS era)
 -> F (Clause (AlonzoUTXOS era) 'Transition) ())
-> PredicateFailure (AlonzoUTXOS era)
-> F (Clause (AlonzoUTXOS era) 'Transition) ()
forall a b. (a -> b) -> a -> b
$
        IsValid -> TagMismatchDescription -> AlonzoUtxosPredFailure era
forall era.
IsValid -> TagMismatchDescription -> AlonzoUtxosPredFailure era
ValidationTagMismatch
          (Tx TopTx era
Signal (AlonzoUTXOS era)
tx Tx TopTx era -> Getting IsValid (Tx TopTx era) IsValid -> IsValid
forall s a. s -> Getting a s a -> a
^. Getting IsValid (Tx TopTx era) IsValid
forall era. AlonzoEraTx era => Lens' (Tx TopTx era) IsValid
Lens' (Tx TopTx era) IsValid
isValidTxL)
          (NonEmpty FailureDescription -> TagMismatchDescription
FailedUnexpectedly (ScriptFailure -> FailureDescription
scriptFailureToFailureDescription (ScriptFailure -> FailureDescription)
-> NonEmpty ScriptFailure -> NonEmpty FailureDescription
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty ScriptFailure
fs))
    Passes [PlutusWithContext]
ps -> (NonEmpty PlutusWithContext
 -> F (Clause (AlonzoUTXOS era) 'Transition) ())
-> Maybe (NonEmpty PlutusWithContext)
-> F (Clause (AlonzoUTXOS era) 'Transition) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Event (AlonzoUTXOS era)
-> F (Clause (AlonzoUTXOS era) 'Transition) ()
AlonzoUtxosEvent era -> F (Clause (AlonzoUTXOS era) 'Transition) ()
forall sts (ctx :: RuleType). Event sts -> Rule sts ctx ()
tellEvent (AlonzoUtxosEvent era
 -> F (Clause (AlonzoUTXOS era) 'Transition) ())
-> (NonEmpty PlutusWithContext -> AlonzoUtxosEvent era)
-> NonEmpty PlutusWithContext
-> F (Clause (AlonzoUTXOS era) 'Transition) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty PlutusWithContext -> AlonzoUtxosEvent era
forall era. NonEmpty PlutusWithContext -> AlonzoUtxosEvent era
SuccessfulPlutusScriptsEvent) ([PlutusWithContext] -> Maybe (NonEmpty PlutusWithContext)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [PlutusWithContext]
ps)

  () <- pure $! Debug.traceEvent validEnd ()

  ppup' <-
    trans @(EraRule "PPUP" era) $
      TRC (PPUPEnv slot pp genDelegs, pup, txBody ^. updateTxBodyL)

  updateUTxOState
    pp
    utxos
    txBody
    certState
    ppup'
    (tellEvent . TotalDeposits (hashAnnotated txBody))
    (\UTxO era
a UTxO era
b -> Event (AlonzoUTXOS era)
-> F (Clause (AlonzoUTXOS era) 'Transition) ()
forall sts (ctx :: RuleType). Event sts -> Rule sts ctx ()
tellEvent (Event (AlonzoUTXOS era)
 -> F (Clause (AlonzoUTXOS era) 'Transition) ())
-> Event (AlonzoUTXOS era)
-> F (Clause (AlonzoUTXOS era) 'Transition) ()
forall a b. (a -> b) -> a -> b
$ UTxO era -> UTxO era -> AlonzoUtxosEvent era
forall era. UTxO era -> UTxO era -> AlonzoUtxosEvent era
TxUTxODiff UTxO era
a UTxO era
b)

alonzoEvalScriptsTxInvalid ::
  forall era.
  ( AlonzoEraTx era
  , AlonzoEraUTxO era
  , ScriptsNeeded era ~ AlonzoScriptsNeeded era
  , STS (AlonzoUTXOS era)
  , EraPlutusContext era
  , EraStake era
  ) =>
  TransitionRule (AlonzoUTXOS era)
alonzoEvalScriptsTxInvalid :: forall era.
(AlonzoEraTx era, AlonzoEraUTxO era,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era, STS (AlonzoUTXOS era),
 EraPlutusContext era, EraStake era) =>
TransitionRule (AlonzoUTXOS era)
alonzoEvalScriptsTxInvalid = do
  TRC (UtxoEnv slot pp _, utxos@(UTxOState utxo _ fees _ _ _), tx) <- Rule
  (AlonzoUTXOS era)
  'Transition
  (RuleContext 'Transition (AlonzoUTXOS era))
F (Clause (AlonzoUTXOS era) 'Transition) (TRC (AlonzoUTXOS era))
forall sts (rtype :: RuleType).
Rule sts rtype (RuleContext rtype sts)
judgmentContext
  let txBody = Tx TopTx era
Signal (AlonzoUTXOS era)
tx Tx TopTx era
-> Getting (TxBody TopTx era) (Tx TopTx era) (TxBody TopTx era)
-> TxBody TopTx era
forall s a. s -> Getting a s a -> a
^. Getting (TxBody TopTx era) (Tx TopTx era) (TxBody TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL

  () <- pure $! Debug.traceEvent invalidBegin ()

  scriptsTransition slot pp tx utxo $ \case
    Passes [PlutusWithContext]
_ps ->
      PredicateFailure (AlonzoUTXOS era)
-> F (Clause (AlonzoUTXOS era) 'Transition) ()
forall sts (ctx :: RuleType).
PredicateFailure sts -> Rule sts ctx ()
failBecause (PredicateFailure (AlonzoUTXOS era)
 -> F (Clause (AlonzoUTXOS era) 'Transition) ())
-> PredicateFailure (AlonzoUTXOS era)
-> F (Clause (AlonzoUTXOS era) 'Transition) ()
forall a b. (a -> b) -> a -> b
$
        IsValid -> TagMismatchDescription -> AlonzoUtxosPredFailure era
forall era.
IsValid -> TagMismatchDescription -> AlonzoUtxosPredFailure era
ValidationTagMismatch (Tx TopTx era
Signal (AlonzoUTXOS era)
tx Tx TopTx era -> Getting IsValid (Tx TopTx era) IsValid -> IsValid
forall s a. s -> Getting a s a -> a
^. Getting IsValid (Tx TopTx era) IsValid
forall era. AlonzoEraTx era => Lens' (Tx TopTx era) IsValid
Lens' (Tx TopTx era) IsValid
isValidTxL) TagMismatchDescription
PassedUnexpectedly
    Fails [PlutusWithContext]
ps NonEmpty ScriptFailure
fs -> do
      (NonEmpty PlutusWithContext
 -> F (Clause (AlonzoUTXOS era) 'Transition) ())
-> Maybe (NonEmpty PlutusWithContext)
-> F (Clause (AlonzoUTXOS era) 'Transition) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Event (AlonzoUTXOS era)
-> F (Clause (AlonzoUTXOS era) 'Transition) ()
AlonzoUtxosEvent era -> F (Clause (AlonzoUTXOS era) 'Transition) ()
forall sts (ctx :: RuleType). Event sts -> Rule sts ctx ()
tellEvent (AlonzoUtxosEvent era
 -> F (Clause (AlonzoUTXOS era) 'Transition) ())
-> (NonEmpty PlutusWithContext -> AlonzoUtxosEvent era)
-> NonEmpty PlutusWithContext
-> F (Clause (AlonzoUTXOS era) 'Transition) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty PlutusWithContext -> AlonzoUtxosEvent era
forall era. NonEmpty PlutusWithContext -> AlonzoUtxosEvent era
SuccessfulPlutusScriptsEvent) ([PlutusWithContext] -> Maybe (NonEmpty PlutusWithContext)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [PlutusWithContext]
ps)
      Event (AlonzoUTXOS era)
-> F (Clause (AlonzoUTXOS era) 'Transition) ()
forall sts (ctx :: RuleType). Event sts -> Rule sts ctx ()
tellEvent (NonEmpty PlutusWithContext -> AlonzoUtxosEvent era
forall era. NonEmpty PlutusWithContext -> AlonzoUtxosEvent era
FailedPlutusScriptsEvent (ScriptFailure -> PlutusWithContext
scriptFailurePlutus (ScriptFailure -> PlutusWithContext)
-> NonEmpty ScriptFailure -> NonEmpty PlutusWithContext
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty ScriptFailure
fs))

  () <- pure $! Debug.traceEvent invalidEnd ()

  {- utxoKeep = txBody ^. collateralInputsTxBodyL ⋪ utxo -}
  {- utxoDel  = txBody ^. collateralInputsTxBodyL ◁ utxo -}
  let !(utxoKeep, utxoDel) = extractKeys (unUTxO utxo) (txBody ^. collateralInputsTxBodyL)
  pure $!
    utxos
      { utxosUtxo = UTxO utxoKeep
      , utxosFees = fees <> sumAllCoin utxoDel
      , utxosInstantStake = deleteInstantStake (UTxO utxoDel) (utxos ^. instantStakeL)
      }

-- =======================================
-- Names for the events we will tell

validBegin, validEnd, invalidBegin, invalidEnd :: String
validBegin :: [Char]
validBegin = [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"," [[Char]
"[LEDGER][SCRIPTS_VALIDATION]", [Char]
"BEGIN"]
validEnd :: [Char]
validEnd = [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"," [[Char]
"[LEDGER][SCRIPTS_VALIDATION]", [Char]
"END"]
invalidBegin :: [Char]
invalidBegin = [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"," [[Char]
"[LEDGER][SCRIPTS_NOT_VALIDATE_TRANSITION]", [Char]
"BEGIN"]
invalidEnd :: [Char]
invalidEnd = [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"," [[Char]
"[LEDGER][SCRIPTS_NOT_VALIDATE_TRANSITION]", [Char]
"END"]

-- =============================================
-- PredicateFailure data type for AlonzoUTXOS

data FailureDescription
  = PlutusFailure Text BS.ByteString
  deriving (Int -> FailureDescription -> [Char] -> [Char]
[FailureDescription] -> [Char] -> [Char]
FailureDescription -> [Char]
(Int -> FailureDescription -> [Char] -> [Char])
-> (FailureDescription -> [Char])
-> ([FailureDescription] -> [Char] -> [Char])
-> Show FailureDescription
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> FailureDescription -> [Char] -> [Char]
showsPrec :: Int -> FailureDescription -> [Char] -> [Char]
$cshow :: FailureDescription -> [Char]
show :: FailureDescription -> [Char]
$cshowList :: [FailureDescription] -> [Char] -> [Char]
showList :: [FailureDescription] -> [Char] -> [Char]
Show, FailureDescription -> FailureDescription -> Bool
(FailureDescription -> FailureDescription -> Bool)
-> (FailureDescription -> FailureDescription -> Bool)
-> Eq FailureDescription
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FailureDescription -> FailureDescription -> Bool
== :: FailureDescription -> FailureDescription -> Bool
$c/= :: FailureDescription -> FailureDescription -> Bool
/= :: FailureDescription -> FailureDescription -> Bool
Eq, (forall x. FailureDescription -> Rep FailureDescription x)
-> (forall x. Rep FailureDescription x -> FailureDescription)
-> Generic FailureDescription
forall x. Rep FailureDescription x -> FailureDescription
forall x. FailureDescription -> Rep FailureDescription x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. FailureDescription -> Rep FailureDescription x
from :: forall x. FailureDescription -> Rep FailureDescription x
$cto :: forall x. Rep FailureDescription x -> FailureDescription
to :: forall x. Rep FailureDescription x -> FailureDescription
Generic, [[Char]] -> FailureDescription -> IO (Maybe ThunkInfo)
Proxy FailureDescription -> [Char]
([[Char]] -> FailureDescription -> IO (Maybe ThunkInfo))
-> ([[Char]] -> FailureDescription -> IO (Maybe ThunkInfo))
-> (Proxy FailureDescription -> [Char])
-> NoThunks FailureDescription
forall a.
([[Char]] -> a -> IO (Maybe ThunkInfo))
-> ([[Char]] -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> [Char])
-> NoThunks a
$cnoThunks :: [[Char]] -> FailureDescription -> IO (Maybe ThunkInfo)
noThunks :: [[Char]] -> FailureDescription -> IO (Maybe ThunkInfo)
$cwNoThunks :: [[Char]] -> FailureDescription -> IO (Maybe ThunkInfo)
wNoThunks :: [[Char]] -> FailureDescription -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy FailureDescription -> [Char]
showTypeOf :: Proxy FailureDescription -> [Char]
NoThunks)

instance NFData FailureDescription

instance EncCBOR FailureDescription where
  -- This strange encoding results from the fact that 'FailureDescription'
  -- used to have another constructor, which used key 0.
  -- We must maintain the original serialization in order to not disrupt
  -- the node-to-client protocol of the cardano node.
  encCBOR :: FailureDescription -> Encoding
encCBOR (PlutusFailure Text
s ByteString
b) = Encode Open FailureDescription -> Encoding
forall (w :: Wrapped) t. Encode w t -> Encoding
encode (Encode Open FailureDescription -> Encoding)
-> Encode Open FailureDescription -> Encoding
forall a b. (a -> b) -> a -> b
$ (Text -> ByteString -> FailureDescription)
-> Word -> Encode Open (Text -> ByteString -> FailureDescription)
forall t. t -> Word -> Encode Open t
Sum Text -> ByteString -> FailureDescription
PlutusFailure Word
1 Encode Open (Text -> ByteString -> FailureDescription)
-> Encode (Closed Dense) Text
-> Encode Open (ByteString -> FailureDescription)
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode (Closed r) a -> Encode w t
!> Text -> Encode (Closed Dense) Text
forall t. EncCBOR t => t -> Encode (Closed Dense) t
To Text
s Encode Open (ByteString -> FailureDescription)
-> Encode (Closed Dense) ByteString
-> Encode Open FailureDescription
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode (Closed r) a -> Encode w t
!> ByteString -> Encode (Closed Dense) ByteString
forall t. EncCBOR t => t -> Encode (Closed Dense) t
To ByteString
b

instance DecCBOR FailureDescription where
  decCBOR :: forall s. Decoder s FailureDescription
decCBOR = Decode (Closed Dense) FailureDescription
-> Decoder s FailureDescription
forall t (w :: Wrapped) s. Typeable t => Decode w t -> Decoder s t
decode (Decode (Closed Dense) FailureDescription
 -> Decoder s FailureDescription)
-> Decode (Closed Dense) FailureDescription
-> Decoder s FailureDescription
forall a b. (a -> b) -> a -> b
$ Text
-> (Word -> Decode Open FailureDescription)
-> Decode (Closed Dense) FailureDescription
forall t.
Text -> (Word -> Decode Open t) -> Decode (Closed Dense) t
Summands Text
"FailureDescription" ((Word -> Decode Open FailureDescription)
 -> Decode (Closed Dense) FailureDescription)
-> (Word -> Decode Open FailureDescription)
-> Decode (Closed Dense) FailureDescription
forall a b. (a -> b) -> a -> b
$ \case
    -- Note the lack of key 0. See the EncCBOR instance above for an explanation.
    Word
1 -> (Text -> ByteString -> FailureDescription)
-> Decode Open (Text -> ByteString -> FailureDescription)
forall t. t -> Decode Open t
SumD Text -> ByteString -> FailureDescription
PlutusFailure Decode Open (Text -> ByteString -> FailureDescription)
-> Decode (Closed (ZonkAny 7)) Text
-> Decode Open (ByteString -> FailureDescription)
forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode (Closed w) a -> Decode w1 t
<! Decode (Closed (ZonkAny 7)) Text
forall t (w :: Wrapped). DecCBOR t => Decode w t
From Decode Open (ByteString -> FailureDescription)
-> Decode (Closed (ZonkAny 6)) ByteString
-> Decode Open FailureDescription
forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode (Closed w) a -> Decode w1 t
<! Decode (Closed (ZonkAny 6)) ByteString
forall t (w :: Wrapped). DecCBOR t => Decode w t
From
    Word
n -> Word -> Decode Open FailureDescription
forall (w :: Wrapped) t. Word -> Decode w t
Invalid Word
n

instance ToJSON FailureDescription where
  toJSON :: FailureDescription -> Value
toJSON (PlutusFailure Text
t ByteString
_bs) =
    Text -> [Pair] -> Value
kindObject
      Text
"FailureDescription"
      [ Key
"error" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
Aeson.String Text
"PlutusFailure"
      , Key
"description" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
t
      -- Plutus context can be pretty big, therefore it's omitted in JSON
      -- "reconstructionDetail" .= bs
      ]

scriptFailureToFailureDescription :: ScriptFailure -> FailureDescription
scriptFailureToFailureDescription :: ScriptFailure -> FailureDescription
scriptFailureToFailureDescription (ScriptFailure Text
msg PlutusWithContext
pwc) =
  Text -> ByteString -> FailureDescription
PlutusFailure Text
msg (ByteString -> ByteString
B64.encode (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ PlutusWithContext -> ByteString
forall a. ToCBOR a => a -> ByteString
Plain.serialize' PlutusWithContext
pwc)

data TagMismatchDescription
  = PassedUnexpectedly
  | FailedUnexpectedly (NonEmpty FailureDescription)
  deriving (Int -> TagMismatchDescription -> [Char] -> [Char]
[TagMismatchDescription] -> [Char] -> [Char]
TagMismatchDescription -> [Char]
(Int -> TagMismatchDescription -> [Char] -> [Char])
-> (TagMismatchDescription -> [Char])
-> ([TagMismatchDescription] -> [Char] -> [Char])
-> Show TagMismatchDescription
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> TagMismatchDescription -> [Char] -> [Char]
showsPrec :: Int -> TagMismatchDescription -> [Char] -> [Char]
$cshow :: TagMismatchDescription -> [Char]
show :: TagMismatchDescription -> [Char]
$cshowList :: [TagMismatchDescription] -> [Char] -> [Char]
showList :: [TagMismatchDescription] -> [Char] -> [Char]
Show, TagMismatchDescription -> TagMismatchDescription -> Bool
(TagMismatchDescription -> TagMismatchDescription -> Bool)
-> (TagMismatchDescription -> TagMismatchDescription -> Bool)
-> Eq TagMismatchDescription
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TagMismatchDescription -> TagMismatchDescription -> Bool
== :: TagMismatchDescription -> TagMismatchDescription -> Bool
$c/= :: TagMismatchDescription -> TagMismatchDescription -> Bool
/= :: TagMismatchDescription -> TagMismatchDescription -> Bool
Eq, (forall x. TagMismatchDescription -> Rep TagMismatchDescription x)
-> (forall x.
    Rep TagMismatchDescription x -> TagMismatchDescription)
-> Generic TagMismatchDescription
forall x. Rep TagMismatchDescription x -> TagMismatchDescription
forall x. TagMismatchDescription -> Rep TagMismatchDescription x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. TagMismatchDescription -> Rep TagMismatchDescription x
from :: forall x. TagMismatchDescription -> Rep TagMismatchDescription x
$cto :: forall x. Rep TagMismatchDescription x -> TagMismatchDescription
to :: forall x. Rep TagMismatchDescription x -> TagMismatchDescription
Generic, [[Char]] -> TagMismatchDescription -> IO (Maybe ThunkInfo)
Proxy TagMismatchDescription -> [Char]
([[Char]] -> TagMismatchDescription -> IO (Maybe ThunkInfo))
-> ([[Char]] -> TagMismatchDescription -> IO (Maybe ThunkInfo))
-> (Proxy TagMismatchDescription -> [Char])
-> NoThunks TagMismatchDescription
forall a.
([[Char]] -> a -> IO (Maybe ThunkInfo))
-> ([[Char]] -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> [Char])
-> NoThunks a
$cnoThunks :: [[Char]] -> TagMismatchDescription -> IO (Maybe ThunkInfo)
noThunks :: [[Char]] -> TagMismatchDescription -> IO (Maybe ThunkInfo)
$cwNoThunks :: [[Char]] -> TagMismatchDescription -> IO (Maybe ThunkInfo)
wNoThunks :: [[Char]] -> TagMismatchDescription -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy TagMismatchDescription -> [Char]
showTypeOf :: Proxy TagMismatchDescription -> [Char]
NoThunks)

instance NFData TagMismatchDescription

instance EncCBOR TagMismatchDescription where
  encCBOR :: TagMismatchDescription -> Encoding
encCBOR TagMismatchDescription
PassedUnexpectedly = Encode Open TagMismatchDescription -> Encoding
forall (w :: Wrapped) t. Encode w t -> Encoding
encode (TagMismatchDescription
-> Word -> Encode Open TagMismatchDescription
forall t. t -> Word -> Encode Open t
Sum TagMismatchDescription
PassedUnexpectedly Word
0)
  encCBOR (FailedUnexpectedly NonEmpty FailureDescription
fs) = Encode Open TagMismatchDescription -> Encoding
forall (w :: Wrapped) t. Encode w t -> Encoding
encode ((NonEmpty FailureDescription -> TagMismatchDescription)
-> Word
-> Encode
     Open (NonEmpty FailureDescription -> TagMismatchDescription)
forall t. t -> Word -> Encode Open t
Sum NonEmpty FailureDescription -> TagMismatchDescription
FailedUnexpectedly Word
1 Encode Open (NonEmpty FailureDescription -> TagMismatchDescription)
-> Encode (Closed Dense) (NonEmpty FailureDescription)
-> Encode Open TagMismatchDescription
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode (Closed r) a -> Encode w t
!> NonEmpty FailureDescription
-> Encode (Closed Dense) (NonEmpty FailureDescription)
forall t. EncCBOR t => t -> Encode (Closed Dense) t
To NonEmpty FailureDescription
fs)

instance DecCBOR TagMismatchDescription where
  decCBOR :: forall s. Decoder s TagMismatchDescription
decCBOR = Decode (Closed Dense) TagMismatchDescription
-> Decoder s TagMismatchDescription
forall t (w :: Wrapped) s. Typeable t => Decode w t -> Decoder s t
decode (Text
-> (Word -> Decode Open TagMismatchDescription)
-> Decode (Closed Dense) TagMismatchDescription
forall t.
Text -> (Word -> Decode Open t) -> Decode (Closed Dense) t
Summands Text
"TagMismatchDescription" Word -> Decode Open TagMismatchDescription
dec)
    where
      dec :: Word -> Decode Open TagMismatchDescription
dec Word
0 = TagMismatchDescription -> Decode Open TagMismatchDescription
forall t. t -> Decode Open t
SumD TagMismatchDescription
PassedUnexpectedly
      dec Word
1 = (NonEmpty FailureDescription -> TagMismatchDescription)
-> Decode
     Open (NonEmpty FailureDescription -> TagMismatchDescription)
forall t. t -> Decode Open t
SumD NonEmpty FailureDescription -> TagMismatchDescription
FailedUnexpectedly Decode Open (NonEmpty FailureDescription -> TagMismatchDescription)
-> Decode (Closed (ZonkAny 5)) (NonEmpty FailureDescription)
-> Decode Open TagMismatchDescription
forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode (Closed w) a -> Decode w1 t
<! Decode (Closed (ZonkAny 5)) (NonEmpty FailureDescription)
forall t (w :: Wrapped). DecCBOR t => Decode w t
From
      dec Word
n = Word -> Decode Open TagMismatchDescription
forall (w :: Wrapped) t. Word -> Decode w t
Invalid Word
n

instance ToJSON TagMismatchDescription where
  toJSON :: TagMismatchDescription -> Value
toJSON = \case
    TagMismatchDescription
PassedUnexpectedly ->
      Text -> [Pair] -> Value
kindObject
        Text
"TagMismatchDescription"
        [Key
"error" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
Aeson.String Text
"PassedUnexpectedly"]
    FailedUnexpectedly NonEmpty FailureDescription
forReasons ->
      Text -> [Pair] -> Value
kindObject
        Text
"TagMismatchDescription"
        [ Key
"error" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
Aeson.String Text
"FailedUnexpectedly"
        , Key
"reconstruction" Key -> NonEmpty FailureDescription -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= NonEmpty FailureDescription
forReasons
        ]

data AlonzoUtxosPredFailure era
  = -- | The 'isValid' tag on the transaction is incorrect. The tag given
    --   here is that provided on the transaction (whereas evaluation of the
    --   scripts gives the opposite.). The Text tries to explain why it failed.
    ValidationTagMismatch IsValid TagMismatchDescription
  | -- | We could not find all the necessary inputs for a Plutus Script.
    --         Previous PredicateFailure tests should make this impossible, but the
    --         consequences of not detecting this means scripts get dropped, so things
    --         might validate that shouldn't. So we double check in the function
    --         collectTwoPhaseScriptInputs, it should find data for every Script.
    CollectErrors [CollectError era]
  | UpdateFailure (EraRuleFailure "PPUP" era)
  deriving
    ((forall x.
 AlonzoUtxosPredFailure era -> Rep (AlonzoUtxosPredFailure era) x)
-> (forall x.
    Rep (AlonzoUtxosPredFailure era) x -> AlonzoUtxosPredFailure era)
-> Generic (AlonzoUtxosPredFailure era)
forall x.
Rep (AlonzoUtxosPredFailure era) x -> AlonzoUtxosPredFailure era
forall x.
AlonzoUtxosPredFailure era -> Rep (AlonzoUtxosPredFailure era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x.
Rep (AlonzoUtxosPredFailure era) x -> AlonzoUtxosPredFailure era
forall era x.
AlonzoUtxosPredFailure era -> Rep (AlonzoUtxosPredFailure era) x
$cfrom :: forall era x.
AlonzoUtxosPredFailure era -> Rep (AlonzoUtxosPredFailure era) x
from :: forall x.
AlonzoUtxosPredFailure era -> Rep (AlonzoUtxosPredFailure era) x
$cto :: forall era x.
Rep (AlonzoUtxosPredFailure era) x -> AlonzoUtxosPredFailure era
to :: forall x.
Rep (AlonzoUtxosPredFailure era) x -> AlonzoUtxosPredFailure era
Generic)

type instance EraRuleFailure "UTXOS" AlonzoEra = AlonzoUtxosPredFailure AlonzoEra

instance InjectRuleFailure "UTXOS" AlonzoUtxosPredFailure AlonzoEra

instance InjectRuleFailure "UTXOS" ShelleyPpupPredFailure AlonzoEra where
  injectFailure :: ShelleyPpupPredFailure AlonzoEra
-> EraRuleFailure "UTXOS" AlonzoEra
injectFailure = EraRuleFailure "PPUP" AlonzoEra -> AlonzoUtxosPredFailure AlonzoEra
ShelleyPpupPredFailure AlonzoEra
-> EraRuleFailure "UTXOS" AlonzoEra
forall era. EraRuleFailure "PPUP" era -> AlonzoUtxosPredFailure era
UpdateFailure

instance
  ( EraTxCert era
  , AlonzoEraScript era
  , EncCBOR (ContextError era)
  , EncCBOR (EraRuleFailure "PPUP" era)
  ) =>
  EncCBOR (AlonzoUtxosPredFailure era)
  where
  encCBOR :: AlonzoUtxosPredFailure era -> Encoding
encCBOR (ValidationTagMismatch IsValid
v TagMismatchDescription
descr) = Encode Open (AlonzoUtxosPredFailure (ZonkAny 4)) -> Encoding
forall (w :: Wrapped) t. Encode w t -> Encoding
encode ((IsValid
 -> TagMismatchDescription -> AlonzoUtxosPredFailure (ZonkAny 4))
-> Word
-> Encode
     Open
     (IsValid
      -> TagMismatchDescription -> AlonzoUtxosPredFailure (ZonkAny 4))
forall t. t -> Word -> Encode Open t
Sum IsValid
-> TagMismatchDescription -> AlonzoUtxosPredFailure (ZonkAny 4)
forall era.
IsValid -> TagMismatchDescription -> AlonzoUtxosPredFailure era
ValidationTagMismatch Word
0 Encode
  Open
  (IsValid
   -> TagMismatchDescription -> AlonzoUtxosPredFailure (ZonkAny 4))
-> Encode (Closed Dense) IsValid
-> Encode
     Open (TagMismatchDescription -> AlonzoUtxosPredFailure (ZonkAny 4))
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode (Closed r) a -> Encode w t
!> IsValid -> Encode (Closed Dense) IsValid
forall t. EncCBOR t => t -> Encode (Closed Dense) t
To IsValid
v Encode
  Open (TagMismatchDescription -> AlonzoUtxosPredFailure (ZonkAny 4))
-> Encode (Closed Dense) TagMismatchDescription
-> Encode Open (AlonzoUtxosPredFailure (ZonkAny 4))
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode (Closed r) a -> Encode w t
!> TagMismatchDescription
-> Encode (Closed Dense) TagMismatchDescription
forall t. EncCBOR t => t -> Encode (Closed Dense) t
To TagMismatchDescription
descr)
  encCBOR (CollectErrors [CollectError era]
cs) =
    Encode Open (AlonzoUtxosPredFailure era) -> Encoding
forall (w :: Wrapped) t. Encode w t -> Encoding
encode (([CollectError era] -> AlonzoUtxosPredFailure era)
-> Word
-> Encode Open ([CollectError era] -> AlonzoUtxosPredFailure era)
forall t. t -> Word -> Encode Open t
Sum (forall era. [CollectError era] -> AlonzoUtxosPredFailure era
CollectErrors @era) Word
1 Encode Open ([CollectError era] -> AlonzoUtxosPredFailure era)
-> Encode (Closed Dense) [CollectError era]
-> Encode Open (AlonzoUtxosPredFailure era)
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode (Closed r) a -> Encode w t
!> [CollectError era] -> Encode (Closed Dense) [CollectError era]
forall t. EncCBOR t => t -> Encode (Closed Dense) t
To [CollectError era]
cs)
  encCBOR (UpdateFailure EraRuleFailure "PPUP" era
pf) = Encode Open (AlonzoUtxosPredFailure era) -> Encoding
forall (w :: Wrapped) t. Encode w t -> Encoding
encode ((EraRuleFailure "PPUP" era -> AlonzoUtxosPredFailure era)
-> Word
-> Encode
     Open (EraRuleFailure "PPUP" era -> AlonzoUtxosPredFailure era)
forall t. t -> Word -> Encode Open t
Sum (forall era. EraRuleFailure "PPUP" era -> AlonzoUtxosPredFailure era
UpdateFailure @era) Word
2 Encode
  Open (EraRuleFailure "PPUP" era -> AlonzoUtxosPredFailure era)
-> Encode (Closed Dense) (EraRuleFailure "PPUP" era)
-> Encode Open (AlonzoUtxosPredFailure era)
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode (Closed r) a -> Encode w t
!> EraRuleFailure "PPUP" era
-> Encode (Closed Dense) (EraRuleFailure "PPUP" era)
forall t. EncCBOR t => t -> Encode (Closed Dense) t
To EraRuleFailure "PPUP" era
pf)

instance
  ( EraTxCert era
  , AlonzoEraScript era
  , DecCBOR (ContextError era)
  , DecCBOR (EraRuleFailure "PPUP" era)
  ) =>
  DecCBOR (AlonzoUtxosPredFailure era)
  where
  decCBOR :: forall s. Decoder s (AlonzoUtxosPredFailure era)
decCBOR = Decode (Closed Dense) (AlonzoUtxosPredFailure era)
-> Decoder s (AlonzoUtxosPredFailure era)
forall t (w :: Wrapped) s. Typeable t => Decode w t -> Decoder s t
decode (Text
-> (Word -> Decode Open (AlonzoUtxosPredFailure era))
-> Decode (Closed Dense) (AlonzoUtxosPredFailure era)
forall t.
Text -> (Word -> Decode Open t) -> Decode (Closed Dense) t
Summands Text
"AlonzoUtxosPredicateFailure" Word -> Decode Open (AlonzoUtxosPredFailure era)
dec)
    where
      dec :: Word -> Decode Open (AlonzoUtxosPredFailure era)
dec Word
0 = (IsValid -> TagMismatchDescription -> AlonzoUtxosPredFailure era)
-> Decode
     Open
     (IsValid -> TagMismatchDescription -> AlonzoUtxosPredFailure era)
forall t. t -> Decode Open t
SumD IsValid -> TagMismatchDescription -> AlonzoUtxosPredFailure era
forall era.
IsValid -> TagMismatchDescription -> AlonzoUtxosPredFailure era
ValidationTagMismatch Decode
  Open
  (IsValid -> TagMismatchDescription -> AlonzoUtxosPredFailure era)
-> Decode (Closed (ZonkAny 1)) IsValid
-> Decode
     Open (TagMismatchDescription -> AlonzoUtxosPredFailure era)
forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode (Closed w) a -> Decode w1 t
<! Decode (Closed (ZonkAny 1)) IsValid
forall t (w :: Wrapped). DecCBOR t => Decode w t
From Decode Open (TagMismatchDescription -> AlonzoUtxosPredFailure era)
-> Decode (Closed (ZonkAny 0)) TagMismatchDescription
-> Decode Open (AlonzoUtxosPredFailure era)
forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode (Closed w) a -> Decode w1 t
<! Decode (Closed (ZonkAny 0)) TagMismatchDescription
forall t (w :: Wrapped). DecCBOR t => Decode w t
From
      dec Word
1 = ([CollectError era] -> AlonzoUtxosPredFailure era)
-> Decode Open ([CollectError era] -> AlonzoUtxosPredFailure era)
forall t. t -> Decode Open t
SumD (forall era. [CollectError era] -> AlonzoUtxosPredFailure era
CollectErrors @era) Decode Open ([CollectError era] -> AlonzoUtxosPredFailure era)
-> Decode (Closed (ZonkAny 2)) [CollectError era]
-> Decode Open (AlonzoUtxosPredFailure era)
forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode (Closed w) a -> Decode w1 t
<! Decode (Closed (ZonkAny 2)) [CollectError era]
forall t (w :: Wrapped). DecCBOR t => Decode w t
From
      dec Word
2 = (EraRuleFailure "PPUP" era -> AlonzoUtxosPredFailure era)
-> Decode
     Open (EraRuleFailure "PPUP" era -> AlonzoUtxosPredFailure era)
forall t. t -> Decode Open t
SumD EraRuleFailure "PPUP" era -> AlonzoUtxosPredFailure era
forall era. EraRuleFailure "PPUP" era -> AlonzoUtxosPredFailure era
UpdateFailure Decode
  Open (EraRuleFailure "PPUP" era -> AlonzoUtxosPredFailure era)
-> Decode (Closed (ZonkAny 3)) (EraRuleFailure "PPUP" era)
-> Decode Open (AlonzoUtxosPredFailure era)
forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode (Closed w) a -> Decode w1 t
<! Decode (Closed (ZonkAny 3)) (EraRuleFailure "PPUP" era)
forall t (w :: Wrapped). DecCBOR t => Decode w t
From
      dec Word
n = Word -> Decode Open (AlonzoUtxosPredFailure era)
forall (w :: Wrapped) t. Word -> Decode w t
Invalid Word
n

deriving stock instance
  ( AlonzoEraScript era
  , Show (TxCert era)
  , Show (ContextError era)
  , Show (Shelley.UTxOState era)
  , Show (EraRuleFailure "PPUP" era)
  ) =>
  Show (AlonzoUtxosPredFailure era)

deriving stock instance
  ( AlonzoEraScript era
  , Eq (TxCert era)
  , Eq (ContextError era)
  , Eq (Shelley.UTxOState era)
  , Eq (EraRuleFailure "PPUP" era)
  ) =>
  Eq (AlonzoUtxosPredFailure era)

instance
  ( AlonzoEraScript era
  , NoThunks (TxCert era)
  , NoThunks (ContextError era)
  , NoThunks (Shelley.UTxOState era)
  , NoThunks (EraRuleFailure "PPUP" era)
  ) =>
  NoThunks (AlonzoUtxosPredFailure era)

instance
  ( AlonzoEraScript era
  , NFData (TxCert era)
  , NFData (ContextError era)
  , NFData (Shelley.UTxOState era)
  , NFData (EraRuleFailure "PPUP" era)
  ) =>
  NFData (AlonzoUtxosPredFailure era)

--------------------------------------------------------------------------------
-- 2-phase checks
--------------------------------------------------------------------------------

-- $2-phase
--
-- Above and beyond 'static' checks (see 'Cardano.Ledger.Rules.ValidateMode') we
-- additionally label 2-phase checks. This is to support a workflow where we
-- validate a 'AlonzoTx'. We would like to trust the flag we have ourselves just
-- computed rather than re-calculating it. However, all other checks should be
-- computed as normal.

-- | Indicates that this check depends only upon the signal to the transition,
-- not the state or environment.
lbl2Phase :: Label
lbl2Phase :: [Char]
lbl2Phase = [Char]
"2phase"

-- | Construct a 2-phase predicate check.
--
--   Note that 2-phase predicate checks are by definition static.
when2Phase :: Rule sts ctx () -> Rule sts ctx ()
when2Phase :: forall sts (ctx :: RuleType). Rule sts ctx () -> Rule sts ctx ()
when2Phase = NonEmpty [Char] -> Rule sts ctx () -> Rule sts ctx ()
forall sts (ctx :: RuleType).
NonEmpty [Char] -> Rule sts ctx () -> Rule sts ctx ()
labeled (NonEmpty [Char] -> Rule sts ctx () -> Rule sts ctx ())
-> NonEmpty [Char] -> Rule sts ctx () -> Rule sts ctx ()
forall a b. (a -> b) -> a -> b
$ [Char]
lblStatic [Char] -> [[Char]] -> NonEmpty [Char]
forall a. a -> [a] -> NonEmpty a
NE.:| [[Char]
lbl2Phase]