{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# HLINT ignore "Use <$>" #-}
module Hydra.Ledger.Cardano.Evaluate (
evaluateTxWith,
evaluateTxWith',
checkBudget,
EvaluationError (..),
EvaluationReport,
renderEvaluationReport,
usedExecutionUnits,
estimateMinFeeWith,
) where
import Hydra.Prelude hiding (label)
import Cardano.Ledger.Alonzo.Scripts (exUnitsMem, exUnitsSteps, txscriptfee)
import Cardano.Ledger.Api (ppMaxTxExUnitsL, ppPricesL, ppTxFeeFixedL, ppTxFeePerByteL)
import Cardano.Ledger.Coin (Coin, CoinPerByte (..))
import Cardano.Ledger.Compactible (fromCompact)
import Cardano.Ledger.Conway.UTxO (txNonDistinctRefScriptsSize)
import Cardano.Ledger.Core (PParams, getMinFeeTx)
import Cardano.Ledger.Val (Val ((<+>), (<->)), (<×>))
import Cardano.Slotting.EpochInfo (EpochInfo)
import Cardano.Slotting.Time (SystemStart)
import Control.Lens ((.~))
import Control.Lens.Getter
import Data.ByteString qualified as BS
import Data.Map.Strict qualified as Map
import Hydra.Cardano.Api (
Era,
ExecutionUnits (..),
IsCardanoEra (cardanoEra),
LedgerEpochInfo (..),
LedgerEra,
LedgerProtocolParameters (..),
ProtocolParametersConversionError,
ScriptExecutionError,
ScriptWitnessIndex,
SerialiseAsCBOR (serialiseToCBOR),
TransactionValidityError,
Tx,
UTxO,
evaluateTransactionExecutionUnits,
getTxBody,
prettyError,
shelleyBasedEra,
toLedgerExUnits,
toLedgerTx,
toLedgerUTxO,
)
import Prettyprinter (defaultLayoutOptions, layoutPretty)
import Prettyprinter.Render.Text (renderStrict)
evaluateTxWith ::
SystemStart ->
EpochInfo (Either Text) ->
PParams LedgerEra ->
Tx ->
UTxO ->
Either EvaluationError EvaluationReport
evaluateTxWith :: SystemStart
-> EpochInfo (Either Text)
-> PParams LedgerEra
-> Tx
-> UTxO
-> Either EvaluationError EvaluationReport
evaluateTxWith SystemStart
sysStart EpochInfo (Either Text)
epochInfo' PParams LedgerEra
pparams' Tx
tx UTxO
utxo = do
let ledgerMaxUnits :: ExUnits
ledgerMaxUnits = PParams LedgerEra
PParams ConwayEra
pparams' PParams ConwayEra
-> Getting ExUnits (PParams ConwayEra) ExUnits -> ExUnits
forall s a. s -> Getting a s a -> a
^. Getting ExUnits (PParams ConwayEra) ExUnits
forall era. AlonzoEraPParams era => Lens' (PParams era) ExUnits
Lens' (PParams ConwayEra) ExUnits
ppMaxTxExUnitsL
maxUnits :: ExecutionUnits
maxUnits =
ExecutionUnits
{ executionMemory :: Natural
executionMemory = ExUnits -> Natural
exUnitsMem ExUnits
ledgerMaxUnits
, executionSteps :: Natural
executionSteps = ExUnits -> Natural
exUnitsSteps ExUnits
ledgerMaxUnits
}
SystemStart
-> EpochInfo (Either Text)
-> PParams LedgerEra
-> ExecutionUnits
-> Tx
-> UTxO
-> Either EvaluationError EvaluationReport
evaluateTxWith' SystemStart
sysStart EpochInfo (Either Text)
epochInfo' PParams LedgerEra
pparams' ExecutionUnits
maxUnits Tx
tx UTxO
utxo
evaluateTxWith' ::
SystemStart ->
EpochInfo (Either Text) ->
PParams LedgerEra ->
ExecutionUnits ->
Tx ->
UTxO ->
Either EvaluationError EvaluationReport
evaluateTxWith' :: SystemStart
-> EpochInfo (Either Text)
-> PParams LedgerEra
-> ExecutionUnits
-> Tx
-> UTxO
-> Either EvaluationError EvaluationReport
evaluateTxWith' SystemStart
sysStart EpochInfo (Either Text)
epochInfo' PParams LedgerEra
pparams' ExecutionUnits
maxUnits Tx
tx UTxO
utxo = do
let pparams'' :: PParams ConwayEra
pparams'' = PParams LedgerEra
PParams ConwayEra
pparams' PParams ConwayEra
-> (PParams ConwayEra -> PParams ConwayEra) -> PParams ConwayEra
forall a b. a -> (a -> b) -> b
& (ExUnits -> Identity ExUnits)
-> PParams ConwayEra -> Identity (PParams ConwayEra)
forall era. AlonzoEraPParams era => Lens' (PParams era) ExUnits
Lens' (PParams ConwayEra) ExUnits
ppMaxTxExUnitsL ((ExUnits -> Identity ExUnits)
-> PParams ConwayEra -> Identity (PParams ConwayEra))
-> ExUnits -> PParams ConwayEra -> PParams ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ExecutionUnits -> ExUnits
toLedgerExUnits ExecutionUnits
maxUnits
let report :: EvaluationReport
report = LedgerProtocolParameters Era -> EvaluationReport
result (LedgerProtocolParameters Era -> EvaluationReport)
-> LedgerProtocolParameters Era -> EvaluationReport
forall a b. (a -> b) -> a -> b
$ PParams LedgerEra -> LedgerProtocolParameters Era
forall era.
PParams (ShelleyLedgerEra era) -> LedgerProtocolParameters era
LedgerProtocolParameters PParams LedgerEra
PParams ConwayEra
pparams''
if (Either ScriptExecutionError ExecutionUnits -> Bool)
-> EvaluationReport -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Either ScriptExecutionError ExecutionUnits -> Bool
forall a b. Either a b -> Bool
isRight EvaluationReport
report
then ExecutionUnits
-> EvaluationReport -> Either EvaluationError EvaluationReport
checkBudget ExecutionUnits
maxUnits EvaluationReport
report
else EvaluationReport -> Either EvaluationError EvaluationReport
forall a b. b -> Either a b
Right EvaluationReport
report
where
result :: LedgerProtocolParameters Era -> EvaluationReport
result LedgerProtocolParameters Era
pparams'' =
((Either
ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits)
-> Either ScriptExecutionError ExecutionUnits)
-> Map
ScriptWitnessIndex
(Either
ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits))
-> EvaluationReport
forall a b.
(a -> b) -> Map ScriptWitnessIndex a -> Map ScriptWitnessIndex b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Either
ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits)
-> Either ScriptExecutionError ExecutionUnits)
-> Map
ScriptWitnessIndex
(Either
ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits))
-> EvaluationReport)
-> (((EvalTxExecutionUnitsLog, ExecutionUnits) -> ExecutionUnits)
-> Either
ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits)
-> Either ScriptExecutionError ExecutionUnits)
-> ((EvalTxExecutionUnitsLog, ExecutionUnits) -> ExecutionUnits)
-> Map
ScriptWitnessIndex
(Either
ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits))
-> EvaluationReport
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((EvalTxExecutionUnitsLog, ExecutionUnits) -> ExecutionUnits)
-> Either
ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits)
-> Either ScriptExecutionError ExecutionUnits
forall a b.
(a -> b)
-> Either ScriptExecutionError a -> Either ScriptExecutionError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) (EvalTxExecutionUnitsLog, ExecutionUnits) -> ExecutionUnits
forall a b. (a, b) -> b
snd (Map
ScriptWitnessIndex
(Either
ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits))
-> EvaluationReport)
-> Map
ScriptWitnessIndex
(Either
ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits))
-> EvaluationReport
forall a b. (a -> b) -> a -> b
$
CardanoEra Era
-> SystemStart
-> LedgerEpochInfo
-> LedgerProtocolParameters Era
-> UTxO
-> TxBody Era
-> Map
ScriptWitnessIndex
(Either
ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits))
forall era.
CardanoEra era
-> SystemStart
-> LedgerEpochInfo
-> LedgerProtocolParameters era
-> UTxO era
-> TxBody era
-> Map
ScriptWitnessIndex
(Either
ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits))
evaluateTransactionExecutionUnits
CardanoEra Era
forall era. IsCardanoEra era => CardanoEra era
cardanoEra
SystemStart
sysStart
(EpochInfo (Either Text) -> LedgerEpochInfo
LedgerEpochInfo EpochInfo (Either Text)
epochInfo')
LedgerProtocolParameters Era
pparams''
UTxO
utxo
(Tx -> TxBody Era
forall era. Tx era -> TxBody era
getTxBody Tx
tx)
checkBudget :: ExecutionUnits -> EvaluationReport -> Either EvaluationError EvaluationReport
checkBudget :: ExecutionUnits
-> EvaluationReport -> Either EvaluationError EvaluationReport
checkBudget ExecutionUnits
maxUnits EvaluationReport
report
| Natural
usedMemory Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
<= ExecutionUnits -> Natural
executionMemory ExecutionUnits
maxUnits Bool -> Bool -> Bool
&& Natural
usedCpu Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
<= ExecutionUnits -> Natural
executionSteps ExecutionUnits
maxUnits =
EvaluationReport -> Either EvaluationError EvaluationReport
forall a b. b -> Either a b
Right EvaluationReport
report
| Bool
otherwise =
EvaluationError -> Either EvaluationError EvaluationReport
forall a b. a -> Either a b
Left
TransactionBudgetOverspent
{ ExecutionUnits
used :: ExecutionUnits
$sel:used:TransactionBudgetOverspent :: ExecutionUnits
used
, $sel:available:TransactionBudgetOverspent :: ExecutionUnits
available = ExecutionUnits
maxUnits
}
where
used :: ExecutionUnits
used@ExecutionUnits
{ executionMemory :: ExecutionUnits -> Natural
executionMemory = Natural
usedMemory
, executionSteps :: ExecutionUnits -> Natural
executionSteps = Natural
usedCpu
} = EvaluationReport -> ExecutionUnits
usedExecutionUnits EvaluationReport
report
data EvaluationError
= TransactionBudgetOverspent {EvaluationError -> ExecutionUnits
used :: ExecutionUnits, EvaluationError -> ExecutionUnits
available :: ExecutionUnits}
| TransactionInvalid (TransactionValidityError Era)
| PParamsConversion ProtocolParametersConversionError
deriving stock (Int -> EvaluationError -> ShowS
[EvaluationError] -> ShowS
EvaluationError -> String
(Int -> EvaluationError -> ShowS)
-> (EvaluationError -> String)
-> ([EvaluationError] -> ShowS)
-> Show EvaluationError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> EvaluationError -> ShowS
showsPrec :: Int -> EvaluationError -> ShowS
$cshow :: EvaluationError -> String
show :: EvaluationError -> String
$cshowList :: [EvaluationError] -> ShowS
showList :: [EvaluationError] -> ShowS
Show)
type EvaluationReport =
(Map ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits))
renderEvaluationReport :: EvaluationReport -> Text
renderEvaluationReport :: EvaluationReport -> Text
renderEvaluationReport =
EvalTxExecutionUnitsLog -> Text
forall t. IsText t "unlines" => [t] -> t
unlines (EvalTxExecutionUnitsLog -> Text)
-> (EvaluationReport -> EvalTxExecutionUnitsLog)
-> EvaluationReport
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ScriptWitnessIndex, Either ScriptExecutionError ExecutionUnits)
-> Text)
-> [(ScriptWitnessIndex,
Either ScriptExecutionError ExecutionUnits)]
-> EvalTxExecutionUnitsLog
forall a b. (a -> b) -> [a] -> [b]
map (ScriptWitnessIndex, Either ScriptExecutionError ExecutionUnits)
-> Text
render ([(ScriptWitnessIndex, Either ScriptExecutionError ExecutionUnits)]
-> EvalTxExecutionUnitsLog)
-> (EvaluationReport
-> [(ScriptWitnessIndex,
Either ScriptExecutionError ExecutionUnits)])
-> EvaluationReport
-> EvalTxExecutionUnitsLog
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EvaluationReport
-> [(ScriptWitnessIndex,
Either ScriptExecutionError ExecutionUnits)]
forall k a. Map k a -> [(k, a)]
Map.toList
where
render :: (ScriptWitnessIndex, Either ScriptExecutionError ExecutionUnits) -> Text
render :: (ScriptWitnessIndex, Either ScriptExecutionError ExecutionUnits)
-> Text
render (ScriptWitnessIndex
ix, Right ExecutionUnits
exunits) =
Text
"- " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ScriptWitnessIndex -> Text
forall b a. (Show a, IsString b) => a -> b
show ScriptWitnessIndex
ix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" OK and used " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ExecutionUnits -> Text
forall b a. (Show a, IsString b) => a -> b
show ExecutionUnits
exunits
render (ScriptWitnessIndex
ix, Left ScriptExecutionError
err) =
EvalTxExecutionUnitsLog -> Text
forall t. IsText t "unlines" => [t] -> t
unlines
[ Text
"- " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ScriptWitnessIndex -> Text
forall b a. (Show a, IsString b) => a -> b
show ScriptWitnessIndex
ix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" FAIL with error: "
, SimpleDocStream Any -> Text
forall ann. SimpleDocStream ann -> Text
renderStrict (SimpleDocStream Any -> Text) -> SimpleDocStream Any -> Text
forall a b. (a -> b) -> a -> b
$ LayoutOptions -> Doc Any -> SimpleDocStream Any
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutPretty LayoutOptions
defaultLayoutOptions (Doc Any -> SimpleDocStream Any) -> Doc Any -> SimpleDocStream Any
forall a b. (a -> b) -> a -> b
$ ScriptExecutionError -> Doc Any
forall e ann. Error e => e -> Doc ann
forall ann. ScriptExecutionError -> Doc ann
prettyError ScriptExecutionError
err
]
usedExecutionUnits :: EvaluationReport -> ExecutionUnits
usedExecutionUnits :: EvaluationReport -> ExecutionUnits
usedExecutionUnits EvaluationReport
report =
ExecutionUnits
{ executionMemory :: Natural
executionMemory = Natural
usedMemory
, executionSteps :: Natural
executionSteps = Natural
usedCpu
}
where
usedMemory :: Natural
usedMemory = [Natural] -> Natural
forall a (f :: * -> *). (Foldable f, Num a) => f a -> a
sum ([Natural] -> Natural) -> [Natural] -> Natural
forall a b. (a -> b) -> a -> b
$ ExecutionUnits -> Natural
executionMemory (ExecutionUnits -> Natural) -> [ExecutionUnits] -> [Natural]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ExecutionUnits]
budgets
usedCpu :: Natural
usedCpu = [Natural] -> Natural
forall a (f :: * -> *). (Foldable f, Num a) => f a -> a
sum ([Natural] -> Natural) -> [Natural] -> Natural
forall a b. (a -> b) -> a -> b
$ ExecutionUnits -> Natural
executionSteps (ExecutionUnits -> Natural) -> [ExecutionUnits] -> [Natural]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ExecutionUnits]
budgets
budgets :: [ExecutionUnits]
budgets = [Either ScriptExecutionError ExecutionUnits] -> [ExecutionUnits]
forall a b. [Either a b] -> [b]
rights ([Either ScriptExecutionError ExecutionUnits] -> [ExecutionUnits])
-> [Either ScriptExecutionError ExecutionUnits] -> [ExecutionUnits]
forall a b. (a -> b) -> a -> b
$ EvaluationReport -> [Either ScriptExecutionError ExecutionUnits]
forall a. Map ScriptWitnessIndex a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList EvaluationReport
report
estimateMinFeeWith ::
PParams LedgerEra ->
UTxO ->
Tx ->
EvaluationReport ->
Coin
estimateMinFeeWith :: PParams LedgerEra -> UTxO -> Tx -> EvaluationReport -> Coin
estimateMinFeeWith PParams LedgerEra
pparams' UTxO
utxo Tx
tx EvaluationReport
evaluationReport =
(Int
txSize Int -> Coin -> Coin
forall i. Integral i => i -> Coin -> Coin
forall t i. (Val t, Integral i) => i -> t -> t
<×> Coin
a Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<+> Coin
b)
Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<+> Prices -> ExUnits -> Coin
txscriptfee Prices
prices ExUnits
allExunits
Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<+> Coin
refScriptsFee
where
txSize :: Int
txSize = ByteString -> Int
BS.length (ByteString -> Int) -> ByteString -> Int
forall a b. (a -> b) -> a -> b
$ Tx -> ByteString
forall a. SerialiseAsCBOR a => a -> ByteString
serialiseToCBOR Tx
tx
a :: Coin
a = CompactForm Coin -> Coin
forall a. Compactible a => CompactForm a -> a
fromCompact (CompactForm Coin -> Coin)
-> (CoinPerByte -> CompactForm Coin) -> CoinPerByte -> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoinPerByte -> CompactForm Coin
unCoinPerByte (CoinPerByte -> Coin) -> CoinPerByte -> Coin
forall a b. (a -> b) -> a -> b
$ PParams LedgerEra
PParams ConwayEra
pparams' PParams ConwayEra
-> Getting CoinPerByte (PParams ConwayEra) CoinPerByte
-> CoinPerByte
forall s a. s -> Getting a s a -> a
^. Getting CoinPerByte (PParams ConwayEra) CoinPerByte
forall era. EraPParams era => Lens' (PParams era) CoinPerByte
Lens' (PParams ConwayEra) CoinPerByte
ppTxFeePerByteL
b :: Coin
b = PParams LedgerEra
PParams ConwayEra
pparams' PParams ConwayEra -> Getting Coin (PParams ConwayEra) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (PParams ConwayEra) Coin
forall era.
(EraPParams era, HasCallStack) =>
Lens' (PParams era) Coin
Lens' (PParams ConwayEra) Coin
ppTxFeeFixedL
prices :: Prices
prices = PParams LedgerEra
PParams ConwayEra
pparams' PParams ConwayEra
-> Getting Prices (PParams ConwayEra) Prices -> Prices
forall s a. s -> Getting a s a -> a
^. Getting Prices (PParams ConwayEra) Prices
forall era. AlonzoEraPParams era => Lens' (PParams era) Prices
Lens' (PParams ConwayEra) Prices
ppPricesL
allExunits :: ExUnits
allExunits = (ExecutionUnits -> ExUnits) -> [ExecutionUnits] -> ExUnits
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ExecutionUnits -> ExUnits
toLedgerExUnits ([ExecutionUnits] -> ExUnits)
-> ([Either ScriptExecutionError ExecutionUnits]
-> [ExecutionUnits])
-> [Either ScriptExecutionError ExecutionUnits]
-> ExUnits
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either ScriptExecutionError ExecutionUnits] -> [ExecutionUnits]
forall a b. [Either a b] -> [b]
rights ([Either ScriptExecutionError ExecutionUnits] -> ExUnits)
-> [Either ScriptExecutionError ExecutionUnits] -> ExUnits
forall a b. (a -> b) -> a -> b
$ EvaluationReport -> [Either ScriptExecutionError ExecutionUnits]
forall a. Map ScriptWitnessIndex a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList EvaluationReport
evaluationReport
refScriptsFee :: Coin
refScriptsFee =
PParams ConwayEra -> Tx TopTx ConwayEra -> Int -> Coin
forall era (l :: TxLevel).
EraTx era =>
PParams era -> Tx l era -> Int -> Coin
forall (l :: TxLevel).
PParams ConwayEra -> Tx l ConwayEra -> Int -> Coin
getMinFeeTx PParams LedgerEra
PParams ConwayEra
pparams' Tx TopTx LedgerEra
Tx TopTx ConwayEra
ledgerTx (UTxO ConwayEra -> Tx TopTx ConwayEra -> Int
forall era (l :: TxLevel).
(EraTx era, BabbageEraTxBody era) =>
UTxO era -> Tx l era -> Int
txNonDistinctRefScriptsSize (ShelleyBasedEra Era -> UTxO -> UTxO LedgerEra
forall era.
ShelleyBasedEra era -> UTxO era -> UTxO (ShelleyLedgerEra era)
toLedgerUTxO ShelleyBasedEra Era
forall era. IsShelleyBasedEra era => ShelleyBasedEra era
shelleyBasedEra UTxO
utxo) Tx TopTx LedgerEra
Tx TopTx ConwayEra
ledgerTx)
Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<-> PParams ConwayEra -> Tx TopTx ConwayEra -> Int -> Coin
forall era (l :: TxLevel).
EraTx era =>
PParams era -> Tx l era -> Int -> Coin
forall (l :: TxLevel).
PParams ConwayEra -> Tx l ConwayEra -> Int -> Coin
getMinFeeTx PParams LedgerEra
PParams ConwayEra
pparams' Tx TopTx LedgerEra
Tx TopTx ConwayEra
ledgerTx Int
0
ledgerTx :: Tx TopTx LedgerEra
ledgerTx = Tx -> Tx TopTx LedgerEra
forall era. Tx era -> Tx TopTx (ShelleyLedgerEra era)
toLedgerTx Tx
tx