diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs index 4b034b890fe..412d7c43793 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs @@ -91,9 +91,6 @@ module Cardano.Wallet.Shelley.Compatibility , fromAlonzoPParams , fromLedgerExUnits , toLedgerExUnits - , fromLedgerPParams - , fromLedgerAlonzoPParams - , toAlonzoPParams , fromCardanoAddress , toSystemStart , toScriptPurpose @@ -256,7 +253,7 @@ import Control.Applicative import Control.Arrow ( left ) import Control.Monad - ( join, when, (>=>) ) + ( when, (>=>) ) import Crypto.Hash.Utils ( blake2b224 ) import Data.Array @@ -363,15 +360,10 @@ import qualified Cardano.Ledger.Alonzo.TxBody as Alonzo import qualified Cardano.Ledger.Alonzo.TxSeq as Alonzo import qualified Cardano.Ledger.Alonzo.TxWitness as Alonzo import qualified Cardano.Ledger.Babbage as Babbage -import qualified Cardano.Ledger.Babbage.PParams as Babbage import qualified Cardano.Ledger.Babbage.Tx as Babbage hiding ( ScriptIntegrityHash, TxBody ) import qualified Cardano.Ledger.Babbage.TxBody as Babbage -import qualified Cardano.Ledger.BaseTypes as BT -import qualified Cardano.Ledger.BaseTypes as Ledger import qualified Cardano.Ledger.BaseTypes as SL -import qualified Cardano.Ledger.Coin as Ledger -import qualified Cardano.Ledger.Core as Ledger import qualified Cardano.Ledger.Core as SL.Core import qualified Cardano.Ledger.Credential as SL import qualified Cardano.Ledger.Crypto as SL @@ -383,7 +375,6 @@ import qualified Cardano.Ledger.Shelley as SL hiding import qualified Cardano.Ledger.Shelley.API as SL import qualified Cardano.Ledger.Shelley.API as SLAPI import qualified Cardano.Ledger.Shelley.BlockChain as SL -import qualified Cardano.Ledger.Shelley.PParams as Shelley import qualified Cardano.Ledger.Shelley.Tx as Shelley import qualified Cardano.Ledger.ShelleyMA as MA import qualified Cardano.Ledger.ShelleyMA.AuxiliaryData as MA @@ -863,8 +854,8 @@ executionUnitPricesFromPParams pp = prices = getField @"_prices" pp fromAlonzoPrices Alonzo.Prices{prMem, prSteps} = W.ExecutionUnitPrices - { W.pricePerStep = Ledger.unboundRational prSteps - , W.pricePerMemoryUnit = Ledger.unboundRational prMem + { W.pricePerStep = SL.unboundRational prSteps + , W.pricePerMemoryUnit = SL.unboundRational prMem } fromLedgerExUnits @@ -906,326 +897,6 @@ txParametersFromPParams maxBundleSize getMaxExecutionUnits pp = W.TxParameters naturalToDouble :: Natural -> Double naturalToDouble = fromIntegral --------------------------------------------------------------------------------- --- Copied from cardano-api --- To be removed when once again exposed. --------------------------------------------------------------------------------- - -fromLedgerPParams - :: Cardano.ShelleyBasedEra era - -> Ledger.PParams (Cardano.ShelleyLedgerEra era) - -> Cardano.ProtocolParameters -fromLedgerPParams Cardano.ShelleyBasedEraShelley = fromLedgerShelleyPParams -fromLedgerPParams Cardano.ShelleyBasedEraAllegra = fromLedgerShelleyPParams -fromLedgerPParams Cardano.ShelleyBasedEraMary = fromLedgerShelleyPParams -fromLedgerPParams Cardano.ShelleyBasedEraAlonzo = fromLedgerAlonzoPParams -fromLedgerPParams Cardano.ShelleyBasedEraBabbage = fromLedgerBabbagePParams - -fromShelleyLovelace :: Ledger.Coin -> Cardano.Lovelace -fromShelleyLovelace (Ledger.Coin c) = Cardano.Lovelace c - -fromLedgerNonce :: Ledger.Nonce -> Maybe Cardano.PraosNonce -fromLedgerNonce Ledger.NeutralNonce = Nothing -fromLedgerNonce (Ledger.Nonce h) = - Just (Cardano.makePraosNonce $ Crypto.hashToBytes h) - -fromLedgerShelleyPParams - :: Shelley.PParams ledgerera - -> Cardano.ProtocolParameters -fromLedgerShelleyPParams - Shelley.PParams { - Shelley._minfeeA - , Shelley._minfeeB - , Shelley._maxBBSize - , Shelley._maxTxSize - , Shelley._maxBHSize - , Shelley._keyDeposit - , Shelley._poolDeposit - , Shelley._eMax - , Shelley._nOpt - , Shelley._a0 - , Shelley._rho - , Shelley._tau - , Shelley._d - , Shelley._extraEntropy - , Shelley._protocolVersion - , Shelley._minUTxOValue - , Shelley._minPoolCost - } = Cardano.ProtocolParameters { - protocolParamProtocolVersion = (\(BT.ProtVer a b) -> (a,b)) - _protocolVersion - , protocolParamDecentralization = Just $ SL.unboundRational _d - , protocolParamExtraPraosEntropy = fromLedgerNonce _extraEntropy - , protocolParamMaxBlockHeaderSize = _maxBHSize - , protocolParamMaxBlockBodySize = _maxBBSize - , protocolParamMaxTxSize = _maxTxSize - , protocolParamTxFeeFixed = _minfeeB - , protocolParamTxFeePerByte = _minfeeA - , protocolParamMinUTxOValue = Just (fromShelleyLovelace _minUTxOValue) - , protocolParamStakeAddressDeposit = fromShelleyLovelace _keyDeposit - , protocolParamStakePoolDeposit = fromShelleyLovelace _poolDeposit - , protocolParamMinPoolCost = fromShelleyLovelace _minPoolCost - , protocolParamPoolRetireMaxEpoch = _eMax - , protocolParamStakePoolTargetNum = _nOpt - , protocolParamPoolPledgeInfluence = SL.unboundRational _a0 - , protocolParamMonetaryExpansion = SL.unboundRational _rho - , protocolParamTreasuryCut = SL.unboundRational _tau - , protocolParamUTxOCostPerWord = Nothing - , protocolParamCostModels = Map.empty - , protocolParamPrices = Nothing - , protocolParamMaxTxExUnits = Nothing - , protocolParamMaxBlockExUnits = Nothing - , protocolParamMaxValueSize = Nothing - , protocolParamCollateralPercent = Nothing - , protocolParamMaxCollateralInputs = Nothing - } - -fromLedgerAlonzoPParams - :: Alonzo.PParams ledgerera - -> Cardano.ProtocolParameters -fromLedgerAlonzoPParams - Alonzo.PParams { - Alonzo._minfeeA - , Alonzo._minfeeB - , Alonzo._maxBBSize - , Alonzo._maxTxSize - , Alonzo._maxBHSize - , Alonzo._keyDeposit - , Alonzo._poolDeposit - , Alonzo._eMax - , Alonzo._nOpt - , Alonzo._a0 - , Alonzo._rho - , Alonzo._tau - , Alonzo._d - , Alonzo._extraEntropy - , Alonzo._protocolVersion - , Alonzo._minPoolCost - , Alonzo._coinsPerUTxOWord - , Alonzo._costmdls - , Alonzo._prices - , Alonzo._maxTxExUnits - , Alonzo._maxBlockExUnits - , Alonzo._maxValSize - , Alonzo._collateralPercentage - , Alonzo._maxCollateralInputs - } = Cardano.ProtocolParameters { - protocolParamProtocolVersion = (\(BT.ProtVer a b) -> (a,b)) - _protocolVersion - , protocolParamDecentralization = Just $ SL.unboundRational _d - , protocolParamExtraPraosEntropy = fromLedgerNonce _extraEntropy - , protocolParamMaxBlockHeaderSize = _maxBHSize - , protocolParamMaxBlockBodySize = _maxBBSize - , protocolParamMaxTxSize = _maxTxSize - , protocolParamTxFeeFixed = _minfeeB - , protocolParamTxFeePerByte = _minfeeA - , protocolParamMinUTxOValue = Nothing - , protocolParamStakeAddressDeposit = fromShelleyLovelace _keyDeposit - , protocolParamStakePoolDeposit = fromShelleyLovelace _poolDeposit - , protocolParamMinPoolCost = fromShelleyLovelace _minPoolCost - , protocolParamPoolRetireMaxEpoch = _eMax - , protocolParamStakePoolTargetNum = _nOpt - , protocolParamPoolPledgeInfluence = SL.unboundRational _a0 - , protocolParamMonetaryExpansion = SL.unboundRational _rho - , protocolParamTreasuryCut = SL.unboundRational _tau - , protocolParamUTxOCostPerWord = Just (fromShelleyLovelace _coinsPerUTxOWord) - , protocolParamCostModels = fromAlonzoCostModels $ Alonzo.unCostModels _costmdls - , protocolParamPrices = Just (fromAlonzoPrices _prices) - , protocolParamMaxTxExUnits = Just (fromAlonzoExUnits _maxTxExUnits) - , protocolParamMaxBlockExUnits = Just (fromAlonzoExUnits _maxBlockExUnits) - , protocolParamMaxValueSize = Just _maxValSize - , protocolParamCollateralPercent = Just _collateralPercentage - , protocolParamMaxCollateralInputs = Just _maxCollateralInputs - } - where - fromAlonzoPrices :: Alonzo.Prices -> Cardano.ExecutionUnitPrices - fromAlonzoPrices Alonzo.Prices{Alonzo.prSteps, Alonzo.prMem} = Cardano.ExecutionUnitPrices - { priceExecutionSteps = Ledger.unboundRational prSteps - , priceExecutionMemory = Ledger.unboundRational prMem - } - - fromAlonzoExUnits :: Alonzo.ExUnits -> Cardano.ExecutionUnits - fromAlonzoExUnits Alonzo.ExUnits{Alonzo.exUnitsSteps, Alonzo.exUnitsMem} = Cardano.ExecutionUnits - { executionSteps = exUnitsSteps - , executionMemory = exUnitsMem - } - - fromAlonzoScriptLanguage :: Alonzo.Language -> Cardano.AnyPlutusScriptVersion - fromAlonzoScriptLanguage Alonzo.PlutusV1 = - Cardano.AnyPlutusScriptVersion Cardano.PlutusScriptV1 - fromAlonzoScriptLanguage Alonzo.PlutusV2 = - Cardano.AnyPlutusScriptVersion Cardano.PlutusScriptV2 - - fromAlonzoCostModel :: Alonzo.CostModel -> Cardano.CostModel - fromAlonzoCostModel m = Cardano.CostModel $ Alonzo.getCostModelParams m - - fromAlonzoCostModels - :: Map Alonzo.Language Alonzo.CostModel - -> Map Cardano.AnyPlutusScriptVersion Cardano.CostModel - fromAlonzoCostModels = - Map.fromList - . map (bimap fromAlonzoScriptLanguage fromAlonzoCostModel) - . Map.toList - -fromLedgerBabbagePParams - :: Babbage.PParams ledgerera - -> Cardano.ProtocolParameters -fromLedgerBabbagePParams = undefined - - -toAlonzoPParams - :: Cardano.ProtocolParameters - -> Alonzo.PParams era -toAlonzoPParams - Cardano.ProtocolParameters - { protocolParamProtocolVersion - , protocolParamDecentralization - , protocolParamExtraPraosEntropy - , protocolParamMaxBlockHeaderSize - , protocolParamMaxBlockBodySize - , protocolParamMaxTxSize - , protocolParamTxFeeFixed - , protocolParamTxFeePerByte - , protocolParamStakeAddressDeposit - , protocolParamStakePoolDeposit - , protocolParamMinPoolCost - , protocolParamPoolRetireMaxEpoch - , protocolParamStakePoolTargetNum - , protocolParamPoolPledgeInfluence - , protocolParamMonetaryExpansion - , protocolParamTreasuryCut - , protocolParamUTxOCostPerWord = Just utxoCostPerWord - , protocolParamCostModels - , protocolParamPrices = Just prices - , protocolParamMaxTxExUnits = Just maxTxExUnits - , protocolParamMaxBlockExUnits = Just maxBlockExUnits - , protocolParamMaxValueSize = Just maxValueSize - , protocolParamCollateralPercent = Just collateralPercentage - , protocolParamMaxCollateralInputs = Just maxCollateralInputs - } = - Alonzo.PParams - { Alonzo._protocolVersion = - let (maj, minor) = protocolParamProtocolVersion - in BT.ProtVer maj minor - , Alonzo._d = - fromMaybe - (error "toAlonzoPParams: invalid Decentralization value") - (join $ Ledger.boundRational <$> protocolParamDecentralization) - , Alonzo._extraEntropy = - toLedgerNonce protocolParamExtraPraosEntropy - , Alonzo._maxBHSize = - protocolParamMaxBlockHeaderSize - , Alonzo._maxBBSize = - protocolParamMaxBlockBodySize - , Alonzo._maxTxSize = - protocolParamMaxTxSize - , Alonzo._minfeeB = - protocolParamTxFeeFixed - , Alonzo._minfeeA = - protocolParamTxFeePerByte - , Alonzo._keyDeposit = - toShelleyLovelace protocolParamStakeAddressDeposit - , Alonzo._poolDeposit = - toShelleyLovelace protocolParamStakePoolDeposit - , Alonzo._minPoolCost = - toShelleyLovelace protocolParamMinPoolCost - , Alonzo._eMax = - protocolParamPoolRetireMaxEpoch - , Alonzo._nOpt = - protocolParamStakePoolTargetNum - , Alonzo._a0 = - fromMaybe - (error "toAlonzoPParams: invalid PoolPledgeInfluence value") - (Ledger.boundRational protocolParamPoolPledgeInfluence) - , Alonzo._rho = - fromMaybe - (error "toAlonzoPParams: invalid MonetaryExpansion value") - (Ledger.boundRational protocolParamMonetaryExpansion) - , Alonzo._tau = - fromMaybe - (error "toAlonzoPParams: invalid TreasuryCut value") - (Ledger.boundRational protocolParamTreasuryCut) - , Alonzo._coinsPerUTxOWord = - toShelleyLovelace utxoCostPerWord - , Alonzo._costmdls = either - (\e -> error $ "toAlonzoPParams: invalid cost models, error: " <> e) - id - (toAlonzoCostModels protocolParamCostModels) - , Alonzo._prices = - fromMaybe - (error "toAlonzoPParams: invalid Price values") - (toAlonzoPrices prices) - , Alonzo._maxTxExUnits = - toAlonzoExUnits maxTxExUnits - , Alonzo._maxBlockExUnits = - toAlonzoExUnits maxBlockExUnits - , Alonzo._maxValSize = - maxValueSize - , Alonzo._collateralPercentage = - collateralPercentage - , Alonzo._maxCollateralInputs = - maxCollateralInputs - } - where - toShelleyLovelace :: Cardano.Lovelace -> SLAPI.Coin - toShelleyLovelace (Cardano.Lovelace l) = SLAPI.Coin l - - toAlonzoCostModels - :: Map Cardano.AnyPlutusScriptVersion Cardano.CostModel - -> Either String Alonzo.CostModels - toAlonzoCostModels m = do - f <- mapM conv $ Map.toList m - Right . Alonzo.CostModels $ Map.fromList f - where - conv :: (Cardano.AnyPlutusScriptVersion, Cardano.CostModel) -> Either String (Alonzo.Language, Alonzo.CostModel) - conv (anySVer, cModel )= do - alonzoCostModel <- toAlonzoCostModel cModel (toAlonzoScriptLanguage anySVer) - Right (toAlonzoScriptLanguage anySVer, alonzoCostModel) - - toAlonzoCostModel :: Cardano.CostModel -> Alonzo.Language -> Either String Alonzo.CostModel - toAlonzoCostModel (Cardano.CostModel m) l = Alonzo.mkCostModel l m - - toAlonzoScriptLanguage :: Cardano.AnyPlutusScriptVersion -> Alonzo.Language - toAlonzoScriptLanguage (Cardano.AnyPlutusScriptVersion Cardano.PlutusScriptV1) = - Alonzo.PlutusV1 - toAlonzoScriptLanguage (Cardano.AnyPlutusScriptVersion Cardano.PlutusScriptV2) = - Alonzo.PlutusV2 - - toAlonzoPrices :: Cardano.ExecutionUnitPrices -> Maybe Alonzo.Prices - toAlonzoPrices Cardano.ExecutionUnitPrices - { priceExecutionSteps - , priceExecutionMemory - } = do - prSteps <- Ledger.boundRational priceExecutionSteps - prMem <- Ledger.boundRational priceExecutionMemory - return Alonzo.Prices { Alonzo.prSteps, Alonzo.prMem } - - toAlonzoExUnits :: Cardano.ExecutionUnits -> Alonzo.ExUnits - toAlonzoExUnits Cardano.ExecutionUnits{executionSteps, executionMemory} = - Alonzo.ExUnits - { Alonzo.exUnitsSteps = executionSteps - , Alonzo.exUnitsMem = executionMemory - } - - toLedgerNonce :: Maybe Cardano.PraosNonce -> Ledger.Nonce - toLedgerNonce = \case - Nothing -> Ledger.NeutralNonce - Just nonce -> Ledger.Nonce (unsafeHashFromBytes (Cardano.serialiseToRawBytes nonce)) -toAlonzoPParams Cardano.ProtocolParameters { protocolParamUTxOCostPerWord = Nothing } = - error "toAlonzoPParams: must specify protocolParamUTxOCostPerWord" -toAlonzoPParams Cardano.ProtocolParameters { protocolParamPrices = Nothing } = - error "toAlonzoPParams: must specify protocolParamPrices" -toAlonzoPParams Cardano.ProtocolParameters { protocolParamMaxTxExUnits = Nothing } = - error "toAlonzoPParams: must specify protocolParamMaxTxExUnits" -toAlonzoPParams Cardano.ProtocolParameters { protocolParamMaxBlockExUnits = Nothing } = - error "toAlonzoPParams: must specify protocolParamMaxBlockExUnits" -toAlonzoPParams Cardano.ProtocolParameters { protocolParamMaxValueSize = Nothing } = - error "toAlonzoPParams: must specify protocolParamMaxValueSize" -toAlonzoPParams Cardano.ProtocolParameters { protocolParamCollateralPercent = Nothing } = - error "toAlonzoPParams: must specify protocolParamCollateralPercent" -toAlonzoPParams Cardano.ProtocolParameters { protocolParamMaxCollateralInputs = Nothing } = - error "toAlonzoPParams: must specify protocolParamMaxCollateralInputs" - toCostModelsAsArray :: Map Alonzo.Language Alonzo.CostModel -> Array Alonzo.Language Alonzo.CostModel diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility/Ledger.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility/Ledger.hs index 911bc14baf5..e97d01fd473 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility/Ledger.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility/Ledger.hs @@ -24,6 +24,7 @@ module Cardano.Wallet.Shelley.Compatibility.Ledger , toLedgerTokenName , toLedgerTokenQuantity , toAlonzoTxOut + , toBabbageTxOut -- * Conversions from ledger specification types to wallet types , toWalletCoin @@ -94,6 +95,8 @@ import qualified Cardano.Ledger.Address as Ledger import qualified Cardano.Ledger.Alonzo as Alonzo import qualified Cardano.Ledger.Alonzo.Rules.Utxo as Alonzo import qualified Cardano.Ledger.Alonzo.TxBody as Alonzo +import qualified Cardano.Ledger.Babbage as Babbage +import qualified Cardano.Ledger.Babbage.TxBody as Babbage import qualified Cardano.Ledger.Crypto as Ledger import qualified Cardano.Ledger.Keys as Ledger import qualified Cardano.Ledger.Mary.Value as Ledger @@ -299,6 +302,24 @@ toAlonzoTxOut (TxOut addr bundle) = \case (toLedger bundle) (Ledger.SJust $ unsafeMakeSafeHash $ Crypto.UnsafeHash $ toShort bytes) +toBabbageTxOut + :: TxOut + -> Maybe (Hash "Datum") + -> Babbage.TxOut (Babbage.BabbageEra StandardCrypto) +toBabbageTxOut (TxOut addr bundle) = \case + Nothing -> + Babbage.TxOut + (toLedger addr) + (toLedger bundle) + Babbage.NoDatum + Ledger.SNothing + Just (Hash bytes) -> + Babbage.TxOut + (toLedger addr) + (toLedger bundle) + (Babbage.DatumHash $ unsafeMakeSafeHash $ Crypto.UnsafeHash $ toShort bytes) + Ledger.SNothing + toWalletScript :: Ledger.Crypto crypto => KeyRole diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Network/Node.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Network/Node.hs index 1ca325bdb33..f0e7b86fc1d 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Network/Node.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley/Network/Node.hs @@ -43,7 +43,6 @@ import Cardano.Api , NodeToClientVersion (..) , SlotNo (..) , connectToLocalNode - , fromLedgerPParams ) import Cardano.BM.Data.Severity ( Severity (..) ) @@ -692,15 +691,15 @@ mkTipSyncClient tr np onPParamsUpdate onInterpreterUpdate onEraUpdate = do ppNode <- onAnyEra (pure Nothing) - (Just . fromLedgerPParams Cardano.ShelleyBasedEraShelley + (Just . Cardano.fromLedgerPParams Cardano.ShelleyBasedEraShelley <$> LSQry Shelley.GetCurrentPParams) - (Just . fromLedgerPParams Cardano.ShelleyBasedEraAllegra + (Just . Cardano.fromLedgerPParams Cardano.ShelleyBasedEraAllegra <$> LSQry Shelley.GetCurrentPParams) - (Just . fromLedgerPParams Cardano.ShelleyBasedEraMary + (Just . Cardano.fromLedgerPParams Cardano.ShelleyBasedEraMary <$> LSQry Shelley.GetCurrentPParams) - (Just . fromLedgerPParams Cardano.ShelleyBasedEraAlonzo + (Just . Cardano.fromLedgerPParams Cardano.ShelleyBasedEraAlonzo <$> LSQry Shelley.GetCurrentPParams) - (Just . fromLedgerPParams Cardano.ShelleyBasedEraAlonzo + (Just . Cardano.fromLedgerPParams Cardano.ShelleyBasedEraAlonzo <$> LSQry Shelley.GetCurrentPParams) pp <- onAnyEra diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Transaction.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Transaction.hs index a4c4901b8ec..57b0fe8f3c8 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Transaction.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley/Transaction.hs @@ -159,7 +159,6 @@ import Cardano.Wallet.Shelley.Compatibility , fromCardanoTxIn , fromCardanoWdrls , fromShelleyTxIn - , toAlonzoPParams , toCardanoLovelace , toCardanoPolicyId , toCardanoSimpleScript @@ -175,7 +174,7 @@ import Cardano.Wallet.Shelley.Compatibility , toStakePoolDlgCert ) import Cardano.Wallet.Shelley.Compatibility.Ledger - ( computeMinimumAdaQuantity, toAlonzoTxOut ) + ( computeMinimumAdaQuantity, toAlonzoTxOut, toBabbageTxOut ) import Cardano.Wallet.Transaction ( AnyScript (..) , DelegationAction (..) @@ -257,6 +256,7 @@ import qualified Cardano.Ledger.Alonzo.Scripts as Alonzo import qualified Cardano.Ledger.Alonzo.Tx as Alonzo import qualified Cardano.Ledger.Alonzo.TxWitness as Alonzo import qualified Cardano.Ledger.Babbage.Tx as Babbage +import qualified Cardano.Ledger.Babbage.PParams as Babbage import qualified Cardano.Ledger.Coin as Ledger import qualified Cardano.Ledger.Core as Ledger import qualified Cardano.Ledger.Shelley.Address.Bootstrap as SL @@ -1131,6 +1131,9 @@ _maxScriptExecutionCost pp redeemers type AlonzoTx = Ledger.Tx (Cardano.ShelleyLedgerEra Cardano.AlonzoEra) +type BabbageTx = + Ledger.Tx (Cardano.ShelleyLedgerEra Cardano.BabbageEra) + _assignScriptRedeemers :: forall era. Cardano.IsShelleyBasedEra era => Cardano.ProtocolParameters @@ -1139,7 +1142,7 @@ _assignScriptRedeemers -> [Redeemer] -> Cardano.Tx era -> Either ErrAssignRedeemers (Cardano.Tx era ) -_assignScriptRedeemers (toAlonzoPParams -> pparams) ti resolveInput redeemers tx = +_assignScriptRedeemers pparams ti resolveInput redeemers tx = case Cardano.shelleyBasedEra @era of Cardano.ShelleyBasedEraShelley -> pure tx @@ -1150,23 +1153,30 @@ _assignScriptRedeemers (toAlonzoPParams -> pparams) ti resolveInput redeemers tx Cardano.ShelleyBasedEraAlonzo -> do let Cardano.ShelleyTx _ alonzoTx = tx alonzoTx' <- flip execStateT alonzoTx $ do - indexedRedeemers <- StateT assignNullRedeemers + indexedRedeemers <- StateT assignNullRedeemersAlonzo executionUnits <- get - >>= lift . evaluateExecutionUnits indexedRedeemers - modifyM (assignExecutionUnits executionUnits) - modify' addScriptIntegrityHash + >>= lift . evaluateExecutionUnitsAlonzo indexedRedeemers + modifyM (assignExecutionUnitsAlonzo executionUnits) + modify' addScriptIntegrityHashAlonzo pure $ Cardano.ShelleyTx ShelleyBasedEraAlonzo alonzoTx' Cardano.ShelleyBasedEraBabbage -> do - error "TODO: Babbage _assignScriptRedeemers" + let Cardano.ShelleyTx _ babbageTx = tx + babbageTx' <- flip execStateT babbageTx $ do + indexedRedeemers <- StateT assignNullRedeemersBabbage + executionUnits <- get + >>= lift . evaluateExecutionUnitsBabbage indexedRedeemers + modifyM (assignExecutionUnitsBabbage executionUnits) + modify' addScriptIntegrityHashBabbage + pure $ Cardano.ShelleyTx ShelleyBasedEraBabbage babbageTx' where -- | Assign redeemers with null execution units to the input transaction. -- -- Redeemers are determined from the context given to the caller via the -- 'Redeemer' type which is mapped to an 'Alonzo.ScriptPurpose'. - assignNullRedeemers + assignNullRedeemersAlonzo :: AlonzoTx -> Either ErrAssignRedeemers (Map Alonzo.RdmrPtr Redeemer, AlonzoTx) - assignNullRedeemers alonzoTx = do + assignNullRedeemersAlonzo alonzoTx = do (indexedRedeemers, nullRedeemers) <- fmap unzip $ forM redeemers $ \rd -> do ptr <- case Alonzo.rdptr (Alonzo.body alonzoTx) (toScriptPurpose rd) of SNothing -> @@ -1191,6 +1201,34 @@ _assignScriptRedeemers (toAlonzoPParams -> pparams) ti resolveInput redeemers tx } ) + assignNullRedeemersBabbage + :: BabbageTx + -> Either ErrAssignRedeemers (Map Alonzo.RdmrPtr Redeemer, BabbageTx) + assignNullRedeemersBabbage babbageTx = do + (indexedRedeemers, nullRedeemers) <- fmap unzip $ forM redeemers $ \rd -> do + ptr <- case Alonzo.rdptr (Alonzo.body babbageTx) (toScriptPurpose rd) of + SNothing -> + Left $ ErrAssignRedeemersTargetNotFound rd + SJust ptr -> + pure ptr + + rData <- case deserialiseOrFail (BL.fromStrict $ redeemerData rd) of + Left e -> + Left $ ErrAssignRedeemersInvalidData rd (show e) + Right d -> + pure (Alonzo.Data d) + + pure ((ptr, rd), (ptr, (rData, mempty))) + + pure + ( Map.fromList indexedRedeemers + , babbageTx + { Alonzo.wits = (Alonzo.wits babbageTx) + { Alonzo.txrdmrs = Alonzo.Redeemers (Map.fromList nullRedeemers) + } + } + ) + utxoFromAlonzoTx :: AlonzoTx -> Ledger.UTxO (Cardano.ShelleyLedgerEra Cardano.AlonzoEra) @@ -1208,23 +1246,42 @@ _assignScriptRedeemers (toAlonzoPParams -> pparams) ti resolveInput redeemers tx in Ledger.UTxO (Map.fromList utxo) + utxoFromBabbageTx + :: BabbageTx + -> Ledger.UTxO (Cardano.ShelleyLedgerEra Cardano.BabbageEra) + utxoFromBabbageTx babbageTx = + let + inputs = Babbage.inputs (Alonzo.body babbageTx) + utxo = flip mapMaybe (F.toList inputs) $ \i -> do + (o, dt) <- resolveInput (fromShelleyTxIn i) + -- NOTE: 'toAlonzoTxOut' only partially represent the information + -- because the wallet internal types aren't capturing datum at + -- the moment. It is _okay_ in this context because the + -- resulting UTxO is only used by 'evaluateTransactionExecutionUnits' + -- to lookup addresses corresponding to inputs. + pure (i, toBabbageTxOut o dt) + in + Ledger.UTxO (Map.fromList utxo) + + -- | Evaluate execution units of each script/redeemer in the transaction. -- This may fail for each script. - evaluateExecutionUnits + evaluateExecutionUnitsAlonzo :: Map Alonzo.RdmrPtr Redeemer -> AlonzoTx -> Either ErrAssignRedeemers (Map Alonzo.RdmrPtr (Either ErrAssignRedeemers Alonzo.ExUnits)) - evaluateExecutionUnits indexedRedeemers alonzoTx = do + evaluateExecutionUnitsAlonzo indexedRedeemers alonzoTx = do let utxo = utxoFromAlonzoTx alonzoTx - let costs = toCostModelsAsArray (Alonzo.unCostModels $ Alonzo._costmdls pparams) + let pparams' = Cardano.toLedgerPParams Cardano.ShelleyBasedEraAlonzo pparams + let costs = toCostModelsAsArray (Alonzo.unCostModels $ Alonzo._costmdls pparams') let systemStart = getSystemStart ti epochInfo <- hoistEpochInfo (left ErrAssignRedeemersPastHorizon . runIdentity . runExceptT) <$> left ErrAssignRedeemersPastHorizon (toEpochInfo ti) res <- evaluateTransactionExecutionUnits - pparams + pparams' alonzoTx utxo epochInfo @@ -1237,22 +1294,53 @@ _assignScriptRedeemers (toAlonzoPParams -> pparams) ti resolveInput redeemers tx error "TODO: Babbage evaluateExecutionUnits" Right report -> - Right $ hoistScriptFailure report - where - hoistScriptFailure - :: Show scriptFailure - => Map Alonzo.RdmrPtr (Either scriptFailure a) - -> Map Alonzo.RdmrPtr (Either ErrAssignRedeemers a) - hoistScriptFailure = Map.mapWithKey $ \ptr -> left $ \e -> - ErrAssignRedeemersScriptFailure (indexedRedeemers ! ptr) (show e) + Right $ hoistScriptFailure indexedRedeemers report + + evaluateExecutionUnitsBabbage + :: Map Alonzo.RdmrPtr Redeemer + -> BabbageTx + -> Either ErrAssignRedeemers + (Map Alonzo.RdmrPtr (Either ErrAssignRedeemers Alonzo.ExUnits)) + evaluateExecutionUnitsBabbage indexedRedeemers babbageTx = do + let utxo = utxoFromBabbageTx babbageTx + let pparams' = Cardano.toLedgerPParams Cardano.ShelleyBasedEraBabbage pparams + let costs = toCostModelsAsArray (Alonzo.unCostModels $ Babbage._costmdls pparams') + let systemStart = getSystemStart ti + + epochInfo <- hoistEpochInfo (left ErrAssignRedeemersPastHorizon . runIdentity . runExceptT) + <$> left ErrAssignRedeemersPastHorizon (toEpochInfo ti) + + res <- evaluateTransactionExecutionUnits + pparams' + babbageTx + utxo + epochInfo + systemStart + costs + case res of + Left (UnknownTxIns ins) -> + Left $ ErrAssignRedeemersUnresolvedTxIns $ map fromShelleyTxIn (F.toList ins) + Left (BadTranslation _) -> do + error "TODO: Babbage evaluateExecutionUnits" + + Right report -> + Right $ hoistScriptFailure indexedRedeemers report + + hoistScriptFailure + :: Show scriptFailure + => Map Alonzo.RdmrPtr Redeemer + -> Map Alonzo.RdmrPtr (Either scriptFailure a) + -> Map Alonzo.RdmrPtr (Either ErrAssignRedeemers a) + hoistScriptFailure indexedRedeemers = Map.mapWithKey $ \ptr -> left $ \e -> + ErrAssignRedeemersScriptFailure (indexedRedeemers ! ptr) (show e) -- | Change execution units for each redeemers in the transaction to what -- they ought to be. - assignExecutionUnits + assignExecutionUnitsAlonzo :: Map Alonzo.RdmrPtr (Either ErrAssignRedeemers Alonzo.ExUnits) -> AlonzoTx -> Either ErrAssignRedeemers AlonzoTx - assignExecutionUnits exUnits alonzoTx = do + assignExecutionUnitsAlonzo exUnits alonzoTx = do let wits = Alonzo.wits alonzoTx let Alonzo.Redeemers rdmrs = Alonzo.txrdmrs wits rdmrs' <- Map.mergeA @@ -1266,21 +1354,40 @@ _assignScriptRedeemers (toAlonzoPParams -> pparams) ti resolveInput redeemers tx { Alonzo.txrdmrs = Alonzo.Redeemers rdmrs' } } - where - assignUnits - :: (dat, Alonzo.ExUnits) - -> Either err Alonzo.ExUnits - -> Either err (dat, Alonzo.ExUnits) - assignUnits (dats, _zero) = - fmap (dats,) + + assignExecutionUnitsBabbage + :: Map Alonzo.RdmrPtr (Either ErrAssignRedeemers Alonzo.ExUnits) + -> BabbageTx + -> Either ErrAssignRedeemers BabbageTx + assignExecutionUnitsBabbage exUnits babbageTx = do + let wits = Alonzo.wits babbageTx + let Alonzo.Redeemers rdmrs = Alonzo.txrdmrs wits + rdmrs' <- Map.mergeA + Map.preserveMissing + Map.dropMissing + (Map.zipWithAMatched (const assignUnits)) + rdmrs + exUnits + pure $ babbageTx + { Alonzo.wits = wits + { Alonzo.txrdmrs = Alonzo.Redeemers rdmrs' + } + } + + assignUnits + :: (dat, Alonzo.ExUnits) + -> Either err Alonzo.ExUnits + -> Either err (dat, Alonzo.ExUnits) + assignUnits (dats, _zero) = + fmap (dats,) -- | Finally, calculate and add the script integrity hash with the new -- final redeemers, if any. - addScriptIntegrityHash + addScriptIntegrityHashAlonzo :: forall e. (e ~ Cardano.ShelleyLedgerEra Cardano.AlonzoEra) => AlonzoTx -> AlonzoTx - addScriptIntegrityHash alonzoTx = + addScriptIntegrityHashAlonzo alonzoTx = let wits = Alonzo.wits alonzoTx langs = @@ -1293,7 +1400,31 @@ _assignScriptRedeemers (toAlonzoPParams -> pparams) ti resolveInput redeemers tx alonzoTx { Alonzo.body = (Alonzo.body alonzoTx) { Alonzo.scriptIntegrityHash = Alonzo.hashScriptIntegrity - pparams + (Cardano.toLedgerPParams Cardano.ShelleyBasedEraAlonzo pparams) + (Set.fromList langs) + (Alonzo.txrdmrs wits) + (Alonzo.txdats wits) + } + } + + addScriptIntegrityHashBabbage + :: forall e. ( e ~ Cardano.ShelleyLedgerEra Cardano.BabbageEra ) + => BabbageTx + -> BabbageTx + addScriptIntegrityHashBabbage babbageTx = + let + wits = Alonzo.wits babbageTx + langs = + [ l + | (_hash, script) <- Map.toList (Alonzo.txscripts wits) + , (not . isNativeScript @e) script + , Just l <- [Alonzo.language script] + ] + in + babbageTx + { Babbage.body = (Babbage.body babbageTx) + { Babbage.scriptIntegrityHash = Alonzo.hashScriptIntegrity + (Cardano.toLedgerPParams Cardano.ShelleyBasedEraBabbage pparams) (Set.fromList langs) (Alonzo.txrdmrs wits) (Alonzo.txdats wits)