{-# LANGUAGE DataKinds          #-}
{-# LANGUAGE GADTs              #-}
{-# LANGUAGE NamedFieldPuns     #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE TemplateHaskell    #-}
{-# LANGUAGE TupleSections      #-}
{-# LANGUAGE TypeApplications   #-}
{-# LANGUAGE ViewPatterns       #-}

{-| Transaction validation using 'cardano-ledger-specs'
-}
module Cardano.Node.Emulator.Validation(
  EmulatorBlock,
  EmulatedLedgerState(..),
  Coin(..),
  SlotNo(..),
  EmulatorEra,
  CardanoLedgerError,
  initialState,
  hasValidationErrors,
  makeTransactionBody,
  validateCardanoTx,
  -- * Modifying the state
  makeBlock,
  setSlot,
  nextSlot,
  UTxO(..),
  setUtxo,
  -- * Lenses
  ledgerEnv,
  memPoolState,
  currentBlock,
  previousBlocks,
  -- * Etc.
  emulatorGlobals,
  ) where

import Cardano.Api.Shelley qualified as C.Api
import Cardano.Ledger.Alonzo.PlutusScriptApi (collectTwoPhaseScriptInputs, evalScripts)
import Cardano.Ledger.Alonzo.Rules.Utxos (UtxosPredicateFailure (CollectErrors))
import Cardano.Ledger.Alonzo.Scripts (CostModels, Script, unCostModels)
import Cardano.Ledger.Alonzo.Tools qualified as C.Ledger
import Cardano.Ledger.Alonzo.Tx (ValidatedTx (..))
import Cardano.Ledger.Alonzo.TxInfo (ExtendedUTxO (..), ScriptResult (..))
import Cardano.Ledger.Alonzo.TxWitness qualified as Alonzo
import Cardano.Ledger.Babbage.PParams (PParams' (..))
import Cardano.Ledger.Babbage.Tx (IsValid (..))
import Cardano.Ledger.BaseTypes (Globals (..), ProtVer, epochInfo)
import Cardano.Ledger.Core (Tx)
import Cardano.Ledger.Core qualified as Core
import Cardano.Ledger.Era (Crypto, ValidateScript)
import Cardano.Ledger.Shelley.API (Coin (..), LedgerEnv (..), MempoolEnv, MempoolState, TxIn, UTxO (UTxO), Validated)
import Cardano.Ledger.Shelley.API qualified as C.Ledger
import Cardano.Ledger.Shelley.LedgerState (LedgerState (..), UTxOState (..), smartUTxOState)
import Cardano.Ledger.Shelley.Rules.Utxo (UtxoEnv (..))
import Cardano.Ledger.Shelley.TxBody (DCert, Wdrl)
import Cardano.Ledger.ShelleyMA.Timelocks (ValidityInterval)
import Cardano.Node.Emulator.Params (EmulatorEra, Params (emulatorPParams), emulatorGlobals, emulatorPParams)
import Cardano.Slotting.Slot (SlotNo (..))
import Control.Lens (makeLenses, over, (&), (.~), (^.))
import Control.Monad.Except (MonadError (throwError))
import Data.Array (array)
import Data.Bifunctor (Bifunctor (..))
import Data.Default (def)
import Data.Map qualified as Map
import Data.Sequence.Strict (StrictSeq)
import Data.Set (Set)
import Data.Text qualified as Text
import GHC.Records (HasField (..))
import Ledger.Index.Internal qualified as P
import Ledger.Slot (Slot)
import Ledger.Tx (CardanoTx (CardanoEmulatorEraTx))
import Ledger.Tx.CardanoAPI qualified as P
import Plutus.V1.Ledger.Api qualified as V1 hiding (TxOut (..))
import Plutus.V1.Ledger.Scripts qualified as P

type CardanoLedgerError = Either P.ValidationErrorInPhase P.ToCardanoError

type EmulatorBlock = [Validated (Tx EmulatorEra)]

{- Note [Emulated ledger]

In the real cardano node, there two types of validation: Transaction validation
(performed when a transaction is first added to the mempool) and block
validation (performed when a block is created by the local node or received
from a peer).

Transaction validation runs the Plutus scripts, checks cryptographic
signatures, balances, existence of transaction inputs and so forth. This is
where the ledger state is updated. Block validation performs other checks
related to the consensus algorithm.

Networking and consensus issues are not part of the emulator's scope. We only
care about transaction validation here, so we don't have to worry about block
validation.

The decision to leave out block validation and consensus-related concerns has
the following implications:

1. We can represent blocks as simple lists-of-transactions
2. We can modify time (the slot number) and ledger parameters as we wish,
   without having to post transactions that modify them.

There are also some limitations of the emulator's functionality that could be
addressed by extending the emulator, without having to bring in the full block
validating machinery.

* We cannot represent different eras - everything is 'BabbageEra'.
* There is no handling of epoch boundaries, rewards, etc.
* The block size is unlimited - we simply take all transactions from the
  mempool when we make a block. There is however a limit on the size of
  individual transactions.
* We use the standard ledger cryptography everywhere ('StandardCrypto').
  This could be replaced by "NoCrypto" for faster validation.

-}

{-| State of the ledger with configuration, mempool, and the blockchain.
-}
data EmulatedLedgerState =
  EmulatedLedgerState
    { EmulatedLedgerState -> MempoolEnv EmulatorEra
_ledgerEnv      :: MempoolEnv EmulatorEra
    , EmulatedLedgerState -> MempoolState EmulatorEra
_memPoolState   :: MempoolState EmulatorEra
    , EmulatedLedgerState -> EmulatorBlock
_currentBlock   :: EmulatorBlock
    , EmulatedLedgerState -> [EmulatorBlock]
_previousBlocks :: [EmulatorBlock]
    }
    deriving Int -> EmulatedLedgerState -> ShowS
[EmulatedLedgerState] -> ShowS
EmulatedLedgerState -> String
(Int -> EmulatedLedgerState -> ShowS)
-> (EmulatedLedgerState -> String)
-> ([EmulatedLedgerState] -> ShowS)
-> Show EmulatedLedgerState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EmulatedLedgerState] -> ShowS
$cshowList :: [EmulatedLedgerState] -> ShowS
show :: EmulatedLedgerState -> String
$cshow :: EmulatedLedgerState -> String
showsPrec :: Int -> EmulatedLedgerState -> ShowS
$cshowsPrec :: Int -> EmulatedLedgerState -> ShowS
Show

makeLenses ''EmulatedLedgerState

{-| Increase the slot number by one
-}
nextSlot :: EmulatedLedgerState -> EmulatedLedgerState
nextSlot :: EmulatedLedgerState -> EmulatedLedgerState
nextSlot = ASetter
  EmulatedLedgerState
  EmulatedLedgerState
  (MempoolEnv EmulatorEra)
  (MempoolEnv EmulatorEra)
-> (MempoolEnv EmulatorEra -> MempoolEnv EmulatorEra)
-> EmulatedLedgerState
-> EmulatedLedgerState
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter
  EmulatedLedgerState
  EmulatedLedgerState
  (MempoolEnv EmulatorEra)
  (MempoolEnv EmulatorEra)
Lens' EmulatedLedgerState (MempoolEnv EmulatorEra)
ledgerEnv MempoolEnv EmulatorEra -> MempoolEnv EmulatorEra
forall era. LedgerEnv era -> LedgerEnv era
f where
  f :: LedgerEnv era -> LedgerEnv era
f l :: LedgerEnv era
l@LedgerEnv{ledgerSlotNo :: forall era. LedgerEnv era -> SlotNo
ledgerSlotNo=SlotNo
oldSlot} = LedgerEnv era
l{ledgerSlotNo :: SlotNo
ledgerSlotNo = SlotNo -> SlotNo
forall a. Enum a => a -> a
succ SlotNo
oldSlot}

{-| Set the slot number
-}
setSlot :: SlotNo -> EmulatedLedgerState -> EmulatedLedgerState
setSlot :: SlotNo -> EmulatedLedgerState -> EmulatedLedgerState
setSlot SlotNo
sl = ASetter
  EmulatedLedgerState
  EmulatedLedgerState
  (MempoolEnv EmulatorEra)
  (MempoolEnv EmulatorEra)
-> (MempoolEnv EmulatorEra -> MempoolEnv EmulatorEra)
-> EmulatedLedgerState
-> EmulatedLedgerState
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter
  EmulatedLedgerState
  EmulatedLedgerState
  (MempoolEnv EmulatorEra)
  (MempoolEnv EmulatorEra)
Lens' EmulatedLedgerState (MempoolEnv EmulatorEra)
ledgerEnv (\MempoolEnv EmulatorEra
l -> MempoolEnv EmulatorEra
l{ledgerSlotNo :: SlotNo
ledgerSlotNo=SlotNo
sl})

{-| Set the utxo
-}
setUtxo :: UTxO EmulatorEra -> EmulatedLedgerState -> EmulatedLedgerState
setUtxo :: UTxO EmulatorEra -> EmulatedLedgerState -> EmulatedLedgerState
setUtxo UTxO EmulatorEra
utxo els :: EmulatedLedgerState
els@EmulatedLedgerState{MempoolState EmulatorEra
_memPoolState :: MempoolState EmulatorEra
_memPoolState :: EmulatedLedgerState -> MempoolState EmulatorEra
_memPoolState} = EmulatedLedgerState
els { _memPoolState :: MempoolState EmulatorEra
_memPoolState = MempoolState EmulatorEra
newPoolState }
  where
    newPoolState :: MempoolState EmulatorEra
newPoolState = MempoolState EmulatorEra
_memPoolState { lsUTxOState :: UTxOState EmulatorEra
lsUTxOState = UTxO EmulatorEra
-> Coin
-> Coin
-> State (EraRule "PPUP" EmulatorEra)
-> UTxOState EmulatorEra
forall era.
Era era =>
UTxO era
-> Coin -> Coin -> State (EraRule "PPUP" era) -> UTxOState era
smartUTxOState UTxO EmulatorEra
utxo (Integer -> Coin
Coin Integer
0) (Integer -> Coin
Coin Integer
0) State (EraRule "PPUP" EmulatorEra)
forall a. Default a => a
def }

{-| Make a block with all transactions that have been validated in the
current block, add the block to the blockchain, and empty the current block.
-}
makeBlock :: EmulatedLedgerState -> EmulatedLedgerState
makeBlock :: EmulatedLedgerState -> EmulatedLedgerState
makeBlock EmulatedLedgerState
state =
  EmulatedLedgerState
state
    EmulatedLedgerState
-> (EmulatedLedgerState -> EmulatedLedgerState)
-> EmulatedLedgerState
forall a b. a -> (a -> b) -> b
& ([Validated (ValidatedTx EmulatorEra)]
 -> Identity [Validated (ValidatedTx EmulatorEra)])
-> EmulatedLedgerState -> Identity EmulatedLedgerState
Lens' EmulatedLedgerState EmulatorBlock
currentBlock (([Validated (ValidatedTx EmulatorEra)]
  -> Identity [Validated (ValidatedTx EmulatorEra)])
 -> EmulatedLedgerState -> Identity EmulatedLedgerState)
-> [Validated (ValidatedTx EmulatorEra)]
-> EmulatedLedgerState
-> EmulatedLedgerState
forall s t a b. ASetter s t a b -> b -> s -> t
.~ []
    EmulatedLedgerState
-> (EmulatedLedgerState -> EmulatedLedgerState)
-> EmulatedLedgerState
forall a b. a -> (a -> b) -> b
& ASetter
  EmulatedLedgerState
  EmulatedLedgerState
  [[Validated (ValidatedTx EmulatorEra)]]
  [[Validated (ValidatedTx EmulatorEra)]]
-> ([[Validated (ValidatedTx EmulatorEra)]]
    -> [[Validated (ValidatedTx EmulatorEra)]])
-> EmulatedLedgerState
-> EmulatedLedgerState
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter
  EmulatedLedgerState
  EmulatedLedgerState
  [[Validated (ValidatedTx EmulatorEra)]]
  [[Validated (ValidatedTx EmulatorEra)]]
Lens' EmulatedLedgerState [EmulatorBlock]
previousBlocks ((:) ([Validated (ValidatedTx EmulatorEra)]
-> [Validated (ValidatedTx EmulatorEra)]
forall a. [a] -> [a]
reverse ([Validated (ValidatedTx EmulatorEra)]
 -> [Validated (ValidatedTx EmulatorEra)])
-> [Validated (ValidatedTx EmulatorEra)]
-> [Validated (ValidatedTx EmulatorEra)]
forall a b. (a -> b) -> a -> b
$ EmulatedLedgerState
state EmulatedLedgerState
-> Getting
     [Validated (ValidatedTx EmulatorEra)]
     EmulatedLedgerState
     [Validated (ValidatedTx EmulatorEra)]
-> [Validated (ValidatedTx EmulatorEra)]
forall s a. s -> Getting a s a -> a
^. Getting
  [Validated (ValidatedTx EmulatorEra)]
  EmulatedLedgerState
  [Validated (ValidatedTx EmulatorEra)]
Lens' EmulatedLedgerState EmulatorBlock
currentBlock))

{-| Initial ledger state for a distribution
-}
initialState :: Params -> EmulatedLedgerState
initialState :: Params -> EmulatedLedgerState
initialState Params
params = EmulatedLedgerState :: MempoolEnv EmulatorEra
-> MempoolState EmulatorEra
-> EmulatorBlock
-> [EmulatorBlock]
-> EmulatedLedgerState
EmulatedLedgerState
  { _ledgerEnv :: MempoolEnv EmulatorEra
_ledgerEnv = LedgerEnv :: forall era.
SlotNo -> TxIx -> PParams era -> AccountState -> LedgerEnv era
C.Ledger.LedgerEnv
      { ledgerSlotNo :: SlotNo
C.Ledger.ledgerSlotNo = SlotNo
0
      , ledgerIx :: TxIx
C.Ledger.ledgerIx = TxIx
forall a. Bounded a => a
minBound
      , ledgerPp :: PParams EmulatorEra
C.Ledger.ledgerPp = Params -> PParams
emulatorPParams Params
params
      , ledgerAccount :: AccountState
C.Ledger.ledgerAccount = Coin -> Coin -> AccountState
C.Ledger.AccountState (Integer -> Coin
Coin Integer
0) (Integer -> Coin
Coin Integer
0)
      }
  , _memPoolState :: MempoolState EmulatorEra
_memPoolState = LedgerState :: forall era.
UTxOState era -> DPState (Crypto era) -> LedgerState era
LedgerState
    { lsUTxOState :: UTxOState EmulatorEra
lsUTxOState = UTxO EmulatorEra
-> Coin
-> Coin
-> State (EraRule "PPUP" EmulatorEra)
-> UTxOState EmulatorEra
forall era.
Era era =>
UTxO era
-> Coin -> Coin -> State (EraRule "PPUP" era) -> UTxOState era
smartUTxOState (Map (TxIn (Crypto EmulatorEra)) (TxOut EmulatorEra)
-> UTxO EmulatorEra
forall era. Map (TxIn (Crypto era)) (TxOut era) -> UTxO era
UTxO Map (TxIn (Crypto EmulatorEra)) (TxOut EmulatorEra)
forall a. Monoid a => a
mempty) (Integer -> Coin
Coin Integer
0) (Integer -> Coin
Coin Integer
0) State (EraRule "PPUP" EmulatorEra)
forall a. Default a => a
def
    , lsDPState :: DPState (Crypto EmulatorEra)
lsDPState = DState StandardCrypto
-> PState StandardCrypto -> DPState StandardCrypto
forall crypto. DState crypto -> PState crypto -> DPState crypto
C.Ledger.DPState DState StandardCrypto
forall a. Default a => a
def PState StandardCrypto
forall a. Default a => a
def
    }
  , _currentBlock :: EmulatorBlock
_currentBlock = []
  , _previousBlocks :: [EmulatorBlock]
_previousBlocks = []
  }


utxoEnv :: Params -> SlotNo -> C.Ledger.UtxoEnv EmulatorEra
utxoEnv :: Params -> SlotNo -> UtxoEnv EmulatorEra
utxoEnv Params
params SlotNo
slotNo = SlotNo
-> PParams EmulatorEra
-> Map
     (KeyHash 'StakePool (Crypto EmulatorEra))
     (PoolParams (Crypto EmulatorEra))
-> GenDelegs (Crypto EmulatorEra)
-> UtxoEnv EmulatorEra
forall era.
SlotNo
-> PParams era
-> Map (KeyHash 'StakePool (Crypto era)) (PoolParams (Crypto era))
-> GenDelegs (Crypto era)
-> UtxoEnv era
C.Ledger.UtxoEnv SlotNo
slotNo (Params -> PParams
emulatorPParams Params
params) Map
  (KeyHash 'StakePool (Crypto EmulatorEra))
  (PoolParams (Crypto EmulatorEra))
forall a. Monoid a => a
mempty (Map (KeyHash 'Genesis StandardCrypto) (GenDelegPair StandardCrypto)
-> GenDelegs StandardCrypto
forall crypto.
Map (KeyHash 'Genesis crypto) (GenDelegPair crypto)
-> GenDelegs crypto
C.Ledger.GenDelegs Map (KeyHash 'Genesis StandardCrypto) (GenDelegPair StandardCrypto)
forall a. Monoid a => a
mempty)

applyTx ::
  Params ->
  EmulatedLedgerState ->
  Tx EmulatorEra ->
  Either P.ValidationError (EmulatedLedgerState, Validated (Tx EmulatorEra))
applyTx :: Params
-> EmulatedLedgerState
-> Tx EmulatorEra
-> Either
     ValidationError (EmulatedLedgerState, Validated (Tx EmulatorEra))
applyTx Params
params oldState :: EmulatedLedgerState
oldState@EmulatedLedgerState{MempoolEnv EmulatorEra
_ledgerEnv :: MempoolEnv EmulatorEra
_ledgerEnv :: EmulatedLedgerState -> MempoolEnv EmulatorEra
_ledgerEnv, MempoolState EmulatorEra
_memPoolState :: MempoolState EmulatorEra
_memPoolState :: EmulatedLedgerState -> MempoolState EmulatorEra
_memPoolState} Tx EmulatorEra
tx = do
  (MempoolState EmulatorEra
newMempool, Validated (ValidatedTx EmulatorEra)
vtx) <- (ApplyTxError EmulatorEra -> ValidationError)
-> Either
     (ApplyTxError EmulatorEra)
     (MempoolState EmulatorEra, Validated (ValidatedTx EmulatorEra))
-> Either
     ValidationError
     (MempoolState EmulatorEra, Validated (ValidatedTx EmulatorEra))
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Text -> ValidationError
P.CardanoLedgerValidationError (Text -> ValidationError)
-> (ApplyTxError EmulatorEra -> Text)
-> ApplyTxError EmulatorEra
-> ValidationError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack (String -> Text)
-> (ApplyTxError EmulatorEra -> String)
-> ApplyTxError EmulatorEra
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ApplyTxError EmulatorEra -> String
forall a. Show a => a -> String
show) (Globals
-> MempoolEnv EmulatorEra
-> MempoolState EmulatorEra
-> Tx EmulatorEra
-> Either
     (ApplyTxError EmulatorEra)
     (MempoolState EmulatorEra, Validated (Tx EmulatorEra))
forall era (m :: * -> *).
(ApplyTx era, MonadError (ApplyTxError era) m) =>
Globals
-> MempoolEnv era
-> MempoolState era
-> Tx era
-> m (MempoolState era, Validated (Tx era))
C.Ledger.applyTx (Params -> Globals
emulatorGlobals Params
params) MempoolEnv EmulatorEra
_ledgerEnv MempoolState EmulatorEra
_memPoolState Tx EmulatorEra
tx)
  (EmulatedLedgerState, Validated (ValidatedTx EmulatorEra))
-> Either
     ValidationError
     (EmulatedLedgerState, Validated (ValidatedTx EmulatorEra))
forall (m :: * -> *) a. Monad m => a -> m a
return (EmulatedLedgerState
oldState EmulatedLedgerState
-> (EmulatedLedgerState -> EmulatedLedgerState)
-> EmulatedLedgerState
forall a b. a -> (a -> b) -> b
& (MempoolState EmulatorEra -> Identity (MempoolState EmulatorEra))
-> EmulatedLedgerState -> Identity EmulatedLedgerState
Lens' EmulatedLedgerState (MempoolState EmulatorEra)
memPoolState ((MempoolState EmulatorEra -> Identity (MempoolState EmulatorEra))
 -> EmulatedLedgerState -> Identity EmulatedLedgerState)
-> MempoolState EmulatorEra
-> EmulatedLedgerState
-> EmulatedLedgerState
forall s t a b. ASetter s t a b -> b -> s -> t
.~ MempoolState EmulatorEra
newMempool EmulatedLedgerState
-> (EmulatedLedgerState -> EmulatedLedgerState)
-> EmulatedLedgerState
forall a b. a -> (a -> b) -> b
& (([Validated (ValidatedTx EmulatorEra)]
  -> Identity [Validated (ValidatedTx EmulatorEra)])
 -> EmulatedLedgerState -> Identity EmulatedLedgerState)
-> ([Validated (ValidatedTx EmulatorEra)]
    -> [Validated (ValidatedTx EmulatorEra)])
-> EmulatedLedgerState
-> EmulatedLedgerState
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ([Validated (ValidatedTx EmulatorEra)]
 -> Identity [Validated (ValidatedTx EmulatorEra)])
-> EmulatedLedgerState -> Identity EmulatedLedgerState
Lens' EmulatedLedgerState EmulatorBlock
currentBlock ((:) Validated (ValidatedTx EmulatorEra)
vtx), Validated (ValidatedTx EmulatorEra)
vtx)


hasValidationErrors :: Params -> SlotNo -> UTxO EmulatorEra -> C.Api.Tx C.Api.BabbageEra -> Either P.ValidationErrorInPhase P.ValidationSuccess
hasValidationErrors :: Params
-> SlotNo
-> UTxO EmulatorEra
-> Tx BabbageEra
-> Either ValidationErrorInPhase ValidationSuccess
hasValidationErrors Params
params SlotNo
slotNo UTxO EmulatorEra
utxo tx' :: Tx BabbageEra
tx'@(C.Api.ShelleyTx ShelleyBasedEra BabbageEra
_ Tx (ShelleyLedgerEra BabbageEra)
tx) =
  case Either
  ValidationError
  (EmulatedLedgerState, Validated (ValidatedTx EmulatorEra))
res of
    Left ValidationError
e  -> ValidationErrorInPhase
-> Either ValidationErrorInPhase ValidationSuccess
forall a b. a -> Either a b
Left (ValidationPhase
P.Phase1, ValidationError
e)
    Right (EmulatedLedgerState, Validated (ValidatedTx EmulatorEra))
_ -> Params
-> UTxO EmulatorEra
-> Tx BabbageEra
-> Either ValidationErrorInPhase ValidationSuccess
getTxExUnitsWithLogs Params
params UTxO EmulatorEra
utxo Tx BabbageEra
tx'
  where
    state :: EmulatedLedgerState
state = SlotNo -> EmulatedLedgerState -> EmulatedLedgerState
setSlot SlotNo
slotNo (EmulatedLedgerState -> EmulatedLedgerState)
-> EmulatedLedgerState -> EmulatedLedgerState
forall a b. (a -> b) -> a -> b
$ UTxO EmulatorEra -> EmulatedLedgerState -> EmulatedLedgerState
setUtxo UTxO EmulatorEra
utxo (EmulatedLedgerState -> EmulatedLedgerState)
-> EmulatedLedgerState -> EmulatedLedgerState
forall a b. (a -> b) -> a -> b
$ Params -> EmulatedLedgerState
initialState Params
params
    res :: Either
  ValidationError
  (EmulatedLedgerState, Validated (ValidatedTx EmulatorEra))
res = do
      ValidatedTx EmulatorEra
vtx <- ([UtxosPredicateFailure EmulatorEra] -> ValidationError)
-> Either
     [UtxosPredicateFailure EmulatorEra] (ValidatedTx EmulatorEra)
-> Either ValidationError (ValidatedTx EmulatorEra)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Text -> ValidationError
P.CardanoLedgerValidationError (Text -> ValidationError)
-> ([UtxosPredicateFailure EmulatorEra] -> Text)
-> [UtxosPredicateFailure EmulatorEra]
-> ValidationError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack (String -> Text)
-> ([UtxosPredicateFailure EmulatorEra] -> String)
-> [UtxosPredicateFailure EmulatorEra]
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [UtxosPredicateFailure EmulatorEra] -> String
forall a. Show a => a -> String
show) (Globals
-> UtxoEnv EmulatorEra
-> UTxOState EmulatorEra
-> Tx EmulatorEra
-> Either
     [UtxosPredicateFailure EmulatorEra] (ValidatedTx EmulatorEra)
forall era (m :: * -> *).
(MonadError [UtxosPredicateFailure era] m, Script era ~ Script era,
 Witnesses era ~ TxWitness era, ValidateScript era,
 HasField "inputs" (TxBody era) (Set (TxIn (Crypto era))),
 HasField "certs" (TxBody era) (StrictSeq (DCert (Crypto era))),
 HasField "_costmdls" (PParams era) CostModels,
 HasField "_protocolVersion" (PParams era) ProtVer,
 HasField "wdrls" (TxBody era) (Wdrl (Crypto era)),
 HasField "vldt" (TxBody era) ValidityInterval, ExtendedUTxO era) =>
Globals
-> UtxoEnv era -> UTxOState era -> Tx era -> m (ValidatedTx era)
constructValidated (Params -> Globals
emulatorGlobals Params
params) (Params -> SlotNo -> UtxoEnv EmulatorEra
utxoEnv Params
params SlotNo
slotNo) (MempoolState EmulatorEra -> UTxOState EmulatorEra
forall era. LedgerState era -> UTxOState era
lsUTxOState (EmulatedLedgerState -> MempoolState EmulatorEra
_memPoolState EmulatedLedgerState
state)) Tx (ShelleyLedgerEra BabbageEra)
Tx EmulatorEra
tx)
      Params
-> EmulatedLedgerState
-> Tx EmulatorEra
-> Either
     ValidationError (EmulatedLedgerState, Validated (Tx EmulatorEra))
applyTx Params
params EmulatedLedgerState
state Tx EmulatorEra
ValidatedTx EmulatorEra
vtx

-- | Construct a 'ValidatedTx' from a 'Core.Tx' by setting the `IsValid`
-- flag.
--
-- Note that this simply constructs the transaction; it does not validate
-- anything other than the scripts. Thus the resulting transaction may be
-- completely invalid.
--
-- Copied from cardano-ledger as it was removed there
-- in https://github.com/input-output-hk/cardano-ledger/commit/721adb55b39885847562437a6fe7e998f8e48c03
constructValidated ::
  forall era m.
  ( MonadError [UtxosPredicateFailure era] m,
    Core.Script era ~ Script era,
    Core.Witnesses era ~ Alonzo.TxWitness era,
    ValidateScript era,
    HasField "inputs" (Core.TxBody era) (Set (TxIn (Crypto era))),
    HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))),
    HasField "_costmdls" (Core.PParams era) CostModels,
    HasField "_protocolVersion" (Core.PParams era) ProtVer,
    HasField "wdrls" (Core.TxBody era) (Wdrl (Crypto era)),
    HasField "vldt" (Core.TxBody era) ValidityInterval,
    ExtendedUTxO era
  ) =>
  Globals ->
  UtxoEnv era ->
  UTxOState era ->
  Core.Tx era ->
  m (ValidatedTx era)
constructValidated :: Globals
-> UtxoEnv era -> UTxOState era -> Tx era -> m (ValidatedTx era)
constructValidated Globals
globals (UtxoEnv SlotNo
_ PParams era
pp Map (KeyHash 'StakePool (Crypto era)) (PoolParams (Crypto era))
_ GenDelegs (Crypto era)
_) UTxOState era
st Tx era
tx =
  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 EpochInfo (Either Text)
ei SystemStart
sysS PParams era
pp Tx era
tx UTxO era
utxo of
    Left [CollectError (Crypto era)]
errs -> [UtxosPredicateFailure era] -> m (ValidatedTx era)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError [[CollectError (Crypto era)] -> UtxosPredicateFailure era
forall era.
[CollectError (Crypto era)] -> UtxosPredicateFailure era
CollectErrors [CollectError (Crypto era)]
errs]
    Right [(ShortByteString, Language, [Data era], ExUnits, CostModel)]
sLst ->
      let scriptEvalResult :: ScriptResult
scriptEvalResult = 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 @era (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
          vTx :: ValidatedTx era
vTx =
            TxBody era
-> TxWitness era
-> IsValid
-> StrictMaybe (AuxiliaryData era)
-> ValidatedTx era
forall era.
TxBody era
-> TxWitness era
-> IsValid
-> StrictMaybe (AuxiliaryData era)
-> ValidatedTx era
ValidatedTx
              (Tx era -> TxBody era
forall k (x :: k) r a. HasField x r a => r -> a
getField @"body" Tx era
tx)
              (Tx era -> TxWitness era
forall k (x :: k) r a. HasField x r a => r -> a
getField @"wits" Tx era
tx)
              (Bool -> IsValid
IsValid (ScriptResult -> Bool
lift ScriptResult
scriptEvalResult))
              (Tx era -> StrictMaybe (AuxiliaryData era)
forall k (x :: k) r a. HasField x r a => r -> a
getField @"auxiliaryData" Tx era
tx)
       in ValidatedTx era -> m (ValidatedTx era)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ValidatedTx era
vTx
  where
    utxo :: UTxO era
utxo = UTxOState era -> UTxO era
forall era. UTxOState era -> UTxO era
_utxo UTxOState era
st
    sysS :: SystemStart
sysS = Globals -> SystemStart
systemStart Globals
globals
    ei :: EpochInfo (Either Text)
ei = Globals -> EpochInfo (Either Text)
epochInfo Globals
globals
    lift :: ScriptResult -> Bool
lift (Passes [PlutusDebug]
_)  = Bool
True
    lift (Fails [PlutusDebug]
_ NonEmpty ScriptFailure
_) = Bool
False

validateCardanoTx
  :: Params
  -> Slot
  -> UTxO EmulatorEra
  -> CardanoTx
  -> Either P.ValidationErrorInPhase P.ValidationSuccess
validateCardanoTx :: Params
-> Slot
-> UTxO EmulatorEra
-> CardanoTx
-> Either ValidationErrorInPhase ValidationSuccess
validateCardanoTx Params
params Slot
slot utxo :: UTxO EmulatorEra
utxo@(UTxO Map (TxIn (Crypto EmulatorEra)) (TxOut EmulatorEra)
utxoMap) (CardanoEmulatorEraTx Tx BabbageEra
tx) =
  if Map (TxIn StandardCrypto) (TxOut EmulatorEra) -> Bool
forall k a. Map k a -> Bool
Map.null Map (TxIn StandardCrypto) (TxOut EmulatorEra)
Map (TxIn (Crypto EmulatorEra)) (TxOut EmulatorEra)
utxoMap then ValidationSuccess
-> Either ValidationErrorInPhase ValidationSuccess
forall a b. b -> Either a b
Right ValidationSuccess
forall k a. Map k a
Map.empty else
    Params
-> SlotNo
-> UTxO EmulatorEra
-> Tx BabbageEra
-> Either ValidationErrorInPhase ValidationSuccess
hasValidationErrors Params
params (Slot -> SlotNo
forall a b. (Integral a, Num b) => a -> b
fromIntegral Slot
slot) UTxO EmulatorEra
utxo Tx BabbageEra
tx

getTxExUnitsWithLogs :: Params -> UTxO EmulatorEra -> C.Api.Tx C.Api.BabbageEra -> Either P.ValidationErrorInPhase P.ValidationSuccess
getTxExUnitsWithLogs :: Params
-> UTxO EmulatorEra
-> Tx BabbageEra
-> Either ValidationErrorInPhase ValidationSuccess
getTxExUnitsWithLogs Params
params UTxO EmulatorEra
utxo (C.Api.ShelleyTx ShelleyBasedEra BabbageEra
_ Tx (ShelleyLedgerEra BabbageEra)
tx) =
  case PParams EmulatorEra
-> Tx EmulatorEra
-> UTxO EmulatorEra
-> EpochInfo (Either Text)
-> SystemStart
-> Array Language CostModel
-> Either
     (TranslationError (Crypto EmulatorEra))
     (RedeemerReportWithLogs (Crypto EmulatorEra))
forall era.
(Era era, ExtendedUTxO era,
 HasField "inputs" (TxBody era) (Set (TxIn (Crypto era))),
 HasField "certs" (TxBody era) (StrictSeq (DCert (Crypto era))),
 HasField "wdrls" (TxBody era) (Wdrl (Crypto era)),
 HasField "txdats" (Witnesses era) (TxDats era),
 HasField "txrdmrs" (Witnesses era) (Redeemers era),
 HasField "_maxTxExUnits" (PParams era) ExUnits,
 HasField "_protocolVersion" (PParams era) ProtVer,
 Script era ~ Script era) =>
PParams era
-> Tx era
-> UTxO era
-> EpochInfo (Either Text)
-> SystemStart
-> Array Language CostModel
-> Either
     (TranslationError (Crypto era))
     (RedeemerReportWithLogs (Crypto era))
C.Ledger.evaluateTransactionExecutionUnitsWithLogs (Params -> PParams
emulatorPParams Params
params) Tx (ShelleyLedgerEra BabbageEra)
Tx EmulatorEra
tx UTxO EmulatorEra
utxo EpochInfo (Either Text)
ei SystemStart
ss Array Language CostModel
costmdls of
    Left TranslationError (Crypto EmulatorEra)
e       -> ValidationErrorInPhase
-> Either ValidationErrorInPhase ValidationSuccess
forall a b. a -> Either a b
Left (ValidationErrorInPhase
 -> Either ValidationErrorInPhase ValidationSuccess)
-> (TranslationError StandardCrypto -> ValidationErrorInPhase)
-> TranslationError StandardCrypto
-> Either ValidationErrorInPhase ValidationSuccess
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ValidationPhase
P.Phase1,) (ValidationError -> ValidationErrorInPhase)
-> (TranslationError StandardCrypto -> ValidationError)
-> TranslationError StandardCrypto
-> ValidationErrorInPhase
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ValidationError
P.CardanoLedgerValidationError (Text -> ValidationError)
-> (TranslationError StandardCrypto -> Text)
-> TranslationError StandardCrypto
-> ValidationError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack (String -> Text)
-> (TranslationError StandardCrypto -> String)
-> TranslationError StandardCrypto
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TranslationError StandardCrypto -> String
forall a. Show a => a -> String
show (TranslationError StandardCrypto
 -> Either ValidationErrorInPhase ValidationSuccess)
-> TranslationError StandardCrypto
-> Either ValidationErrorInPhase ValidationSuccess
forall a b. (a -> b) -> a -> b
$ TranslationError StandardCrypto
TranslationError (Crypto EmulatorEra)
e
    Right RedeemerReportWithLogs (Crypto EmulatorEra)
result -> (Either (TransactionScriptFailure StandardCrypto) ([Text], ExUnits)
 -> Either ValidationErrorInPhase ([Text], ExUnits))
-> Map
     RdmrPtr
     (Either
        (TransactionScriptFailure StandardCrypto) ([Text], ExUnits))
-> Either ValidationErrorInPhase ValidationSuccess
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((TransactionScriptFailure StandardCrypto
 -> Either ValidationErrorInPhase ([Text], ExUnits))
-> (([Text], ExUnits)
    -> Either ValidationErrorInPhase ([Text], ExUnits))
-> Either
     (TransactionScriptFailure StandardCrypto) ([Text], ExUnits)
-> Either ValidationErrorInPhase ([Text], ExUnits)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either TransactionScriptFailure StandardCrypto
-> Either ValidationErrorInPhase ([Text], ExUnits)
forall c b.
TransactionScriptFailure c -> Either ValidationErrorInPhase b
toCardanoLedgerError ([Text], ExUnits)
-> Either ValidationErrorInPhase ([Text], ExUnits)
forall a b. b -> Either a b
Right) Map
  RdmrPtr
  (Either
     (TransactionScriptFailure StandardCrypto) ([Text], ExUnits))
RedeemerReportWithLogs (Crypto EmulatorEra)
result
  where
    eg :: Globals
eg = Params -> Globals
emulatorGlobals Params
params
    ss :: SystemStart
ss = Globals -> SystemStart
systemStart Globals
eg
    ei :: EpochInfo (Either Text)
ei = Globals -> EpochInfo (Either Text)
epochInfo Globals
eg
    costmdls :: Array Language CostModel
costmdls = (Language, Language)
-> [(Language, CostModel)] -> Array Language CostModel
forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array (Language
forall a. Bounded a => a
minBound, Language
forall a. Bounded a => a
maxBound) ([(Language, CostModel)] -> Array Language CostModel)
-> (Map Language CostModel -> [(Language, CostModel)])
-> Map Language CostModel
-> Array Language CostModel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Language CostModel -> [(Language, CostModel)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map Language CostModel -> Array Language CostModel)
-> Map Language CostModel -> Array Language CostModel
forall a b. (a -> b) -> a -> b
$ CostModels -> Map Language CostModel
unCostModels (CostModels -> Map Language CostModel)
-> CostModels -> Map Language CostModel
forall a b. (a -> b) -> a -> b
$ forall k (x :: k) r a. HasField x r a => r -> a
forall r a. HasField "_costmdls" r a => r -> a
getField @"_costmdls" (PParams -> CostModels) -> PParams -> CostModels
forall a b. (a -> b) -> a -> b
$ Params -> PParams
emulatorPParams Params
params
    toCardanoLedgerError :: TransactionScriptFailure c -> Either ValidationErrorInPhase b
toCardanoLedgerError (C.Ledger.ValidationFailedV1 (V1.CekError CekEvaluationException NamedDeBruijn DefaultUni DefaultFun
ce) [Text]
logs) =
      ValidationErrorInPhase -> Either ValidationErrorInPhase b
forall a b. a -> Either a b
Left (ValidationPhase
P.Phase2, ScriptError -> ValidationError
P.ScriptFailure ([Text] -> String -> ScriptError
P.EvaluationError [Text]
logs (String
"CekEvaluationFailure: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ CekEvaluationException NamedDeBruijn DefaultUni DefaultFun
-> String
forall a. Show a => a -> String
show CekEvaluationException NamedDeBruijn DefaultUni DefaultFun
ce)))
    toCardanoLedgerError (C.Ledger.ValidationFailedV2 (V1.CekError CekEvaluationException NamedDeBruijn DefaultUni DefaultFun
ce) [Text]
logs) =
      ValidationErrorInPhase -> Either ValidationErrorInPhase b
forall a b. a -> Either a b
Left (ValidationPhase
P.Phase2, ScriptError -> ValidationError
P.ScriptFailure ([Text] -> String -> ScriptError
P.EvaluationError [Text]
logs (String
"CekEvaluationFailure: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ CekEvaluationException NamedDeBruijn DefaultUni DefaultFun
-> String
forall a. Show a => a -> String
show CekEvaluationException NamedDeBruijn DefaultUni DefaultFun
ce)))
    toCardanoLedgerError TransactionScriptFailure c
e = ValidationErrorInPhase -> Either ValidationErrorInPhase b
forall a b. a -> Either a b
Left (ValidationPhase
P.Phase2, Text -> ValidationError
P.CardanoLedgerValidationError (Text -> ValidationError) -> Text -> ValidationError
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ TransactionScriptFailure c -> String
forall a. Show a => a -> String
show TransactionScriptFailure c
e)

makeTransactionBody
  :: Params
  -> UTxO EmulatorEra
  -> P.CardanoBuildTx
  -> Either CardanoLedgerError (C.Api.TxBody C.Api.BabbageEra)
makeTransactionBody :: Params
-> UTxO EmulatorEra
-> CardanoBuildTx
-> Either CardanoLedgerError (TxBody BabbageEra)
makeTransactionBody Params
params UTxO EmulatorEra
utxo CardanoBuildTx
txBodyContent = do
  Tx BabbageEra
txTmp <- (ToCardanoError -> CardanoLedgerError)
-> (TxBody BabbageEra -> Tx BabbageEra)
-> Either ToCardanoError (TxBody BabbageEra)
-> Either CardanoLedgerError (Tx BabbageEra)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap ToCardanoError -> CardanoLedgerError
forall a b. b -> Either a b
Right ([KeyWitness BabbageEra] -> TxBody BabbageEra -> Tx BabbageEra
forall era. [KeyWitness era] -> TxBody era -> Tx era
C.Api.makeSignedTransaction []) (Either ToCardanoError (TxBody BabbageEra)
 -> Either CardanoLedgerError (Tx BabbageEra))
-> Either ToCardanoError (TxBody BabbageEra)
-> Either CardanoLedgerError (Tx BabbageEra)
forall a b. (a -> b) -> a -> b
$ Maybe PParams
-> Map RdmrPtr ExUnits
-> CardanoBuildTx
-> Either ToCardanoError (TxBody BabbageEra)
P.makeTransactionBody (PParams -> Maybe PParams
forall a. a -> Maybe a
Just (PParams -> Maybe PParams) -> PParams -> Maybe PParams
forall a b. (a -> b) -> a -> b
$ Params -> PParams
emulatorPParams Params
params) Map RdmrPtr ExUnits
forall a. Monoid a => a
mempty CardanoBuildTx
txBodyContent
  Map RdmrPtr ExUnits
exUnits <- (ValidationErrorInPhase -> CardanoLedgerError)
-> (ValidationSuccess -> Map RdmrPtr ExUnits)
-> Either ValidationErrorInPhase ValidationSuccess
-> Either CardanoLedgerError (Map RdmrPtr ExUnits)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap ValidationErrorInPhase -> CardanoLedgerError
forall a b. a -> Either a b
Left ((([Text], ExUnits) -> ExUnits)
-> ValidationSuccess -> Map RdmrPtr ExUnits
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map ([Text], ExUnits) -> ExUnits
forall a b. (a, b) -> b
snd) (Either ValidationErrorInPhase ValidationSuccess
 -> Either CardanoLedgerError (Map RdmrPtr ExUnits))
-> Either ValidationErrorInPhase ValidationSuccess
-> Either CardanoLedgerError (Map RdmrPtr ExUnits)
forall a b. (a -> b) -> a -> b
$ Params
-> UTxO EmulatorEra
-> Tx BabbageEra
-> Either ValidationErrorInPhase ValidationSuccess
getTxExUnitsWithLogs Params
params UTxO EmulatorEra
utxo Tx BabbageEra
txTmp
  (ToCardanoError -> CardanoLedgerError)
-> Either ToCardanoError (TxBody BabbageEra)
-> Either CardanoLedgerError (TxBody BabbageEra)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ToCardanoError -> CardanoLedgerError
forall a b. b -> Either a b
Right (Either ToCardanoError (TxBody BabbageEra)
 -> Either CardanoLedgerError (TxBody BabbageEra))
-> Either ToCardanoError (TxBody BabbageEra)
-> Either CardanoLedgerError (TxBody BabbageEra)
forall a b. (a -> b) -> a -> b
$ Maybe PParams
-> Map RdmrPtr ExUnits
-> CardanoBuildTx
-> Either ToCardanoError (TxBody BabbageEra)
P.makeTransactionBody (PParams -> Maybe PParams
forall a. a -> Maybe a
Just (PParams -> Maybe PParams) -> PParams -> Maybe PParams
forall a b. (a -> b) -> a -> b
$ Params -> PParams
emulatorPParams Params
params) Map RdmrPtr ExUnits
exUnits CardanoBuildTx
txBodyContent