{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Cardano.Rpc.Server.Internal.UtxoRpc.Eval
  ( evalTxMethod
  )
where

import Cardano.Api
import Cardano.Api.Experimental qualified as Exp
import Cardano.Api.Experimental.Era
import Cardano.Api.Ledger qualified as L
import Cardano.Rpc.Proto.Api.UtxoRpc.Submit qualified as U5c
import Cardano.Rpc.Proto.Api.UtxoRpc.Submit qualified as UtxoRpc
import Cardano.Rpc.Server.Internal.Error
import Cardano.Rpc.Server.Internal.Monad
import Cardano.Rpc.Server.Internal.Orphans ()
import Cardano.Rpc.Server.Internal.Tracing
import Cardano.Rpc.Server.Internal.UtxoRpc.Type

import Cardano.Ledger.Api qualified as L

import RIO hiding (toList)

import Data.Default
import Data.Map.Strict qualified as Map
import Data.ProtoLens (defMessage)
import Data.Set qualified as Set
import GHC.IsList
import GHC.Stack
import Network.GRPC.Spec

import Proto.Utxorpc.V1beta.Cardano.Cardano_Fields qualified as Proto

-- | Evaluate a CBOR-serialised transaction against the current ledger state,
-- returning per-redeemer execution units, computed minimum fee, script traces,
-- balance check results, and evaluation errors, without submitting.
evalTxMethod
  :: MonadRpc e m
  => Proto UtxoRpc.EvalTxRequest
  -- ^ The evaluation request containing raw transaction CBOR
  -> m (Proto UtxoRpc.EvalTxResponse)
evalTxMethod :: forall e (m :: * -> *).
MonadRpc e m =>
Proto EvalTxRequest -> m (Proto EvalTxResponse)
evalTxMethod Proto EvalTxRequest
request = do
  nodeConnInfo <- m LocalNodeConnectInfo
forall field env (m :: * -> *).
(Has field env, MonadReader env m) =>
m field
grab
  AnyCardanoEra (era :: CardanoEra era) <- liftIO . throwExceptT $ determineEra nodeConnInfo
  (eon :: Era era) <- forEraInEon @Era era (error "Minimum Conway era required") pure

  (Exp.SignedTx ledgerTx :: Exp.SignedTx era) <-
    putTraceThrowEither
      . first TraceRpcEvalTxDecodingError
      . obtainCommonConstraints eon (deserialiseFromRawBytes asType)
      $ request ^. U5c.tx . U5c.raw

  let allInputs =
        Era era -> (EraCommonConstraints era => Set TxIn) -> Set TxIn
forall era a. Era era -> (EraCommonConstraints era => a) -> a
obtainCommonConstraints Era era
eon ((EraCommonConstraints era => Set TxIn) -> Set TxIn)
-> (EraCommonConstraints era => Set TxIn) -> Set TxIn
forall a b. (a -> b) -> a -> b
$
          (TxIn -> TxIn) -> Set TxIn -> Set TxIn
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map TxIn -> TxIn
fromShelleyTxIn (Set TxIn -> Set TxIn) -> Set TxIn -> Set TxIn
forall a b. (a -> b) -> a -> b
$
            Tx TopTx (ShelleyLedgerEra era)
Tx TopTx (LedgerEra era)
ledgerTx Tx TopTx (LedgerEra era)
-> Getting (Set TxIn) (Tx TopTx (LedgerEra era)) (Set TxIn)
-> Set TxIn
forall s a. s -> Getting a s a -> a
^. (TxBody TopTx (LedgerEra era)
 -> Const (Set TxIn) (TxBody TopTx (LedgerEra era)))
-> Tx TopTx (LedgerEra era)
-> Const (Set TxIn) (Tx TopTx (LedgerEra era))
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel).
Lens' (Tx l (LedgerEra era)) (TxBody l (LedgerEra era))
L.bodyTxL ((TxBody TopTx (LedgerEra era)
  -> Const (Set TxIn) (TxBody TopTx (LedgerEra era)))
 -> Tx TopTx (LedgerEra era)
 -> Const (Set TxIn) (Tx TopTx (LedgerEra era)))
-> ((Set TxIn -> Const (Set TxIn) (Set TxIn))
    -> TxBody TopTx (LedgerEra era)
    -> Const (Set TxIn) (TxBody TopTx (LedgerEra era)))
-> Getting (Set TxIn) (Tx TopTx (LedgerEra era)) (Set TxIn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set TxIn -> Const (Set TxIn) (Set TxIn))
-> TxBody TopTx (LedgerEra era)
-> Const (Set TxIn) (TxBody TopTx (LedgerEra era))
forall era.
EraTxBody era =>
SimpleGetter (TxBody TopTx era) (Set TxIn)
SimpleGetter (TxBody TopTx (LedgerEra era)) (Set TxIn)
L.allInputsTxBodyF

  let (unregStakeCreds, unregDRepCreds, regPoolIds) =
        extractBalanceCheckCreds eon $ ledgerTx ^. L.bodyTxL
      apiStakeCreds = (Credential Staking -> StakeCredential)
-> Set (Credential Staking) -> Set StakeCredential
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map Credential Staking -> StakeCredential
fromShelleyStakeCredential Set (Credential Staking)
unregStakeCreds
      apiPoolIds = (KeyHash StakePool -> Hash StakePoolKey)
-> Set (KeyHash StakePool) -> Set (Hash StakePoolKey)
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map KeyHash StakePool -> Hash StakePoolKey
StakePoolKeyHash Set (KeyHash StakePool)
regPoolIds

  let target = Target point
forall point. Target point
VolatileTip
  (protocolParams, utxo, systemStart, eraHistory, stakeDelegDeposits, drepStates, registeredPools) <-
    liftIO . (throwEither =<<) $
      executeLocalStateQueryExpr nodeConnInfo target $ do
        protocolParams <- throwEither =<< throwEither =<< queryProtocolParameters (convert eon)
        utxo <- throwEither =<< throwEither =<< queryUtxo (convert eon) (QueryUTxOByTxIn allInputs)
        systemStart <- throwEither =<< querySystemStart
        eraHistory <- throwEither =<< queryEraHistory
        stakeDelegDeposits <-
          throwEither =<< throwEither =<< queryStakeDelegDeposits (convert eon) apiStakeCreds
        drepStates <- throwEither =<< throwEither =<< queryDRepState (convert eon) unregDRepCreds
        registeredPools <- throwEither =<< throwEither =<< queryStakePoolParameters (convert eon) apiPoolIds
        pure
          (protocolParams, utxo, systemStart, eraHistory, stakeDelegDeposits, drepStates, registeredPools)

  obtainCommonConstraints eon $ do
    let ledgerUtxo = ShelleyBasedEra era -> UTxO era -> UTxO (ShelleyLedgerEra era)
forall era.
ShelleyBasedEra era -> UTxO era -> UTxO (ShelleyLedgerEra era)
toLedgerUTxO (Era era -> ShelleyBasedEra era
forall era. Era era -> ShelleyBasedEra era
forall a (f :: a -> *) (g :: a -> *) (era :: a).
Convert f g =>
f era -> g era
convert Era era
eon) UTxO era
utxo
        epochInfo = EraHistory -> LedgerEpochInfo
toLedgerEpochInfo EraHistory
eraHistory
        evalResults =
          SystemStart
-> LedgerEpochInfo
-> PParams (LedgerEra era)
-> UTxO (LedgerEra era)
-> Tx TopTx (LedgerEra era)
-> Map
     ScriptWitnessIndex
     (Either
        ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits))
forall era.
IsEra era =>
SystemStart
-> LedgerEpochInfo
-> PParams (LedgerEra era)
-> UTxO (LedgerEra era)
-> Tx TopTx (LedgerEra era)
-> Map
     ScriptWitnessIndex
     (Either
        ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits))
Exp.evaluateTransactionExecutionUnits
            SystemStart
systemStart
            LedgerEpochInfo
epochInfo
            PParams (ShelleyLedgerEra era)
PParams (LedgerEra era)
protocolParams
            UTxO (ShelleyLedgerEra era)
UTxO (LedgerEra era)
ledgerUtxo
            Tx TopTx (ShelleyLedgerEra era)
Tx TopTx (LedgerEra era)
ledgerTx
        evaluatedExUnitsMap =
          [(PlutusPurpose AsIx (LedgerEra era), ExUnits)]
-> Map (PlutusPurpose AsIx (LedgerEra era)) ExUnits
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
            [ (PlutusPurpose AsIx (LedgerEra era)
purpose, Natural -> Natural -> ExUnits
L.ExUnits (ExecutionUnits -> Natural
executionMemory ExecutionUnits
units) (ExecutionUnits -> Natural
executionSteps ExecutionUnits
units))
            | (ScriptWitnessIndex
swi, Right (EvalTxExecutionUnitsLog
_, ExecutionUnits
units)) <- Map
  ScriptWitnessIndex
  (Either
     ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits))
-> [(ScriptWitnessIndex,
     Either
       ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits))]
forall k a. Map k a -> [(k, a)]
Map.toList Map
  ScriptWitnessIndex
  (Either
     ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits))
evalResults
            , Just PlutusPurpose AsIx (LedgerEra era)
purpose <- [AlonzoEraOnwards era
-> ScriptWitnessIndex
-> Maybe (PlutusPurpose AsIx (ShelleyLedgerEra era))
forall era.
AlonzoEraOnwards era
-> ScriptWitnessIndex
-> Maybe (PlutusPurpose AsIx (ShelleyLedgerEra era))
fromScriptWitnessIndex (Era era -> AlonzoEraOnwards era
forall era. Era era -> AlonzoEraOnwards era
forall a (f :: a -> *) (g :: a -> *) (era :: a).
Convert f g =>
f era -> g era
convert Era era
eon) ScriptWitnessIndex
swi]
            ]
        -- Failed redeemers keep the client-supplied ex-units, so the computed
        -- fee may vary with the client's guess. This is acceptable because a
        -- failed evaluation means the tx cannot be submitted anyway.
        txWithEvaluatedExUnits =
          Tx TopTx (ShelleyLedgerEra era)
Tx TopTx (LedgerEra era)
ledgerTx
            Tx TopTx (LedgerEra era)
-> (Tx TopTx (LedgerEra era) -> Tx TopTx (LedgerEra era))
-> Tx TopTx (LedgerEra era)
forall a b. a -> (a -> b) -> b
& (TxWits (LedgerEra era) -> Identity (TxWits (LedgerEra era)))
-> Tx TopTx (LedgerEra era) -> Identity (Tx TopTx (LedgerEra era))
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxWits era)
forall (l :: TxLevel).
Lens' (Tx l (LedgerEra era)) (TxWits (LedgerEra era))
L.witsTxL ((TxWits (LedgerEra era) -> Identity (TxWits (LedgerEra era)))
 -> Tx TopTx (LedgerEra era) -> Identity (Tx TopTx (LedgerEra era)))
-> ((Redeemers (LedgerEra era)
     -> Identity (Redeemers (LedgerEra era)))
    -> TxWits (LedgerEra era) -> Identity (TxWits (LedgerEra era)))
-> (Redeemers (LedgerEra era)
    -> Identity (Redeemers (LedgerEra era)))
-> Tx TopTx (LedgerEra era)
-> Identity (Tx TopTx (LedgerEra era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Redeemers (LedgerEra era) -> Identity (Redeemers (LedgerEra era)))
-> TxWits (LedgerEra era) -> Identity (TxWits (LedgerEra era))
forall era.
AlonzoEraTxWits era =>
Lens' (TxWits era) (Redeemers era)
Lens' (TxWits (LedgerEra era)) (Redeemers (LedgerEra era))
L.rdmrsTxWitsL
              ((Redeemers (LedgerEra era)
  -> Identity (Redeemers (LedgerEra era)))
 -> Tx TopTx (LedgerEra era) -> Identity (Tx TopTx (LedgerEra era)))
-> (Redeemers (LedgerEra era) -> Redeemers (LedgerEra era))
-> Tx TopTx (LedgerEra era)
-> Tx TopTx (LedgerEra era)
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ \Redeemers (LedgerEra era)
rdmrs ->
                Map
  (PlutusPurpose AsIx (LedgerEra era))
  (Data (LedgerEra era), ExUnits)
-> Redeemers (LedgerEra era)
forall era.
AlonzoEraScript era =>
Map (PlutusPurpose AsIx era) (Data era, ExUnits) -> Redeemers era
L.Redeemers (Map
   (PlutusPurpose AsIx (LedgerEra era))
   (Data (LedgerEra era), ExUnits)
 -> Redeemers (LedgerEra era))
-> Map
     (PlutusPurpose AsIx (LedgerEra era))
     (Data (LedgerEra era), ExUnits)
-> Redeemers (LedgerEra era)
forall a b. (a -> b) -> a -> b
$
                  (PlutusPurpose AsIx (LedgerEra era)
 -> (Data (LedgerEra era), ExUnits)
 -> (Data (LedgerEra era), ExUnits))
-> Map
     (PlutusPurpose AsIx (LedgerEra era))
     (Data (LedgerEra era), ExUnits)
-> Map
     (PlutusPurpose AsIx (LedgerEra era))
     (Data (LedgerEra era), ExUnits)
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey
                    ( \PlutusPurpose AsIx (LedgerEra era)
purpose (Data (LedgerEra era)
datum, ExUnits
oldExUnits) ->
                        (Data (LedgerEra era)
datum, ExUnits
-> PlutusPurpose AsIx (LedgerEra era)
-> Map (PlutusPurpose AsIx (LedgerEra era)) ExUnits
-> ExUnits
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault ExUnits
oldExUnits PlutusPurpose AsIx (LedgerEra era)
purpose Map (PlutusPurpose AsIx (LedgerEra era)) ExUnits
evaluatedExUnitsMap)
                    )
                    (Redeemers (LedgerEra era)
-> Map
     (PlutusPurpose AsIx (LedgerEra era))
     (Data (LedgerEra era), ExUnits)
forall era.
Redeemers era -> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
L.unRedeemers Redeemers (LedgerEra era)
rdmrs)
        fee =
          PParams (LedgerEra era)
-> Tx TopTx (LedgerEra era)
-> UTxO (LedgerEra era)
-> Tx TopTx (LedgerEra era)
forall era.
EraUTxO era =>
PParams era -> Tx TopTx era -> UTxO era -> Tx TopTx era
L.setMinFeeTxUtxo PParams (ShelleyLedgerEra era)
PParams (LedgerEra era)
protocolParams Tx TopTx (LedgerEra era)
txWithEvaluatedExUnits UTxO (ShelleyLedgerEra era)
UTxO (LedgerEra era)
ledgerUtxo
            Tx TopTx (LedgerEra era)
-> Getting Coin (Tx TopTx (LedgerEra era)) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. (TxBody TopTx (LedgerEra era)
 -> Const Coin (TxBody TopTx (LedgerEra era)))
-> Tx TopTx (LedgerEra era)
-> Const Coin (Tx TopTx (LedgerEra era))
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel).
Lens' (Tx l (LedgerEra era)) (TxBody l (LedgerEra era))
L.bodyTxL ((TxBody TopTx (LedgerEra era)
  -> Const Coin (TxBody TopTx (LedgerEra era)))
 -> Tx TopTx (LedgerEra era)
 -> Const Coin (Tx TopTx (LedgerEra era)))
-> ((Coin -> Const Coin Coin)
    -> TxBody TopTx (LedgerEra era)
    -> Const Coin (TxBody TopTx (LedgerEra era)))
-> Getting Coin (Tx TopTx (LedgerEra era)) Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Const Coin Coin)
-> TxBody TopTx (LedgerEra era)
-> Const Coin (TxBody TopTx (LedgerEra era))
forall era. EraTxBody era => Lens' (TxBody TopTx era) Coin
Lens' (TxBody TopTx (LedgerEra era)) Coin
L.feeTxBodyL
        redeemerData =
          [(ScriptWitnessIndex, (ScriptData, ByteString))]
-> Map ScriptWitnessIndex (ScriptData, ByteString)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
            [ ( AlonzoEraOnwards era
-> PlutusPurpose AsIx (ShelleyLedgerEra era) -> ScriptWitnessIndex
forall era.
AlonzoEraOnwards era
-> PlutusPurpose AsIx (ShelleyLedgerEra era) -> ScriptWitnessIndex
toScriptIndex (Era era -> AlonzoEraOnwards era
forall era. Era era -> AlonzoEraOnwards era
forall a (f :: a -> *) (g :: a -> *) (era :: a).
Convert f g =>
f era -> g era
convert Era era
eon) PlutusPurpose AsIx (ShelleyLedgerEra era)
PlutusPurpose AsIx (LedgerEra era)
purpose
              ,
                ( Data -> ScriptData
fromPlutusData (Data -> ScriptData) -> Data -> ScriptData
forall a b. (a -> b) -> a -> b
$ Data (LedgerEra era) -> Data
forall era. Data era -> Data
L.getPlutusData Data (LedgerEra era)
datum
                , Version -> Data (LedgerEra era) -> ByteString
forall a. EncCBOR a => Version -> a -> ByteString
L.serialize' (Era era -> Version
forall era. Era era -> Version
Exp.eraProtVerHigh Era era
eon) Data (LedgerEra era)
datum
                )
              )
            | (PlutusPurpose AsIx (LedgerEra era)
purpose, (Data (LedgerEra era)
datum, ExUnits
_exUnits)) <-
                Map
  (PlutusPurpose AsIx (LedgerEra era))
  (Data (LedgerEra era), ExUnits)
-> [(PlutusPurpose AsIx (LedgerEra era),
     (Data (LedgerEra era), ExUnits))]
Map
  (PlutusPurpose AsIx (LedgerEra era))
  (Data (LedgerEra era), ExUnits)
-> [Item
      (Map
         (PlutusPurpose AsIx (LedgerEra era))
         (Data (LedgerEra era), ExUnits))]
forall l. IsList l => l -> [Item l]
toList (Map
   (PlutusPurpose AsIx (LedgerEra era))
   (Data (LedgerEra era), ExUnits)
 -> [(PlutusPurpose AsIx (LedgerEra era),
      (Data (LedgerEra era), ExUnits))])
-> (Redeemers (LedgerEra era)
    -> Map
         (PlutusPurpose AsIx (LedgerEra era))
         (Data (LedgerEra era), ExUnits))
-> Redeemers (LedgerEra era)
-> [(PlutusPurpose AsIx (LedgerEra era),
     (Data (LedgerEra era), ExUnits))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Redeemers (LedgerEra era)
-> Map
     (PlutusPurpose AsIx (LedgerEra era))
     (Data (LedgerEra era), ExUnits)
forall era.
Redeemers era -> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
L.unRedeemers (Redeemers (LedgerEra era)
 -> [(PlutusPurpose AsIx (LedgerEra era),
      (Data (LedgerEra era), ExUnits))])
-> Redeemers (LedgerEra era)
-> [(PlutusPurpose AsIx (LedgerEra era),
     (Data (LedgerEra era), ExUnits))]
forall a b. (a -> b) -> a -> b
$ Tx TopTx (ShelleyLedgerEra era)
Tx TopTx (LedgerEra era)
ledgerTx Tx TopTx (LedgerEra era)
-> Getting
     (Redeemers (LedgerEra era))
     (Tx TopTx (LedgerEra era))
     (Redeemers (LedgerEra era))
-> Redeemers (LedgerEra era)
forall s a. s -> Getting a s a -> a
^. (TxWits (LedgerEra era)
 -> Const (Redeemers (LedgerEra era)) (TxWits (LedgerEra era)))
-> Tx TopTx (LedgerEra era)
-> Const (Redeemers (LedgerEra era)) (Tx TopTx (LedgerEra era))
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxWits era)
forall (l :: TxLevel).
Lens' (Tx l (LedgerEra era)) (TxWits (LedgerEra era))
L.witsTxL ((TxWits (LedgerEra era)
  -> Const (Redeemers (LedgerEra era)) (TxWits (LedgerEra era)))
 -> Tx TopTx (LedgerEra era)
 -> Const (Redeemers (LedgerEra era)) (Tx TopTx (LedgerEra era)))
-> ((Redeemers (LedgerEra era)
     -> Const (Redeemers (LedgerEra era)) (Redeemers (LedgerEra era)))
    -> TxWits (LedgerEra era)
    -> Const (Redeemers (LedgerEra era)) (TxWits (LedgerEra era)))
-> Getting
     (Redeemers (LedgerEra era))
     (Tx TopTx (LedgerEra era))
     (Redeemers (LedgerEra era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Redeemers (LedgerEra era)
 -> Const (Redeemers (LedgerEra era)) (Redeemers (LedgerEra era)))
-> TxWits (LedgerEra era)
-> Const (Redeemers (LedgerEra era)) (TxWits (LedgerEra era))
forall era.
AlonzoEraTxWits era =>
Lens' (TxWits era) (Redeemers era)
Lens' (TxWits (LedgerEra era)) (Redeemers (LedgerEra era))
L.rdmrsTxWitsL
            ]
        txEval = Coin
-> Map
     ScriptWitnessIndex
     (Either
        ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits))
-> Map ScriptWitnessIndex (ScriptData, ByteString)
-> Proto TxEval
mkProtoTxEval Coin
fee Map
  ScriptWitnessIndex
  (Either
     ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits))
evalResults Map ScriptWitnessIndex (ScriptData, ByteString)
redeemerData

        lookupStakeDeposit Credential Staking
credential =
          StakeCredential -> Map StakeCredential Coin -> Maybe Coin
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Credential Staking -> StakeCredential
fromShelleyStakeCredential Credential Staking
credential) Map StakeCredential Coin
stakeDelegDeposits
        lookupDRepDeposit Credential DRepRole
credential =
          CompactForm Coin -> Coin
forall a. Compactible a => CompactForm a -> a
L.fromCompact (CompactForm Coin -> Coin)
-> (DRepState -> CompactForm Coin) -> DRepState -> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DRepState -> CompactForm Coin
L.drepDeposit (DRepState -> Coin) -> Maybe DRepState -> Maybe Coin
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Credential DRepRole
-> Map (Credential DRepRole) DRepState -> Maybe DRepState
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Credential DRepRole
credential Map (Credential DRepRole) DRepState
drepStates
        isRegPool KeyHash StakePool
poolKeyHash =
          KeyHash StakePool -> Hash StakePoolKey
StakePoolKeyHash KeyHash StakePool
poolKeyHash Hash StakePoolKey
-> Map (Hash StakePoolKey) StakePoolParameters -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map (Hash StakePoolKey) StakePoolParameters
registeredPools
        balance =
          PParams (LedgerEra era)
-> (Credential Staking -> Maybe Coin)
-> (Credential DRepRole -> Maybe Coin)
-> (KeyHash StakePool -> Bool)
-> UTxO (LedgerEra era)
-> TxBody TopTx (LedgerEra era)
-> Value (LedgerEra era)
forall era (l :: TxLevel).
EraUTxO era =>
PParams era
-> (Credential Staking -> Maybe Coin)
-> (Credential DRepRole -> Maybe Coin)
-> (KeyHash StakePool -> Bool)
-> UTxO era
-> TxBody l era
-> Value era
L.evalBalanceTxBody
            PParams (ShelleyLedgerEra era)
PParams (LedgerEra era)
protocolParams
            Credential Staking -> Maybe Coin
lookupStakeDeposit
            Credential DRepRole -> Maybe Coin
lookupDRepDeposit
            KeyHash StakePool -> Bool
isRegPool
            UTxO (ShelleyLedgerEra era)
UTxO (LedgerEra era)
ledgerUtxo
            (Tx TopTx (LedgerEra era)
txWithEvaluatedExUnits Tx TopTx (LedgerEra era)
-> Getting
     (TxBody TopTx (LedgerEra era))
     (Tx TopTx (LedgerEra era))
     (TxBody TopTx (LedgerEra era))
-> TxBody TopTx (LedgerEra era)
forall s a. s -> Getting a s a -> a
^. Getting
  (TxBody TopTx (LedgerEra era))
  (Tx TopTx (LedgerEra era))
  (TxBody TopTx (LedgerEra era))
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel).
Lens' (Tx l (LedgerEra era)) (TxBody l (LedgerEra era))
L.bodyTxL)
        balanceErrors
          | Value (LedgerEra era)
MaryValue
balance MaryValue -> MaryValue -> Bool
forall a. Eq a => a -> a -> Bool
== MaryValue
forall a. Monoid a => a
mempty = []
          | Bool
otherwise =
              [ EvalReport
forall msg. Message msg => msg
defMessage
                  EvalReport -> (EvalReport -> EvalReport) -> EvalReport
forall a b. a -> (a -> b) -> b
& LensLike' Identity EvalReport Text
forall (f :: * -> *) s a.
(Functor f, HasField s "msg" a) =>
LensLike' f s a
Proto.msg
                    LensLike' Identity EvalReport Text
-> Text -> EvalReport -> EvalReport
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Text
"Transaction is not balanced. Remaining balance (consumed - produced): "
                      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> MaryValue -> Text
forall a. Show a => a -> Text
tshow Value (LedgerEra era)
MaryValue
balance
              ]
        finalTxEval =
          TxEval -> Proto TxEval
forall msg. msg -> Proto msg
Proto (TxEval -> Proto TxEval) -> TxEval -> Proto TxEval
forall a b. (a -> b) -> a -> b
$ Proto TxEval -> TxEval
forall msg. Proto msg -> msg
getProto Proto TxEval
txEval TxEval -> (TxEval -> TxEval) -> TxEval
forall a b. a -> (a -> b) -> b
& LensLike' Identity TxEval [EvalReport]
forall (f :: * -> *) s a.
(Functor f, HasField s "errors" a) =>
LensLike' f s a
Proto.errors LensLike' Identity TxEval [EvalReport]
-> ([EvalReport] -> [EvalReport]) -> TxEval -> TxEval
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ([EvalReport] -> [EvalReport] -> [EvalReport]
forall a. Semigroup a => a -> a -> a
<> [EvalReport]
balanceErrors)

    pure $ def & U5c.report . U5c.cardano .~ finalTxEval
 where
  putTraceThrowEither :: Either e b -> m b
putTraceThrowEither Either e b
value = (HasCallStack => m b) -> m b
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => m b) -> m b) -> (HasCallStack => m b) -> m b
forall a b. (a -> b) -> a -> b
$ do
    (e -> m ()) -> (b -> m ()) -> Either e b -> m ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either e -> m ()
forall t' t e (m :: * -> *).
(t ~ TraceRpc, Inject t' t, Has (Tracer m t) e, MonadReader e m) =>
t' -> m ()
putTrace (m () -> b -> m ()
forall a b. a -> b -> a
const (m () -> b -> m ()) -> m () -> b -> m ()
forall a b. (a -> b) -> a -> b
$ () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) Either e b
value
    Either e b -> m b
forall e (m :: * -> *) a.
(Error e, HasCallStack, MonadIO m, Show e, Typeable e) =>
Either e a -> m a
throwEither Either e b
value

-- | Extract the credentials and pool IDs needed for balance check queries from
-- the transaction body certificates.
extractBalanceCheckCreds
  :: Era era
  -> L.TxBody l (ShelleyLedgerEra era)
  -> ( Set.Set (L.Credential L.Staking)
     , Set.Set (L.Credential L.DRepRole)
     , Set.Set (L.KeyHash L.StakePool)
     )
extractBalanceCheckCreds :: forall era (l :: TxLevel).
Era era
-> TxBody l (ShelleyLedgerEra era)
-> (Set (Credential Staking), Set (Credential DRepRole),
    Set (KeyHash StakePool))
extractBalanceCheckCreds Era era
eon TxBody l (ShelleyLedgerEra era)
txBody =
  Era era
-> (EraCommonConstraints era =>
    (Set (Credential Staking), Set (Credential DRepRole),
     Set (KeyHash StakePool)))
-> (Set (Credential Staking), Set (Credential DRepRole),
    Set (KeyHash StakePool))
forall era a. Era era -> (EraCommonConstraints era => a) -> a
obtainCommonConstraints Era era
eon ((EraCommonConstraints era =>
  (Set (Credential Staking), Set (Credential DRepRole),
   Set (KeyHash StakePool)))
 -> (Set (Credential Staking), Set (Credential DRepRole),
     Set (KeyHash StakePool)))
-> (EraCommonConstraints era =>
    (Set (Credential Staking), Set (Credential DRepRole),
     Set (KeyHash StakePool)))
-> (Set (Credential Staking), Set (Credential DRepRole),
    Set (KeyHash StakePool))
forall a b. (a -> b) -> a -> b
$ do
    let certs :: [Item (StrictSeq (TxCert (LedgerEra era)))]
certs = StrictSeq (TxCert (LedgerEra era))
-> [Item (StrictSeq (TxCert (LedgerEra era)))]
forall l. IsList l => l -> [Item l]
toList (StrictSeq (TxCert (LedgerEra era))
 -> [Item (StrictSeq (TxCert (LedgerEra era)))])
-> StrictSeq (TxCert (LedgerEra era))
-> [Item (StrictSeq (TxCert (LedgerEra era)))]
forall a b. (a -> b) -> a -> b
$ TxBody l (ShelleyLedgerEra era)
TxBody l (LedgerEra era)
txBody TxBody l (LedgerEra era)
-> Getting
     (StrictSeq (TxCert (LedgerEra era)))
     (TxBody l (LedgerEra era))
     (StrictSeq (TxCert (LedgerEra era)))
-> StrictSeq (TxCert (LedgerEra era))
forall s a. s -> Getting a s a -> a
^. Getting
  (StrictSeq (TxCert (LedgerEra era)))
  (TxBody l (LedgerEra era))
  (StrictSeq (TxCert (LedgerEra era)))
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxCert era))
forall (l :: TxLevel).
Lens'
  (TxBody l (LedgerEra era)) (StrictSeq (TxCert (LedgerEra era)))
L.certsTxBodyL
        unregStakeCreds :: Set (Credential Staking)
unregStakeCreds =
          [Item (Set (Credential Staking))] -> Set (Credential Staking)
forall l. IsList l => [Item l] -> l
fromList ([Item (Set (Credential Staking))] -> Set (Credential Staking))
-> [Item (Set (Credential Staking))] -> Set (Credential Staking)
forall a b. (a -> b) -> a -> b
$ (TxCert (LedgerEra era) -> Maybe (Item (Set (Credential Staking))))
-> [TxCert (LedgerEra era)] -> [Item (Set (Credential Staking))]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe TxCert (LedgerEra era) -> Maybe (Item (Set (Credential Staking)))
TxCert (LedgerEra era) -> Maybe (Credential Staking)
forall era.
EraTxCert era =>
TxCert era -> Maybe (Credential Staking)
L.lookupUnRegStakeTxCert [Item (StrictSeq (TxCert (LedgerEra era)))]
[TxCert (LedgerEra era)]
certs
        unregDRepCreds :: Set (Credential DRepRole)
unregDRepCreds =
          [Item (Set (Credential DRepRole))] -> Set (Credential DRepRole)
forall l. IsList l => [Item l] -> l
fromList ([Item (Set (Credential DRepRole))] -> Set (Credential DRepRole))
-> [Item (Set (Credential DRepRole))] -> Set (Credential DRepRole)
forall a b. (a -> b) -> a -> b
$ ((Credential DRepRole, Coin) -> Item (Set (Credential DRepRole)))
-> [(Credential DRepRole, Coin)]
-> [Item (Set (Credential DRepRole))]
forall a b. (a -> b) -> [a] -> [b]
map (Credential DRepRole, Coin) -> Item (Set (Credential DRepRole))
(Credential DRepRole, Coin) -> Credential DRepRole
forall a b. (a, b) -> a
fst ([(Credential DRepRole, Coin)]
 -> [Item (Set (Credential DRepRole))])
-> [(Credential DRepRole, Coin)]
-> [Item (Set (Credential DRepRole))]
forall a b. (a -> b) -> a -> b
$ (TxCert (LedgerEra era) -> Maybe (Credential DRepRole, Coin))
-> [TxCert (LedgerEra era)] -> [(Credential DRepRole, Coin)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe TxCert (LedgerEra era) -> Maybe (Credential DRepRole, Coin)
forall era.
ConwayEraTxCert era =>
TxCert era -> Maybe (Credential DRepRole, Coin)
L.getUnRegDRepTxCert [Item (StrictSeq (TxCert (LedgerEra era)))]
[TxCert (LedgerEra era)]
certs
        regPoolIds :: Set (KeyHash StakePool)
regPoolIds =
          [Item (Set (KeyHash StakePool))] -> Set (KeyHash StakePool)
forall l. IsList l => [Item l] -> l
fromList ([Item (Set (KeyHash StakePool))] -> Set (KeyHash StakePool))
-> [Item (Set (KeyHash StakePool))] -> Set (KeyHash StakePool)
forall a b. (a -> b) -> a -> b
$ (StakePoolParams -> Item (Set (KeyHash StakePool)))
-> [StakePoolParams] -> [Item (Set (KeyHash StakePool))]
forall a b. (a -> b) -> [a] -> [b]
map StakePoolParams -> Item (Set (KeyHash StakePool))
StakePoolParams -> KeyHash StakePool
L.sppId ([StakePoolParams] -> [Item (Set (KeyHash StakePool))])
-> [StakePoolParams] -> [Item (Set (KeyHash StakePool))]
forall a b. (a -> b) -> a -> b
$ (TxCert (LedgerEra era) -> Maybe StakePoolParams)
-> [TxCert (LedgerEra era)] -> [StakePoolParams]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe TxCert (LedgerEra era) -> Maybe StakePoolParams
forall era. EraTxCert era => TxCert era -> Maybe StakePoolParams
L.getRegPoolTxCert [Item (StrictSeq (TxCert (LedgerEra era)))]
[TxCert (LedgerEra era)]
certs
    (Set (Credential Staking)
unregStakeCreds, Set (Credential DRepRole)
unregDRepCreds, Set (KeyHash StakePool)
regPoolIds)