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

module Cardano.Ledger.Alonzo.Rules.Utxos
  ( UTXOS,
    UtxosPredicateFailure (..),
    lbl2Phase,
    TagMismatchDescription (..),
    validBegin,
    validEnd,
    invalidBegin,
    invalidEnd,
    UtxosEvent (..),
    when2Phase,
    ConcreteAlonzo,
    FailureDescription (..),
    scriptFailuresToPredicateFailure,
    scriptFailuresToPlutusDebug,
  )
where

import Cardano.Binary (FromCBOR (..), ToCBOR (..), serialize')
import qualified Cardano.Ledger.Alonzo.PParams as Alonzo
import Cardano.Ledger.Alonzo.PlutusScriptApi
  ( CollectError (..),
    collectTwoPhaseScriptInputs,
    evalScripts,
  )
import Cardano.Ledger.Alonzo.Scripts (CostModels, Script)
import Cardano.Ledger.Alonzo.Tx (IsValid (..), ValidatedTx (..))
import qualified Cardano.Ledger.Alonzo.TxBody as Alonzo
import Cardano.Ledger.Alonzo.TxInfo
  ( ExtendedUTxO (..),
    PlutusDebug,
    ScriptFailure (..),
    ScriptResult (..),
  )
import qualified Cardano.Ledger.Alonzo.TxWitness as Alonzo
import Cardano.Ledger.BaseTypes
  ( Globals,
    ProtVer,
    ShelleyBase,
    epochInfo,
    strictMaybeToMaybe,
    systemStart,
  )
import qualified Cardano.Ledger.Core as Core
import Cardano.Ledger.Era (Crypto, Era, ValidateScript)
import Cardano.Ledger.Mary.Value (Value)
import Cardano.Ledger.Rules.ValidationMode (Inject (..), lblStatic)
import Cardano.Ledger.Shelley.LedgerState
  ( PPUPState (..),
    UTxOState (..),
    keyRefunds,
    updateStakeDistribution,
  )
import qualified Cardano.Ledger.Shelley.LedgerState as Shelley
import Cardano.Ledger.Shelley.PParams (Update)
import Cardano.Ledger.Shelley.Rules.Ppup (PPUP, PPUPEnv (..), PpupPredicateFailure)
import Cardano.Ledger.Shelley.Rules.Utxo (UtxoEnv (..), updateUTxOState)
import Cardano.Ledger.Shelley.TxBody (DCert, Wdrl)
import Cardano.Ledger.Shelley.UTxO (UTxO (..), balance, totalDeposits)
import Cardano.Ledger.ShelleyMA.Timelocks (ValidityInterval)
import Cardano.Ledger.TxIn (TxIn)
import Cardano.Ledger.Val as Val (Val (coin, (<->)))
import Cardano.Slotting.EpochInfo.Extend (unsafeLinearExtendEpochInfo)
import Cardano.Slotting.Slot (SlotNo)
import Control.Monad.Trans.Reader (ReaderT, asks)
import Control.State.Transition.Extended
import Data.ByteString as BS (ByteString)
import qualified Data.ByteString.Base64 as B64
import Data.Coders
import Data.Foldable (toList)
import Data.List (intercalate)
import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as Map
import Data.MapExtras (extractKeys)
import Data.Sequence.Strict (StrictSeq)
import Data.Set (Set)
import Data.Text (Text)
import Debug.Trace (traceEvent)
import GHC.Generics (Generic)
import GHC.Records (HasField (..))
import NoThunks.Class (NoThunks)

--------------------------------------------------------------------------------
-- The UTXOS transition system
--------------------------------------------------------------------------------

type ConcreteAlonzo era =
  ( Core.Script era ~ Script era,
    Core.Value era ~ Value (Crypto era),
    Core.TxBody era ~ Alonzo.TxBody era,
    Core.PParams era ~ Alonzo.PParams era,
    Core.PParamsDelta era ~ Alonzo.PParamsUpdate era,
    Core.TxOut era ~ Alonzo.TxOut era,
    Core.Witnesses era ~ Alonzo.TxWitness era,
    Core.Tx era ~ ValidatedTx era
  )

data UTXOS era

instance
  forall era.
  ( Era era,
    ConcreteAlonzo era,
    ExtendedUTxO era,
    Embed (Core.EraRule "PPUP" era) (UTXOS era),
    Environment (Core.EraRule "PPUP" era) ~ PPUPEnv era,
    State (Core.EraRule "PPUP" era) ~ PPUPState era,
    Signal (Core.EraRule "PPUP" era) ~ Maybe (Update era),
    ValidateScript era,
    ToCBOR (PredicateFailure (Core.EraRule "PPUP" era)) -- Serializing the PredicateFailure
  ) =>
  STS (UTXOS era)
  where
  type BaseM (UTXOS era) = ShelleyBase
  type Environment (UTXOS era) = UtxoEnv era
  type State (UTXOS era) = UTxOState era
  type Signal (UTXOS era) = ValidatedTx era
  type PredicateFailure (UTXOS era) = UtxosPredicateFailure era
  type Event (UTXOS era) = UtxosEvent era
  transitionRules :: [TransitionRule (UTXOS era)]
transitionRules = [TransitionRule (UTXOS era)
forall era.
(ConcreteAlonzo era, ExtendedUTxO era,
 Environment (EraRule "PPUP" era) ~ PPUPEnv era,
 State (EraRule "PPUP" era) ~ PPUPState era,
 Signal (EraRule "PPUP" era) ~ Maybe (Update era),
 Embed (EraRule "PPUP" era) (UTXOS era), ValidateScript era,
 ToCBOR (PredicateFailure (EraRule "PPUP" era))) =>
TransitionRule (UTXOS era)
utxosTransition]

data UtxosEvent era
  = AlonzoPpupToUtxosEvent (Event (Core.EraRule "PPUP" era))
  | SuccessfulPlutusScriptsEvent (NonEmpty PlutusDebug)
  | FailedPlutusScriptsEvent (NonEmpty PlutusDebug)

instance
  ( Era era,
    STS (PPUP era),
    PredicateFailure (Core.EraRule "PPUP" era) ~ PpupPredicateFailure era,
    Event (Core.EraRule "PPUP" era) ~ Event (PPUP era)
  ) =>
  Embed (PPUP era) (UTXOS era)
  where
  wrapFailed :: PredicateFailure (PPUP era) -> PredicateFailure (UTXOS era)
wrapFailed = PredicateFailure (PPUP era) -> PredicateFailure (UTXOS era)
forall era.
PredicateFailure (EraRule "PPUP" era) -> UtxosPredicateFailure era
UpdateFailure
  wrapEvent :: Event (PPUP era) -> Event (UTXOS era)
wrapEvent = Event (PPUP era) -> Event (UTXOS era)
forall era. Event (EraRule "PPUP" era) -> UtxosEvent era
AlonzoPpupToUtxosEvent

utxosTransition ::
  forall era.
  ( ConcreteAlonzo era,
    ExtendedUTxO era,
    Environment (Core.EraRule "PPUP" era) ~ PPUPEnv era,
    State (Core.EraRule "PPUP" era) ~ PPUPState era,
    Signal (Core.EraRule "PPUP" era) ~ Maybe (Update era),
    Embed (Core.EraRule "PPUP" era) (UTXOS era),
    ValidateScript era,
    ToCBOR (PredicateFailure (Core.EraRule "PPUP" era)) -- Serializing the PredicateFailure
  ) =>
  TransitionRule (UTXOS era)
utxosTransition :: TransitionRule (UTXOS era)
utxosTransition =
  F (Clause (UTXOS era) 'Transition) (TRC (UTXOS era))
forall sts (rtype :: RuleType).
Rule sts rtype (RuleContext rtype sts)
judgmentContext F (Clause (UTXOS era) 'Transition) (TRC (UTXOS era))
-> (TRC (UTXOS era)
    -> F (Clause (UTXOS era) 'Transition) (UTxOState era))
-> F (Clause (UTXOS era) 'Transition) (UTxOState era)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(TRC (Environment (UTXOS era)
_, State (UTXOS era)
_, Signal (UTXOS era)
tx)) -> do
    case ValidatedTx era -> IsValid
forall k (x :: k) r a. HasField x r a => r -> a
getField @"isValid" Signal (UTXOS era)
ValidatedTx era
tx of
      IsValid Bool
True -> F (Clause (UTXOS era) 'Transition) (UTxOState era)
forall era.
(ValidateScript era, ConcreteAlonzo era, ExtendedUTxO era,
 STS (UTXOS era), Environment (EraRule "PPUP" era) ~ PPUPEnv era,
 State (EraRule "PPUP" era) ~ PPUPState era,
 Signal (EraRule "PPUP" era) ~ Maybe (Update era),
 Embed (EraRule "PPUP" era) (UTXOS era)) =>
TransitionRule (UTXOS era)
scriptsValidateTransition
      IsValid Bool
False -> F (Clause (UTXOS era) 'Transition) (UTxOState era)
forall era.
(ValidateScript era, ConcreteAlonzo era, ExtendedUTxO era,
 STS (UTXOS era)) =>
TransitionRule (UTXOS era)
scriptsNotValidateTransition

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

scriptsTransition ::
  ( STS sts,
    Monad m,
    ExtendedUTxO era,
    ValidateScript era,
    HasField "_costmdls" (Core.PParams era) CostModels,
    HasField "_protocolVersion" (Core.PParams era) ProtVer,
    HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))),
    HasField "inputs" (Core.TxBody era) (Set (TxIn (Crypto era))),
    HasField "vldt" (Core.TxBody era) ValidityInterval,
    HasField "wdrls" (Core.TxBody era) (Wdrl (Crypto era)),
    HasField "wits" (Core.Tx era) (Alonzo.TxWitness era),
    BaseM sts ~ ReaderT Globals m,
    PredicateFailure sts ~ UtxosPredicateFailure era,
    Core.Script era ~ Script era
  ) =>
  SlotNo ->
  Core.PParams era ->
  Core.Tx era ->
  UTxO era ->
  (ScriptResult -> Rule sts ctx ()) ->
  Rule sts ctx ()
scriptsTransition :: SlotNo
-> PParams era
-> Tx era
-> UTxO era
-> (ScriptResult -> Rule sts ctx ())
-> Rule sts ctx ()
scriptsTransition SlotNo
slot PParams era
pp Tx era
tx UTxO era
utxo ScriptResult -> Rule sts ctx ()
action = do
  SystemStart
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
  EpochInfo (Either Text)
ei <- BaseM sts (EpochInfo (Either Text))
-> Rule sts ctx (EpochInfo (Either Text))
forall sts a (ctx :: RuleType).
STS sts =>
BaseM sts a -> Rule sts ctx a
liftSTS (BaseM sts (EpochInfo (Either Text))
 -> Rule sts ctx (EpochInfo (Either Text)))
-> BaseM sts (EpochInfo (Either Text))
-> Rule sts ctx (EpochInfo (Either Text))
forall a b. (a -> b) -> a -> b
$ (Globals -> EpochInfo (Either Text))
-> ReaderT Globals m (EpochInfo (Either Text))
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Globals -> EpochInfo (Either Text)
epochInfo
  case EpochInfo (Either Text)
-> SystemStart
-> PParams era
-> Tx era
-> UTxO era
-> Either
     [CollectError (Crypto era)]
     [(ShortByteString, Language, [Data era], ExUnits, CostModel)]
forall era.
(Era era, ExtendedUTxO era, Script era ~ Script era,
 HasField "_costmdls" (PParams era) CostModels,
 HasField "wdrls" (TxBody era) (Wdrl (Crypto era)),
 HasField "certs" (TxBody era) (StrictSeq (DCert (Crypto era))),
 HasField "inputs" (TxBody era) (Set (TxIn (Crypto era))),
 HasField "wits" (Tx era) (TxWitness era)) =>
EpochInfo (Either Text)
-> SystemStart
-> PParams era
-> Tx era
-> UTxO era
-> Either
     [CollectError (Crypto era)]
     [(ShortByteString, Language, [Data era], ExUnits, CostModel)]
collectTwoPhaseScriptInputs (SlotNo -> EpochInfo (Either Text) -> EpochInfo (Either Text)
forall (m :: * -> *).
Monad m =>
SlotNo -> EpochInfo m -> EpochInfo m
unsafeLinearExtendEpochInfo SlotNo
slot EpochInfo (Either Text)
ei) SystemStart
sysSt PParams era
pp Tx era
tx UTxO era
utxo of
    Right [(ShortByteString, Language, [Data era], ExUnits, CostModel)]
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
$ ProtVer
-> Tx era
-> [(ShortByteString, Language, [Data era], ExUnits, CostModel)]
-> ScriptResult
forall era tx.
(Era era, Show (Script era), HasField "body" tx (TxBody era),
 HasField "wits" tx (TxWitness era),
 HasField "vldt" (TxBody era) ValidityInterval) =>
ProtVer
-> tx
-> [(ShortByteString, Language, [Data era], ExUnits, CostModel)]
-> ScriptResult
evalScripts (PParams era -> ProtVer
forall k (x :: k) r a. HasField x r a => r -> a
getField @"_protocolVersion" PParams era
pp) Tx era
tx [(ShortByteString, Language, [Data era], ExUnits, CostModel)]
sLst
    Left [CollectError (Crypto era)]
info
      | [CollectError (Crypto era)]
alonzoFailures <- (CollectError (Crypto era) -> Bool)
-> [CollectError (Crypto era)] -> [CollectError (Crypto era)]
forall a. (a -> Bool) -> [a] -> [a]
filter CollectError (Crypto era) -> Bool
forall crypto. CollectError crypto -> Bool
isNotBadTranslation [CollectError (Crypto era)]
info,
        Bool -> Bool
not ([CollectError (Crypto era)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CollectError (Crypto era)]
alonzoFailures) ->
          PredicateFailure sts -> Rule sts ctx ()
forall sts (ctx :: RuleType).
PredicateFailure sts -> Rule sts ctx ()
failBecause ([CollectError (Crypto era)] -> UtxosPredicateFailure era
forall era.
[CollectError (Crypto era)] -> UtxosPredicateFailure era
CollectErrors [CollectError (Crypto era)]
alonzoFailures)
      | Bool
otherwise -> () -> Rule sts ctx ()
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 crypto -> Bool
isNotBadTranslation = \case
      BadTranslation {} -> Bool
False
      CollectError crypto
_ -> Bool
True

scriptsValidateTransition ::
  forall era.
  ( ValidateScript era,
    ConcreteAlonzo era,
    ExtendedUTxO era,
    STS (UTXOS era),
    Environment (Core.EraRule "PPUP" era) ~ PPUPEnv era,
    State (Core.EraRule "PPUP" era) ~ PPUPState era,
    Signal (Core.EraRule "PPUP" era) ~ Maybe (Update era),
    Embed (Core.EraRule "PPUP" era) (UTXOS era)
  ) =>
  TransitionRule (UTXOS era)
scriptsValidateTransition :: TransitionRule (UTXOS era)
scriptsValidateTransition = do
  TRC (UtxoEnv slot pp poolParams genDelegs, u :: State (UTXOS era)
u@(UTxOState utxo _ _ pup _), Signal (UTXOS era)
tx) <-
    F (Clause (UTXOS era) 'Transition) (TRC (UTXOS era))
forall sts (rtype :: RuleType).
Rule sts rtype (RuleContext rtype sts)
judgmentContext
  let txb :: TxBody era
txb = ValidatedTx era -> TxBody era
forall era. ValidatedTx era -> TxBody era
body Signal (UTXOS era)
ValidatedTx era
tx
      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
keyRefunds PParams era
PParams era
pp TxBody era
TxBody era
txb
      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
TxBody era
txb
      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
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))
poolParams) [DCert (Crypto era)]
txcerts Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<-> Coin
refunded

  () <- () -> F (Clause (UTXOS era) 'Transition) ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> F (Clause (UTXOS era) 'Transition) ())
-> () -> F (Clause (UTXOS era) 'Transition) ()
forall a b. (a -> b) -> a -> b
$! String -> () -> ()
forall a. String -> a -> a
traceEvent String
validBegin ()

  SlotNo
-> PParams era
-> Tx era
-> UTxO era
-> (ScriptResult -> F (Clause (UTXOS era) 'Transition) ())
-> F (Clause (UTXOS era) 'Transition) ()
forall sts (m :: * -> *) era (ctx :: RuleType).
(STS sts, Monad m, ExtendedUTxO era, ValidateScript era,
 HasField "_costmdls" (PParams era) CostModels,
 HasField "_protocolVersion" (PParams era) ProtVer,
 HasField "certs" (TxBody era) (StrictSeq (DCert (Crypto era))),
 HasField "inputs" (TxBody era) (Set (TxIn (Crypto era))),
 HasField "vldt" (TxBody era) ValidityInterval,
 HasField "wdrls" (TxBody era) (Wdrl (Crypto era)),
 HasField "wits" (Tx era) (TxWitness era),
 BaseM sts ~ ReaderT Globals m,
 PredicateFailure sts ~ UtxosPredicateFailure era,
 Script era ~ Script era) =>
SlotNo
-> PParams era
-> Tx era
-> UTxO era
-> (ScriptResult -> Rule sts ctx ())
-> Rule sts ctx ()
scriptsTransition SlotNo
slot PParams era
pp Tx era
Signal (UTXOS era)
tx UTxO era
utxo ((ScriptResult -> F (Clause (UTXOS era) 'Transition) ())
 -> F (Clause (UTXOS era) 'Transition) ())
-> (ScriptResult -> F (Clause (UTXOS era) 'Transition) ())
-> F (Clause (UTXOS era) 'Transition) ()
forall a b. (a -> b) -> a -> b
$ \case
    Fails [PlutusDebug]
_ps NonEmpty ScriptFailure
fs ->
      PredicateFailure (UTXOS era)
-> F (Clause (UTXOS era) 'Transition) ()
forall sts (ctx :: RuleType).
PredicateFailure sts -> Rule sts ctx ()
failBecause (PredicateFailure (UTXOS era)
 -> F (Clause (UTXOS era) 'Transition) ())
-> PredicateFailure (UTXOS era)
-> F (Clause (UTXOS era) 'Transition) ()
forall a b. (a -> b) -> a -> b
$
        IsValid -> TagMismatchDescription -> UtxosPredicateFailure era
forall era.
IsValid -> TagMismatchDescription -> UtxosPredicateFailure era
ValidationTagMismatch
          (ValidatedTx era -> IsValid
forall k (x :: k) r a. HasField x r a => r -> a
getField @"isValid" Signal (UTXOS era)
ValidatedTx era
tx)
          (NonEmpty FailureDescription -> TagMismatchDescription
FailedUnexpectedly (NonEmpty ScriptFailure -> NonEmpty FailureDescription
scriptFailuresToPredicateFailure NonEmpty ScriptFailure
fs))
    Passes [PlutusDebug]
ps -> (NonEmpty PlutusDebug -> F (Clause (UTXOS era) 'Transition) ())
-> Maybe (NonEmpty PlutusDebug)
-> F (Clause (UTXOS era) 'Transition) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (UtxosEvent era -> F (Clause (UTXOS era) 'Transition) ()
forall sts (ctx :: RuleType). Event sts -> Rule sts ctx ()
tellEvent (UtxosEvent era -> F (Clause (UTXOS era) 'Transition) ())
-> (NonEmpty PlutusDebug -> UtxosEvent era)
-> NonEmpty PlutusDebug
-> F (Clause (UTXOS era) 'Transition) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty PlutusDebug -> UtxosEvent era
forall era. NonEmpty PlutusDebug -> UtxosEvent era
SuccessfulPlutusScriptsEvent) ([PlutusDebug] -> Maybe (NonEmpty PlutusDebug)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [PlutusDebug]
ps)

  () <- () -> F (Clause (UTXOS era) 'Transition) ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> F (Clause (UTXOS era) 'Transition) ())
-> () -> F (Clause (UTXOS era) 'Transition) ()
forall a b. (a -> b) -> a -> b
$! String -> () -> ()
forall a. String -> a -> a
traceEvent String
validEnd ()

  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 (UTXOS era) 'Transition (State (EraRule "PPUP" era)))
-> RuleContext 'Transition (EraRule "PPUP" era)
-> Rule (UTXOS 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)
pup, StrictMaybe (Update era) -> Maybe (Update era)
forall a. StrictMaybe a -> Maybe a
strictMaybeToMaybe (StrictMaybe (Update era) -> Maybe (Update era))
-> StrictMaybe (Update era) -> Maybe (Update era)
forall a b. (a -> b) -> a -> b
$ TxBody era -> StrictMaybe (Update era)
forall k (x :: k) r a. HasField x r a => r -> a
getField @"update" TxBody era
TxBody era
txb)

  UTxOState era -> F (Clause (UTXOS era) 'Transition) (UTxOState era)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UTxOState era
 -> F (Clause (UTXOS era) 'Transition) (UTxOState era))
-> UTxOState era
-> F (Clause (UTXOS 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
updateUTxOState UTxOState era
State (UTXOS era)
u TxBody era
txb Coin
depositChange PPUPState era
State (EraRule "PPUP" era)
ppup'

scriptsNotValidateTransition ::
  forall era.
  ( ValidateScript era,
    ConcreteAlonzo era,
    ExtendedUTxO era,
    STS (UTXOS era)
  ) =>
  TransitionRule (UTXOS era)
scriptsNotValidateTransition :: TransitionRule (UTXOS era)
scriptsNotValidateTransition = do
  TRC (UtxoEnv slot pp _ _, us :: State (UTXOS era)
us@(UTxOState utxo _ fees _ _), Signal (UTXOS era)
tx) <- F (Clause (UTXOS era) 'Transition) (TRC (UTXOS era))
forall sts (rtype :: RuleType).
Rule sts rtype (RuleContext rtype sts)
judgmentContext
  let txb :: TxBody era
txb = ValidatedTx era -> TxBody era
forall era. ValidatedTx era -> TxBody era
body Signal (UTXOS era)
ValidatedTx era
tx

  let !()
_ = String -> () -> ()
forall a. String -> a -> a
traceEvent String
invalidBegin ()

  SlotNo
-> PParams era
-> Tx era
-> UTxO era
-> (ScriptResult -> Rule (UTXOS era) 'Transition ())
-> Rule (UTXOS era) 'Transition ()
forall sts (m :: * -> *) era (ctx :: RuleType).
(STS sts, Monad m, ExtendedUTxO era, ValidateScript era,
 HasField "_costmdls" (PParams era) CostModels,
 HasField "_protocolVersion" (PParams era) ProtVer,
 HasField "certs" (TxBody era) (StrictSeq (DCert (Crypto era))),
 HasField "inputs" (TxBody era) (Set (TxIn (Crypto era))),
 HasField "vldt" (TxBody era) ValidityInterval,
 HasField "wdrls" (TxBody era) (Wdrl (Crypto era)),
 HasField "wits" (Tx era) (TxWitness era),
 BaseM sts ~ ReaderT Globals m,
 PredicateFailure sts ~ UtxosPredicateFailure era,
 Script era ~ Script era) =>
SlotNo
-> PParams era
-> Tx era
-> UTxO era
-> (ScriptResult -> Rule sts ctx ())
-> Rule sts ctx ()
scriptsTransition SlotNo
slot PParams era
pp Tx era
Signal (UTXOS era)
tx UTxO era
utxo ((ScriptResult -> Rule (UTXOS era) 'Transition ())
 -> Rule (UTXOS era) 'Transition ())
-> (ScriptResult -> Rule (UTXOS era) 'Transition ())
-> Rule (UTXOS era) 'Transition ()
forall a b. (a -> b) -> a -> b
$ \case
    Passes [PlutusDebug]
_ps ->
      PredicateFailure (UTXOS era) -> Rule (UTXOS era) 'Transition ()
forall sts (ctx :: RuleType).
PredicateFailure sts -> Rule sts ctx ()
failBecause (PredicateFailure (UTXOS era) -> Rule (UTXOS era) 'Transition ())
-> PredicateFailure (UTXOS era) -> Rule (UTXOS era) 'Transition ()
forall a b. (a -> b) -> a -> b
$
        IsValid -> TagMismatchDescription -> UtxosPredicateFailure era
forall era.
IsValid -> TagMismatchDescription -> UtxosPredicateFailure era
ValidationTagMismatch (ValidatedTx era -> IsValid
forall k (x :: k) r a. HasField x r a => r -> a
getField @"isValid" Signal (UTXOS era)
ValidatedTx era
tx) TagMismatchDescription
PassedUnexpectedly
    Fails [PlutusDebug]
ps NonEmpty ScriptFailure
fs -> do
      (NonEmpty PlutusDebug -> Rule (UTXOS era) 'Transition ())
-> Maybe (NonEmpty PlutusDebug) -> Rule (UTXOS era) 'Transition ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (UtxosEvent era -> Rule (UTXOS era) 'Transition ()
forall sts (ctx :: RuleType). Event sts -> Rule sts ctx ()
tellEvent (UtxosEvent era -> Rule (UTXOS era) 'Transition ())
-> (NonEmpty PlutusDebug -> UtxosEvent era)
-> NonEmpty PlutusDebug
-> Rule (UTXOS era) 'Transition ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty PlutusDebug -> UtxosEvent era
forall era. NonEmpty PlutusDebug -> UtxosEvent era
SuccessfulPlutusScriptsEvent) ([PlutusDebug] -> Maybe (NonEmpty PlutusDebug)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [PlutusDebug]
ps)
      Event (UTXOS era) -> Rule (UTXOS era) 'Transition ()
forall sts (ctx :: RuleType). Event sts -> Rule sts ctx ()
tellEvent (NonEmpty PlutusDebug -> UtxosEvent era
forall era. NonEmpty PlutusDebug -> UtxosEvent era
FailedPlutusScriptsEvent (NonEmpty ScriptFailure -> NonEmpty PlutusDebug
scriptFailuresToPlutusDebug NonEmpty ScriptFailure
fs))

  let !()
_ = String -> () -> ()
forall a. String -> a -> a
traceEvent String
invalidEnd ()

      {- utxoKeep = getField @"collateral" txb ⋪ utxo -}
      {- utxoDel  = getField @"collateral" txb ◁ utxo -}
      !(Map (TxIn (Crypto era)) (TxOut era)
utxoKeep, Map (TxIn (Crypto era)) (TxOut era)
utxoDel) = Map (TxIn (Crypto era)) (TxOut era)
-> Set (TxIn (Crypto era))
-> (Map (TxIn (Crypto era)) (TxOut era),
    Map (TxIn (Crypto era)) (TxOut era))
forall k a. Ord k => Map k a -> Set k -> (Map k a, Map k a)
extractKeys (UTxO era -> Map (TxIn (Crypto era)) (TxOut era)
forall era. UTxO era -> Map (TxIn (Crypto era)) (TxOut era)
unUTxO UTxO era
utxo) (TxBody era -> Set (TxIn (Crypto era))
forall k (x :: k) r a. HasField x r a => r -> a
getField @"collateral" TxBody era
TxBody era
txb)
  UTxOState era -> F (Clause (UTXOS era) 'Transition) (UTxOState era)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (UTxOState era
 -> F (Clause (UTXOS era) 'Transition) (UTxOState era))
-> UTxOState era
-> F (Clause (UTXOS era) 'Transition) (UTxOState era)
forall a b. (a -> b) -> a -> b
$! UTxOState era
State (UTXOS era)
us
      { _utxo :: UTxO era
_utxo = Map (TxIn (Crypto era)) (TxOut era) -> UTxO era
forall era. Map (TxIn (Crypto era)) (TxOut era) -> UTxO era
UTxO Map (TxIn (Crypto era)) (TxOut era)
Map (TxIn (Crypto era)) (TxOut era)
utxoKeep,
        _fees :: Coin
_fees = Coin
fees Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> Value (Crypto era) -> Coin
forall t. Val t => t -> Coin
Val.coin (UTxO era -> Value era
forall era. Era era => UTxO era -> Value era
balance (Map (TxIn (Crypto era)) (TxOut era) -> UTxO era
forall era. Map (TxIn (Crypto era)) (TxOut era) -> UTxO era
UTxO Map (TxIn (Crypto era)) (TxOut era)
Map (TxIn (Crypto era)) (TxOut era)
utxoDel)),
        _stakeDistro :: IncrementalStake (Crypto era)
_stakeDistro = IncrementalStake (Crypto era)
-> UTxO era -> UTxO era -> IncrementalStake (Crypto era)
forall era.
Era era =>
IncrementalStake (Crypto era)
-> UTxO era -> UTxO era -> IncrementalStake (Crypto era)
updateStakeDistribution (UTxOState era -> IncrementalStake (Crypto era)
forall era. UTxOState era -> IncrementalStake (Crypto era)
_stakeDistro UTxOState era
State (UTXOS era)
us) (Map (TxIn (Crypto era)) (TxOut era) -> UTxO era
forall era. Map (TxIn (Crypto era)) (TxOut era) -> UTxO era
UTxO Map (TxIn (Crypto era)) (TxOut era)
Map (TxIn (Crypto era)) (TxOut era)
utxoDel) UTxO era
forall a. Monoid a => a
mempty
      }

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

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

-- =============================================
-- PredicateFailure data type for UTXOS

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

instance ToCBOR 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.
  toCBOR :: FailureDescription -> Encoding
toCBOR (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. ToCBOR 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. ToCBOR t => t -> Encode ('Closed 'Dense) t
To ByteString
b

instance FromCBOR FailureDescription where
  fromCBOR :: Decoder s FailureDescription
fromCBOR = Decode ('Closed 'Dense) FailureDescription
-> Decoder s FailureDescription
forall (w :: Wrapped) t s. Decode w t -> Decoder s t
decode (String
-> (Word -> Decode 'Open FailureDescription)
-> Decode ('Closed 'Dense) FailureDescription
forall t.
String -> (Word -> Decode 'Open t) -> Decode ('Closed 'Dense) t
Summands String
"FailureDescription" Word -> Decode 'Open FailureDescription
dec)
    where
      -- Note the lack of key 0. See the ToCBOR instance above for an explanation.
      dec :: Word -> Decode 'Open FailureDescription
dec 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 Any) Text
-> Decode 'Open (ByteString -> FailureDescription)
forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! Decode ('Closed Any) Text
forall t (w :: Wrapped). FromCBOR t => Decode w t
From Decode 'Open (ByteString -> FailureDescription)
-> Decode ('Closed Any) ByteString
-> Decode 'Open FailureDescription
forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! Decode ('Closed Any) ByteString
forall t (w :: Wrapped). FromCBOR t => Decode w t
From
      dec Word
n = Word -> Decode 'Open FailureDescription
forall (w :: Wrapped) t. Word -> Decode w t
Invalid Word
n

scriptFailureToFailureDescription :: ScriptFailure -> FailureDescription
scriptFailureToFailureDescription :: ScriptFailure -> FailureDescription
scriptFailureToFailureDescription (PlutusSF Text
t PlutusDebug
pd) =
  Text -> ByteString -> FailureDescription
PlutusFailure Text
t (ByteString -> ByteString
B64.encode (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ PlutusDebug -> ByteString
forall a. ToCBOR a => a -> ByteString
serialize' PlutusDebug
pd)

scriptFailuresToPredicateFailure :: NonEmpty ScriptFailure -> NonEmpty FailureDescription
scriptFailuresToPredicateFailure :: NonEmpty ScriptFailure -> NonEmpty FailureDescription
scriptFailuresToPredicateFailure = (ScriptFailure -> FailureDescription)
-> NonEmpty ScriptFailure -> NonEmpty FailureDescription
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ScriptFailure -> FailureDescription
scriptFailureToFailureDescription

scriptFailuresToPlutusDebug :: NonEmpty ScriptFailure -> NonEmpty PlutusDebug
scriptFailuresToPlutusDebug :: NonEmpty ScriptFailure -> NonEmpty PlutusDebug
scriptFailuresToPlutusDebug = (ScriptFailure -> PlutusDebug)
-> NonEmpty ScriptFailure -> NonEmpty PlutusDebug
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(PlutusSF Text
_ PlutusDebug
pdb) -> PlutusDebug
pdb)

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

instance ToCBOR TagMismatchDescription where
  toCBOR :: TagMismatchDescription -> Encoding
toCBOR 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)
  toCBOR (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. ToCBOR t => t -> Encode ('Closed 'Dense) t
To NonEmpty FailureDescription
fs)

instance FromCBOR TagMismatchDescription where
  fromCBOR :: Decoder s TagMismatchDescription
fromCBOR = Decode ('Closed 'Dense) TagMismatchDescription
-> Decoder s TagMismatchDescription
forall (w :: Wrapped) t s. Decode w t -> Decoder s t
decode (String
-> (Word -> Decode 'Open TagMismatchDescription)
-> Decode ('Closed 'Dense) TagMismatchDescription
forall t.
String -> (Word -> Decode 'Open t) -> Decode ('Closed 'Dense) t
Summands String
"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 Any) (NonEmpty FailureDescription)
-> Decode 'Open TagMismatchDescription
forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! Decode ('Closed Any) (NonEmpty FailureDescription)
forall t (w :: Wrapped). FromCBOR t => Decode w t
From
      dec Word
n = Word -> Decode 'Open TagMismatchDescription
forall (w :: Wrapped) t. Word -> Decode w t
Invalid Word
n

data UtxosPredicateFailure 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 (Crypto era)]
  | UpdateFailure (PredicateFailure (Core.EraRule "PPUP" era))
  deriving
    ((forall x.
 UtxosPredicateFailure era -> Rep (UtxosPredicateFailure era) x)
-> (forall x.
    Rep (UtxosPredicateFailure era) x -> UtxosPredicateFailure era)
-> Generic (UtxosPredicateFailure era)
forall x.
Rep (UtxosPredicateFailure era) x -> UtxosPredicateFailure era
forall x.
UtxosPredicateFailure era -> Rep (UtxosPredicateFailure era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x.
Rep (UtxosPredicateFailure era) x -> UtxosPredicateFailure era
forall era x.
UtxosPredicateFailure era -> Rep (UtxosPredicateFailure era) x
$cto :: forall era x.
Rep (UtxosPredicateFailure era) x -> UtxosPredicateFailure era
$cfrom :: forall era x.
UtxosPredicateFailure era -> Rep (UtxosPredicateFailure era) x
Generic)

instance
  ( Era era,
    ToCBOR (PredicateFailure (Core.EraRule "PPUP" era)),
    Show (Core.TxOut era)
  ) =>
  ToCBOR (UtxosPredicateFailure era)
  where
  toCBOR :: UtxosPredicateFailure era -> Encoding
toCBOR (ValidationTagMismatch IsValid
v TagMismatchDescription
descr) = Encode 'Open (UtxosPredicateFailure Any) -> Encoding
forall (w :: Wrapped) t. Encode w t -> Encoding
encode ((IsValid -> TagMismatchDescription -> UtxosPredicateFailure Any)
-> Word
-> Encode
     'Open
     (IsValid -> TagMismatchDescription -> UtxosPredicateFailure Any)
forall t. t -> Word -> Encode 'Open t
Sum IsValid -> TagMismatchDescription -> UtxosPredicateFailure Any
forall era.
IsValid -> TagMismatchDescription -> UtxosPredicateFailure era
ValidationTagMismatch Word
0 Encode
  'Open
  (IsValid -> TagMismatchDescription -> UtxosPredicateFailure Any)
-> Encode ('Closed 'Dense) IsValid
-> Encode
     'Open (TagMismatchDescription -> UtxosPredicateFailure Any)
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. ToCBOR t => t -> Encode ('Closed 'Dense) t
To IsValid
v Encode 'Open (TagMismatchDescription -> UtxosPredicateFailure Any)
-> Encode ('Closed 'Dense) TagMismatchDescription
-> Encode 'Open (UtxosPredicateFailure Any)
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. ToCBOR t => t -> Encode ('Closed 'Dense) t
To TagMismatchDescription
descr)
  toCBOR (CollectErrors [CollectError (Crypto era)]
cs) =
    Encode 'Open (UtxosPredicateFailure era) -> Encoding
forall (w :: Wrapped) t. Encode w t -> Encoding
encode (([CollectError (Crypto era)] -> UtxosPredicateFailure era)
-> Word
-> Encode
     'Open ([CollectError (Crypto era)] -> UtxosPredicateFailure era)
forall t. t -> Word -> Encode 'Open t
Sum ([CollectError (Crypto era)] -> UtxosPredicateFailure era
forall era.
[CollectError (Crypto era)] -> UtxosPredicateFailure era
CollectErrors @era) Word
1 Encode
  'Open ([CollectError (Crypto era)] -> UtxosPredicateFailure era)
-> Encode ('Closed 'Dense) [CollectError (Crypto era)]
-> Encode 'Open (UtxosPredicateFailure era)
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> [CollectError (Crypto era)]
-> Encode ('Closed 'Dense) [CollectError (Crypto era)]
forall t. ToCBOR t => t -> Encode ('Closed 'Dense) t
To [CollectError (Crypto era)]
cs)
  toCBOR (UpdateFailure PredicateFailure (EraRule "PPUP" era)
pf) = Encode 'Open (UtxosPredicateFailure era) -> Encoding
forall (w :: Wrapped) t. Encode w t -> Encoding
encode ((PredicateFailure (EraRule "PPUP" era)
 -> UtxosPredicateFailure era)
-> Word
-> Encode
     'Open
     (PredicateFailure (EraRule "PPUP" era)
      -> UtxosPredicateFailure era)
forall t. t -> Word -> Encode 'Open t
Sum (PredicateFailure (EraRule "PPUP" era) -> UtxosPredicateFailure era
forall era.
PredicateFailure (EraRule "PPUP" era) -> UtxosPredicateFailure era
UpdateFailure @era) Word
2 Encode
  'Open
  (PredicateFailure (EraRule "PPUP" era)
   -> UtxosPredicateFailure era)
-> Encode ('Closed 'Dense) (PredicateFailure (EraRule "PPUP" era))
-> Encode 'Open (UtxosPredicateFailure era)
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> PredicateFailure (EraRule "PPUP" era)
-> Encode ('Closed 'Dense) (PredicateFailure (EraRule "PPUP" era))
forall t. ToCBOR t => t -> Encode ('Closed 'Dense) t
To PredicateFailure (EraRule "PPUP" era)
pf)

instance
  ( Era era,
    FromCBOR (PredicateFailure (Core.EraRule "PPUP" era))
  ) =>
  FromCBOR (UtxosPredicateFailure era)
  where
  fromCBOR :: Decoder s (UtxosPredicateFailure era)
fromCBOR = Decode ('Closed 'Dense) (UtxosPredicateFailure era)
-> Decoder s (UtxosPredicateFailure era)
forall (w :: Wrapped) t s. Decode w t -> Decoder s t
decode (String
-> (Word -> Decode 'Open (UtxosPredicateFailure era))
-> Decode ('Closed 'Dense) (UtxosPredicateFailure era)
forall t.
String -> (Word -> Decode 'Open t) -> Decode ('Closed 'Dense) t
Summands String
"UtxosPredicateFailure" Word -> Decode 'Open (UtxosPredicateFailure era)
dec)
    where
      dec :: Word -> Decode 'Open (UtxosPredicateFailure era)
dec Word
0 = (IsValid -> TagMismatchDescription -> UtxosPredicateFailure era)
-> Decode
     'Open
     (IsValid -> TagMismatchDescription -> UtxosPredicateFailure era)
forall t. t -> Decode 'Open t
SumD IsValid -> TagMismatchDescription -> UtxosPredicateFailure era
forall era.
IsValid -> TagMismatchDescription -> UtxosPredicateFailure era
ValidationTagMismatch Decode
  'Open
  (IsValid -> TagMismatchDescription -> UtxosPredicateFailure era)
-> Decode ('Closed Any) IsValid
-> Decode
     'Open (TagMismatchDescription -> UtxosPredicateFailure era)
forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! Decode ('Closed Any) IsValid
forall t (w :: Wrapped). FromCBOR t => Decode w t
From Decode 'Open (TagMismatchDescription -> UtxosPredicateFailure era)
-> Decode ('Closed Any) TagMismatchDescription
-> Decode 'Open (UtxosPredicateFailure era)
forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! Decode ('Closed Any) TagMismatchDescription
forall t (w :: Wrapped). FromCBOR t => Decode w t
From
      dec Word
1 = ([CollectError (Crypto era)] -> UtxosPredicateFailure era)
-> Decode
     'Open ([CollectError (Crypto era)] -> UtxosPredicateFailure era)
forall t. t -> Decode 'Open t
SumD ([CollectError (Crypto era)] -> UtxosPredicateFailure era
forall era.
[CollectError (Crypto era)] -> UtxosPredicateFailure era
CollectErrors @era) Decode
  'Open ([CollectError (Crypto era)] -> UtxosPredicateFailure era)
-> Decode ('Closed Any) [CollectError (Crypto era)]
-> Decode 'Open (UtxosPredicateFailure era)
forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! Decode ('Closed Any) [CollectError (Crypto era)]
forall t (w :: Wrapped). FromCBOR t => Decode w t
From
      dec Word
2 = (PredicateFailure (EraRule "PPUP" era)
 -> UtxosPredicateFailure era)
-> Decode
     'Open
     (PredicateFailure (EraRule "PPUP" era)
      -> UtxosPredicateFailure era)
forall t. t -> Decode 'Open t
SumD PredicateFailure (EraRule "PPUP" era) -> UtxosPredicateFailure era
forall era.
PredicateFailure (EraRule "PPUP" era) -> UtxosPredicateFailure era
UpdateFailure Decode
  'Open
  (PredicateFailure (EraRule "PPUP" era)
   -> UtxosPredicateFailure era)
-> Decode ('Closed Any) (PredicateFailure (EraRule "PPUP" era))
-> Decode 'Open (UtxosPredicateFailure era)
forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! Decode ('Closed Any) (PredicateFailure (EraRule "PPUP" era))
forall t (w :: Wrapped). FromCBOR t => Decode w t
From
      dec Word
n = Word -> Decode 'Open (UtxosPredicateFailure era)
forall (w :: Wrapped) t. Word -> Decode w t
Invalid Word
n

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

instance
  ( Eq (Shelley.UTxOState era),
    Eq (PredicateFailure (Core.EraRule "PPUP" era))
  ) =>
  Eq (UtxosPredicateFailure era)
  where
  (ValidationTagMismatch IsValid
a TagMismatchDescription
x) == :: UtxosPredicateFailure era -> UtxosPredicateFailure era -> Bool
== (ValidationTagMismatch IsValid
b TagMismatchDescription
y) = IsValid
a IsValid -> IsValid -> Bool
forall a. Eq a => a -> a -> Bool
== IsValid
b Bool -> Bool -> Bool
&& TagMismatchDescription
x TagMismatchDescription -> TagMismatchDescription -> Bool
forall a. Eq a => a -> a -> Bool
== TagMismatchDescription
y
  (CollectErrors [CollectError (Crypto era)]
x) == (CollectErrors [CollectError (Crypto era)]
y) = [CollectError (Crypto era)]
x [CollectError (Crypto era)] -> [CollectError (Crypto era)] -> Bool
forall a. Eq a => a -> a -> Bool
== [CollectError (Crypto era)]
y
  (UpdateFailure PredicateFailure (EraRule "PPUP" era)
x) == (UpdateFailure PredicateFailure (EraRule "PPUP" era)
y) = PredicateFailure (EraRule "PPUP" era)
x PredicateFailure (EraRule "PPUP" era)
-> PredicateFailure (EraRule "PPUP" era) -> Bool
forall a. Eq a => a -> a -> Bool
== PredicateFailure (EraRule "PPUP" era)
y
  UtxosPredicateFailure era
_ == UtxosPredicateFailure era
_ = Bool
False

instance
  ( NoThunks (Shelley.UTxOState era),
    NoThunks (PredicateFailure (Core.EraRule "PPUP" era))
  ) =>
  NoThunks (UtxosPredicateFailure 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 'ValidatedTx'. 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 :: String
lbl2Phase = String
"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 :: Rule sts ctx () -> Rule sts ctx ()
when2Phase = NonEmpty String -> Rule sts ctx () -> Rule sts ctx ()
forall sts (ctx :: RuleType).
NonEmpty String -> Rule sts ctx () -> Rule sts ctx ()
labeled (NonEmpty String -> Rule sts ctx () -> Rule sts ctx ())
-> NonEmpty String -> Rule sts ctx () -> Rule sts ctx ()
forall a b. (a -> b) -> a -> b
$ String
lblStatic String -> [String] -> NonEmpty String
forall a. a -> [a] -> NonEmpty a
NE.:| [String
lbl2Phase]

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

instance
  PredicateFailure (Core.EraRule "PPUP" era) ~ PpupPredicateFailure era =>
  Inject (PpupPredicateFailure era) (UtxosPredicateFailure era)
  where
  inject :: PpupPredicateFailure era -> UtxosPredicateFailure era
inject = PpupPredicateFailure era -> UtxosPredicateFailure era
forall era.
PredicateFailure (EraRule "PPUP" era) -> UtxosPredicateFailure era
UpdateFailure

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