From 71bca156bc8ff0656822e2899f47e01f6f58ec86 Mon Sep 17 00:00:00 2001 From: Yura Lazarev Date: Wed, 15 Mar 2023 18:54:51 +0100 Subject: [PATCH] Fix partial pattern matches by adding Conway case --- .../Cardano/Wallet/Api/Http/Shelley/Server.hs | 7 +- lib/wallet/src/Cardano/Wallet/Pools.hs | 8 + .../src/Cardano/Wallet/Read/Primitive/Tx.hs | 4 + .../Read/Primitive/Tx/Features/Validity.hs | 1 + .../Cardano/Wallet/Shelley/Compatibility.hs | 83 ++++-- .../Cardano/Wallet/Shelley/Network/Node.hs | 20 +- .../src/Cardano/Wallet/Shelley/Transaction.hs | 255 +++++++++++++----- lib/wallet/src/Cardano/Wallet/Write/Tx.hs | 8 +- 8 files changed, 279 insertions(+), 107 deletions(-) diff --git a/lib/wallet/api/http/Cardano/Wallet/Api/Http/Shelley/Server.hs b/lib/wallet/api/http/Cardano/Wallet/Api/Http/Shelley/Server.hs index b1d6cf98f29..a20b606aa2b 100644 --- a/lib/wallet/api/http/Cardano/Wallet/Api/Http/Shelley/Server.hs +++ b/lib/wallet/api/http/Cardano/Wallet/Api/Http/Shelley/Server.hs @@ -4139,6 +4139,7 @@ type RewardAccountBuilder k guardIsRecentEra :: AnyCardanoEra -> Handler AnyRecentEra guardIsRecentEra (Cardano.AnyCardanoEra era) = case era of + Cardano.ConwayEra -> pure $ WriteTx.AnyRecentEra WriteTx.RecentEraConway Cardano.BabbageEra -> pure $ WriteTx.AnyRecentEra WriteTx.RecentEraBabbage Cardano.AlonzoEra -> pure $ WriteTx.AnyRecentEra WriteTx.RecentEraAlonzo Cardano.MaryEra -> liftE invalidEra @@ -4786,7 +4787,7 @@ data ErrUnexpectedPoolIdPlaceholder = ErrUnexpectedPoolIdPlaceholder deriving (Eq, Show) data ErrCreateWallet - = ErrCreateWalletAlreadyExists ErrWalletAlreadyExists + = ErrCreateWalletAlreadyExists !ErrWalletAlreadyExists -- ^ Wallet already exists | ErrCreateWalletFailedToCreateWorker -- ^ Somehow, we couldn't create a worker or open a db connection @@ -4842,8 +4843,8 @@ instance IsServerError ErrGetAsset where -- | The type of log messages coming from the server 'ApiLayer', which may or -- may not be associated with a particular worker thread. data WalletEngineLog - = MsgWalletWorker (WorkerLog WalletId W.WalletWorkerLog) - | MsgSubmitSealedTx TxSubmitLog + = MsgWalletWorker !(WorkerLog WalletId W.WalletWorkerLog) + | MsgSubmitSealedTx !TxSubmitLog deriving (Show, Eq) instance ToText WalletEngineLog where diff --git a/lib/wallet/src/Cardano/Wallet/Pools.hs b/lib/wallet/src/Cardano/Wallet/Pools.hs index 1a2749e6fd0..5bd0023c60e 100644 --- a/lib/wallet/src/Cardano/Wallet/Pools.hs +++ b/lib/wallet/src/Cardano/Wallet/Pools.hs @@ -109,11 +109,14 @@ import Cardano.Wallet.Shelley.Compatibility , fromAllegraBlock , fromAlonzoBlock , fromBabbageBlock + , fromConwayBlock , fromMaryBlock , fromShelleyBlock , getBabbageProducer + , getConwayProducer , getProducer , toBabbageBlockHeader + , toConwayBlockHeader , toShelleyBlockHeader ) import Cardano.Wallet.Unsafe @@ -654,6 +657,9 @@ monitorStakePools tr (NetworkParameters gp sp _pp) genesisPools nl DBLayer{..} = BlockBabbage blk -> forEachShelleyBlock (fromBabbageBlock gp blk) (getBabbageProducer blk) + BlockConway blk -> + forEachShelleyBlock + (fromConwayBlock gp blk) (getConwayProducer blk) forLastBlock = \case BlockByron blk -> @@ -668,6 +674,8 @@ monitorStakePools tr (NetworkParameters gp sp _pp) genesisPools nl DBLayer{..} = putHeader (toShelleyBlockHeader getGenesisBlockHash blk) BlockBabbage blk -> putHeader (toBabbageBlockHeader getGenesisBlockHash blk) + BlockConway blk -> + putHeader (toConwayBlockHeader getGenesisBlockHash blk) forEachShelleyBlock (blk, certificates) poolId = do let header = view #header blk diff --git a/lib/wallet/src/Cardano/Wallet/Read/Primitive/Tx.hs b/lib/wallet/src/Cardano/Wallet/Read/Primitive/Tx.hs index 8e98de8861b..45d262075ef 100644 --- a/lib/wallet/src/Cardano/Wallet/Read/Primitive/Tx.hs +++ b/lib/wallet/src/Cardano/Wallet/Read/Primitive/Tx.hs @@ -21,6 +21,8 @@ import Cardano.Wallet.Read.Primitive.Tx.Babbage ( fromBabbageTx ) import Cardano.Wallet.Read.Primitive.Tx.Byron ( fromTxAux ) +import Cardano.Wallet.Read.Primitive.Tx.Conway + ( fromConwayTx ) import Cardano.Wallet.Read.Primitive.Tx.Mary ( fromMaryTx ) import Cardano.Wallet.Read.Primitive.Tx.Shelley @@ -63,6 +65,8 @@ fromCardanoTx witCtx = \case extract $ fromAlonzoTx tx witCtx Cardano.ShelleyBasedEraBabbage -> extract $ fromBabbageTx tx witCtx + Cardano.ShelleyBasedEraConway -> + extract $ fromConwayTx tx witCtx Cardano.ByronTx tx -> ( fromTxAux tx , emptyTokenMapWithScripts diff --git a/lib/wallet/src/Cardano/Wallet/Read/Primitive/Tx/Features/Validity.hs b/lib/wallet/src/Cardano/Wallet/Read/Primitive/Tx/Features/Validity.hs index efe39604a8b..9523a85b709 100644 --- a/lib/wallet/src/Cardano/Wallet/Read/Primitive/Tx/Features/Validity.hs +++ b/lib/wallet/src/Cardano/Wallet/Read/Primitive/Tx/Features/Validity.hs @@ -37,6 +37,7 @@ getValidity = EraFun , maryFun = yesMaryValidity , alonzoFun = yesMaryValidity , babbageFun = yesMaryValidity + , conwayFun = yesMaryValidity } where noValidity = const $ K Nothing diff --git a/lib/wallet/src/Cardano/Wallet/Shelley/Compatibility.hs b/lib/wallet/src/Cardano/Wallet/Shelley/Compatibility.hs index 66bcaf3297b..a22671862ec 100644 --- a/lib/wallet/src/Cardano/Wallet/Shelley/Compatibility.hs +++ b/lib/wallet/src/Cardano/Wallet/Shelley/Compatibility.hs @@ -87,6 +87,7 @@ module Cardano.Wallet.Shelley.Compatibility , fromMaryPParams , fromAlonzoPParams , fromBabbagePParams + , fromConwayPParams , fromLedgerExUnits , toLedgerExUnits , fromCardanoAddress @@ -141,7 +142,9 @@ module Cardano.Wallet.Shelley.Compatibility , fromMaryBlock , fromAlonzoBlock , fromBabbageBlock + , fromConwayBlock , getBabbageProducer + , getConwayProducer -- * Internal Conversions , decentralizationLevelFromPParams @@ -169,11 +172,11 @@ import Cardano.Api , AnyCardanoEra (..) , AsType (..) , BabbageEra - , ConwayEra , CardanoEra (..) , CardanoEraStyle (..) , CardanoMode , ConsensusModeParams (CardanoModeParams) + , ConwayEra , EraInMode (..) , InAnyCardanoEra (..) , IsCardanoEra (..) @@ -330,6 +333,7 @@ import Ouroboros.Consensus.Cardano.Block , StandardAllegra , StandardAlonzo , StandardBabbage + , StandardConway , StandardMary , StandardShelley ) @@ -377,6 +381,7 @@ import qualified Cardano.Ledger.Babbage.Tx as Babbage hiding import qualified Cardano.Ledger.Babbage.TxBody as Babbage import qualified Cardano.Ledger.BaseTypes as SL import qualified Cardano.Ledger.Conway as Conway +import qualified Cardano.Ledger.Conway.PParams as Conway import qualified Cardano.Ledger.Credential as SL import qualified Cardano.Ledger.Crypto as SL import qualified Cardano.Ledger.Era as Ledger.Era @@ -531,20 +536,15 @@ toBabbageBlockHeader -> ShelleyBlock (Consensus.Praos StandardCrypto) era -> W.BlockHeader toBabbageBlockHeader genesisHash blk = - let - ShelleyBlock (SL.Block header _txSeq) _headerHash = blk - in - W.BlockHeader - { slotNo = - Consensus.pHeaderSlot header - , blockHeight = - fromBlockNo $ Consensus.pHeaderBlock header - , headerHash = - fromShelleyHash $ Consensus.pHeaderHash header - , parentHeaderHash = Just $ - fromPrevHash (coerce genesisHash) $ - Consensus.pHeaderPrevHash header - } + W.BlockHeader + { slotNo = Consensus.pHeaderSlot header + , blockHeight = fromBlockNo $ Consensus.pHeaderBlock header + , headerHash = fromShelleyHash $ Consensus.pHeaderHash header + , parentHeaderHash = Just $ fromPrevHash (coerce genesisHash) $ + Consensus.pHeaderPrevHash header + } + where + ShelleyBlock (SL.Block header _txSeq) _headerHash = blk toConwayBlockHeader :: (ShelleyCompatible (Consensus.Praos StandardCrypto) era) @@ -552,20 +552,15 @@ toConwayBlockHeader -> ShelleyBlock (Consensus.Praos StandardCrypto) era -> W.BlockHeader toConwayBlockHeader genesisHash blk = - let - ShelleyBlock (SL.Block header _txSeq) _headerHash = blk - in - W.BlockHeader - { slotNo = - Consensus.pHeaderSlot header - , blockHeight = - fromBlockNo $ Consensus.pHeaderBlock header - , headerHash = - fromShelleyHash $ Consensus.pHeaderHash header - , parentHeaderHash = Just $ - fromPrevHash (coerce genesisHash) $ - Consensus.pHeaderPrevHash header - } + W.BlockHeader + { slotNo = Consensus.pHeaderSlot header + , blockHeight = fromBlockNo $ Consensus.pHeaderBlock header + , headerHash = fromShelleyHash $ Consensus.pHeaderHash header + , parentHeaderHash = Just $ fromPrevHash (coerce genesisHash) $ + Consensus.pHeaderPrevHash header + } + where + ShelleyBlock (SL.Block header _txSeq) _headerHash = blk getProducer :: (Era era, ToCBORGroup (Ledger.Era.TxSeq era)) @@ -579,6 +574,12 @@ getBabbageProducer getBabbageProducer (ShelleyBlock (SL.Block (Consensus.Header header _) _) _) = fromPoolKeyHash $ SL.hashKey (Consensus.hbVk header) +getConwayProducer + :: (Era era, ToCBORGroup (Ledger.Era.TxSeq era)) + => ShelleyBlock (Consensus.Praos StandardCrypto) era -> PoolId +getConwayProducer (ShelleyBlock (SL.Block (Consensus.Header header _) _) _) = + fromPoolKeyHash $ SL.hashKey (Consensus.hbVk header) + fromCardanoBlock :: W.GenesisParameters -> CardanoBlock StandardCrypto @@ -1007,6 +1008,30 @@ fromBabbagePParams eraInfo currentNodeProtocolParameters pp = , currentNodeProtocolParameters } +fromConwayPParams + :: HasCallStack + => W.EraInfo Bound + -> Maybe Cardano.ProtocolParameters + -> Babbage.BabbagePParams StandardConway + -> W.ProtocolParameters +fromConwayPParams eraInfo currentNodeProtocolParameters pp = + W.ProtocolParameters + { decentralizationLevel = decentralizationLevelFromPParams pp + , txParameters = txParametersFromPParams + (W.TokenBundleMaxSize $ W.TxSize $ Conway._maxValSize pp) + (fromLedgerExUnits (getField @"_maxTxExUnits" pp)) + pp + , desiredNumberOfStakePools = desiredNumberOfStakePoolsFromPParams pp + , minimumUTxO = minimumUTxOForShelleyBasedEra ShelleyBasedEraConway pp + , stakeKeyDeposit = stakeKeyDepositFromPParams pp + , eras = fromBoundToEpochNo <$> eraInfo + , maximumCollateralInputCount = + unsafeIntToWord $ Conway._maxCollateralInputs pp + , minimumCollateralPercentage = Conway._collateralPercentage pp + , executionUnitPrices = Just $ executionUnitPricesFromPParams pp + , currentNodeProtocolParameters + } + -- | Extract the current network decentralization level from the given set of -- protocol parameters. decentralizationLevelFromPParams diff --git a/lib/wallet/src/Cardano/Wallet/Shelley/Network/Node.hs b/lib/wallet/src/Cardano/Wallet/Shelley/Network/Node.hs index 6a3f10913f0..b17e6a46185 100644 --- a/lib/wallet/src/Cardano/Wallet/Shelley/Network/Node.hs +++ b/lib/wallet/src/Cardano/Wallet/Shelley/Network/Node.hs @@ -46,6 +46,8 @@ import Cardano.BM.Data.Tracer ( HasPrivacyAnnotation (..), HasSeverityAnnotation (..) ) import Cardano.Launcher.Node ( CardanoNodeConn, nodeSocketFile ) +import Cardano.Pool.Types + ( PoolId, StakePoolsSummary (..) ) import Cardano.Wallet.Byron.Compatibility ( byronCodecConfig, protocolParametersFromUpdateState ) import Cardano.Wallet.Logging @@ -77,6 +79,7 @@ import Cardano.Wallet.Shelley.Compatibility , fromAllegraPParams , fromAlonzoPParams , fromBabbagePParams + , fromConwayPParams , fromMaryPParams , fromNonMyopicMemberRewards , fromPoint @@ -214,6 +217,8 @@ import Ouroboros.Consensus.Protocol.Praos ( Praos ) import Ouroboros.Consensus.Protocol.TPraos ( TPraos ) +import Ouroboros.Consensus.Shelley.Eras + ( StandardConway ) import Ouroboros.Consensus.Shelley.Ledger.Config ( CodecConfig (..), getCompactGenesis ) import Ouroboros.Network.Block @@ -278,11 +283,10 @@ import qualified Cardano.Api as Cardano import qualified Cardano.Crypto.Hash as Crypto import qualified Cardano.Ledger.Alonzo.PParams as Alonzo import qualified Cardano.Ledger.Babbage.PParams as Babbage +import qualified Cardano.Ledger.Conway.PParams as Conway import qualified Cardano.Ledger.Crypto as SL import qualified Cardano.Ledger.Shelley.API as SL import qualified Cardano.Ledger.Shelley.LedgerState as SL -import Cardano.Pool.Types - ( PoolId, StakePoolsSummary (..) ) import qualified Cardano.Wallet.Primitive.SyncProgress as SP import qualified Cardano.Wallet.Primitive.Types as W import qualified Cardano.Wallet.Primitive.Types.Coin as W @@ -501,6 +505,8 @@ withNodeNetworkLayerBase <$> LSQry Shelley.GetCurrentPParams) (Just . fromIntegral . Babbage._nOpt <$> LSQry Shelley.GetCurrentPParams) + (Just . fromIntegral . Conway._nOpt + <$> LSQry Shelley.GetCurrentPParams) queryNonMyopicMemberRewards :: LSQ (CardanoBlock StandardCrypto) IO @@ -713,6 +719,8 @@ mkWalletToNodeProtocols <$> LSQry Shelley.GetCurrentPParams) (Just . Cardano.fromLedgerPParams Cardano.ShelleyBasedEraBabbage <$> LSQry Shelley.GetCurrentPParams) + (Just . Cardano.fromLedgerPParams Cardano.ShelleyBasedEraConway + <$> LSQry Shelley.GetCurrentPParams) pp <- onAnyEra (protocolParametersFromUpdateState eraBounds ppNode @@ -727,6 +735,8 @@ mkWalletToNodeProtocols <$> LSQry Shelley.GetCurrentPParams) (fromBabbagePParams eraBounds ppNode <$> LSQry Shelley.GetCurrentPParams) + (fromConwayPParams eraBounds ppNode + <$> LSQry Shelley.GetCurrentPParams) return (pp, sp) @@ -818,6 +828,7 @@ fetchRewardAccounts tr queryRewardQ accounts = do shelleyQry shelleyQry shelleyQry + shelleyQry (res,logs) <- bracketQuery "queryRewards" tr (send queryRewardQ (SomeLSQ qry)) liftIO $ mapM_ (traceWith tr) logs @@ -1373,6 +1384,7 @@ byronOrShelleyBased onByron onShelleyBased = onAnyEra onShelleyBased onShelleyBased onShelleyBased + onShelleyBased -- | Create a local state query specific to the each era. -- @@ -1390,8 +1402,9 @@ onAnyEra -> LSQ (Shelley.ShelleyBlock (TPraos StandardCrypto) StandardMary) m a -> LSQ (Shelley.ShelleyBlock (TPraos StandardCrypto) StandardAlonzo) m a -> LSQ (Shelley.ShelleyBlock (Praos StandardCrypto) StandardBabbage) m a + -> LSQ (Shelley.ShelleyBlock (Praos StandardCrypto) StandardConway) m a -> LSQ (CardanoBlock StandardCrypto) m a -onAnyEra onByron onShelley onAllegra onMary onAlonzo onBabbage = +onAnyEra onByron onShelley onAllegra onMary onAlonzo onBabbage onConway = currentEra >>= \case AnyCardanoEra ByronEra -> mapQuery QueryIfCurrentByron onByron AnyCardanoEra ShelleyEra -> mapQuery QueryIfCurrentShelley onShelley @@ -1399,6 +1412,7 @@ onAnyEra onByron onShelley onAllegra onMary onAlonzo onBabbage = AnyCardanoEra MaryEra -> mapQuery QueryIfCurrentMary onMary AnyCardanoEra AlonzoEra -> mapQuery QueryIfCurrentAlonzo onAlonzo AnyCardanoEra BabbageEra -> mapQuery QueryIfCurrentBabbage onBabbage + AnyCardanoEra ConwayEra -> mapQuery QueryIfCurrentConway onConway where mapQuery :: (forall r. BlockQuery block1 r diff --git a/lib/wallet/src/Cardano/Wallet/Shelley/Transaction.hs b/lib/wallet/src/Cardano/Wallet/Shelley/Transaction.hs index fb1a57ab451..49d9e594f63 100644 --- a/lib/wallet/src/Cardano/Wallet/Shelley/Transaction.hs +++ b/lib/wallet/src/Cardano/Wallet/Shelley/Transaction.hs @@ -293,6 +293,9 @@ import qualified Cardano.Ledger.Alonzo.TxWitness as Alonzo import qualified Cardano.Ledger.Babbage.PParams as Babbage import qualified Cardano.Ledger.Babbage.Tx as Babbage import qualified Cardano.Ledger.Coin as Ledger +import qualified Cardano.Ledger.Conway.PParams as Conway +import qualified Cardano.Ledger.Conway.Tx as Conway +import qualified Cardano.Ledger.Conway.TxBody as Conway import qualified Cardano.Ledger.Core as Ledger import qualified Cardano.Ledger.Keys.Bootstrap as SL import qualified Cardano.Ledger.Serialization as Ledger @@ -315,6 +318,8 @@ import qualified Data.Map.Merge.Strict as Map import qualified Data.Sequence.Strict as StrictSeq import qualified Data.Set as Set import qualified Data.Text as T +import Ouroboros.Consensus.Cardano.Block + ( StandardConway ) -- | Type encapsulating what we need to know to add things -- payloads, -- certificates -- to a transaction. @@ -641,6 +646,10 @@ newTransactionLayer networkId = TransactionLayer signTransaction networkId acctResolver policyResolver addressResolver inputResolver (body, wits) & sealedTxFromCardano' + InAnyCardanoEra ConwayEra (Cardano.Tx body wits) -> + signTransaction networkId acctResolver policyResolver + addressResolver inputResolver (body, wits) + & sealedTxFromCardano' , mkUnsignedTransaction = \stakeXPub _pp ctx selection -> do let ttl = txValidityInterval ctx @@ -776,28 +785,27 @@ updateSealedTx (Cardano.Tx body existingKeyWits) extraContent = do ShelleyBasedEraShelley -> Cardano.toShelleyScript $ Cardano.ScriptInEra Cardano.SimpleScriptInShelley - (Cardano.SimpleScript $ - toCardanoSimpleScriptV1 walletScript) + (Cardano.SimpleScript $ toCardanoSimpleScriptV1 walletScript) ShelleyBasedEraAllegra -> Cardano.toShelleyScript $ Cardano.ScriptInEra Cardano.SimpleScriptInAllegra - (Cardano.SimpleScript $ - toCardanoSimpleScript walletScript) + (Cardano.SimpleScript $ toCardanoSimpleScript walletScript) ShelleyBasedEraMary -> Cardano.toShelleyScript $ Cardano.ScriptInEra Cardano.SimpleScriptInMary - (Cardano.SimpleScript $ - toCardanoSimpleScript walletScript) + (Cardano.SimpleScript $ toCardanoSimpleScript walletScript) ShelleyBasedEraAlonzo -> Cardano.toShelleyScript $ Cardano.ScriptInEra Cardano.SimpleScriptInAlonzo - (Cardano.SimpleScript $ - toCardanoSimpleScript walletScript) + (Cardano.SimpleScript $ toCardanoSimpleScript walletScript) ShelleyBasedEraBabbage -> Cardano.toShelleyScript $ Cardano.ScriptInEra Cardano.SimpleScriptInBabbage - (Cardano.SimpleScript $ - toCardanoSimpleScript walletScript) + (Cardano.SimpleScript $ toCardanoSimpleScript walletScript) + ShelleyBasedEraConway -> + Cardano.toShelleyScript $ Cardano.ScriptInEra + Cardano.SimpleScriptInConway + (Cardano.SimpleScript $ toCardanoSimpleScript walletScript) -- NOTE: If the ShelleyMA MAClass were exposed, the Allegra and Mary -- cases could perhaps be joined. It is not however. And we still need @@ -808,8 +816,23 @@ modifyShelleyTxBody -> Ledger.TxBody (Cardano.ShelleyLedgerEra era) -> Ledger.TxBody (Cardano.ShelleyLedgerEra era) modifyShelleyTxBody txUpdate era ledgerBody = case era of + ShelleyBasedEraConway -> ledgerBody + { Conway.outputs = Conway.outputs ledgerBody + <> StrictSeq.fromList + ( Ledger.mkSized + . Cardano.toShelleyTxOut era + . Cardano.toCtxUTxOTxOut + . toCardanoTxOut era <$> extraOutputs + ) + , Conway.inputs = Conway.inputs ledgerBody + <> Set.fromList (Cardano.toShelleyTxIn <$> extraInputs') + , Conway.collateral = Conway.collateral ledgerBody + <> Set.fromList (Cardano.toShelleyTxIn <$> extraCollateral') + , Conway.txfee = + modifyFee $ Conway.txfee ledgerBody + } ShelleyBasedEraBabbage -> ledgerBody - { Babbage.outputs = Babbage.outputs ledgerBody + { Babbage.outputs = Babbage.outputs ledgerBody <> StrictSeq.fromList ( Ledger.mkSized . Cardano.toShelleyTxOut era @@ -824,7 +847,7 @@ modifyShelleyTxBody txUpdate era ledgerBody = case era of modifyFee $ Babbage.txfee ledgerBody } ShelleyBasedEraAlonzo -> ledgerBody - { Alonzo.outputs = Alonzo.outputs ledgerBody + { Alonzo.outputs = Alonzo.outputs ledgerBody <> StrictSeq.fromList ( Cardano.toShelleyTxOut era . Cardano.toCtxUTxOTxOut @@ -1111,18 +1134,21 @@ estimateKeyWitnessCount utxo txbody@(Cardano.TxBody txbodycontent) = :: Ledger.Script (Cardano.ShelleyLedgerEra era) -> Maybe (Script KeyHash) toTimelockScript anyScript = case Cardano.shelleyBasedEra @era of + Cardano.ShelleyBasedEraConway -> + case anyScript of + Alonzo.TimelockScript timelock -> + Just $ toWalletScript (const dummyKeyRole) timelock + Alonzo.PlutusScript _ _ -> Nothing Cardano.ShelleyBasedEraBabbage -> case anyScript of - (Alonzo.TimelockScript timelock) - -> Just $ toWalletScript (const dummyKeyRole) timelock - (Alonzo.PlutusScript _ _) - -> Nothing + Alonzo.TimelockScript timelock -> + Just $ toWalletScript (const dummyKeyRole) timelock + Alonzo.PlutusScript _ _ -> Nothing Cardano.ShelleyBasedEraAlonzo -> case anyScript of - (Alonzo.TimelockScript timelock) - -> Just $ toWalletScript (const dummyKeyRole) timelock - (Alonzo.PlutusScript _ _) - -> Nothing + Alonzo.TimelockScript timelock -> + Just $ toWalletScript (const dummyKeyRole) timelock + Alonzo.PlutusScript _ _ -> Nothing Cardano.ShelleyBasedEraMary -> Just $ toWalletScript (const dummyKeyRole) anyScript Cardano.ShelleyBasedEraAllegra -> @@ -1168,6 +1194,9 @@ type AlonzoTx = type BabbageTx = Ledger.Tx (Cardano.ShelleyLedgerEra Cardano.BabbageEra) +type ConwayTx = + Ledger.Tx (Cardano.ShelleyLedgerEra Cardano.ConwayEra) + assignScriptRedeemers :: forall era. Cardano.IsShelleyBasedEra era => Cardano.ProtocolParameters @@ -1202,6 +1231,15 @@ assignScriptRedeemers pparams ti utxo redeemers tx = modifyM (assignExecutionUnitsBabbage executionUnits) modify' addScriptIntegrityHashBabbage pure $ Cardano.ShelleyTx ShelleyBasedEraBabbage babbageTx' + Cardano.ShelleyBasedEraConway -> do + let Cardano.ShelleyTx _ conwayTx = tx + conwayTx' <- flip execStateT conwayTx $ do + indexedRedeemers <- StateT assignNullRedeemersConway + executionUnits <- get + >>= lift . evaluateExecutionUnitsConway indexedRedeemers + modifyM (assignExecutionUnitsConway executionUnits) + modify' addScriptIntegrityHashConway + pure $ Cardano.ShelleyTx ShelleyBasedEraConway conwayTx' where epochInfo :: EpochInfo (Either T.Text) epochInfo = hoistEpochInfo (left (T.pack . show) . runIdentity . runExceptT) @@ -1227,19 +1265,12 @@ assignScriptRedeemers pparams ti utxo redeemers tx = assignNullRedeemersAlonzo alonzoTx = do (indexedRedeemers, nullRedeemers) <- fmap unzip $ forM redeemers $ \rd -> do ptr <- case Alonzo.rdptr (Alonzo.body alonzoTx) (toScriptPurpose rd) of - SNothing -> - Left $ ErrAssignRedeemersTargetNotFound rd - SJust ptr -> - pure ptr - + 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) - + Left e -> Left $ ErrAssignRedeemersInvalidData rd (show e) + Right d -> pure (Alonzo.Data d) pure ((ptr, rd), (ptr, (rData, mempty))) - pure ( Map.fromList indexedRedeemers , alonzoTx @@ -1256,19 +1287,12 @@ assignScriptRedeemers pparams ti utxo redeemers tx = (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 - + 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) - + Left e -> Left $ ErrAssignRedeemersInvalidData rd (show e) + Right d -> pure (Alonzo.Data d) pure ((ptr, rd), (ptr, (rData, mempty))) - pure ( Map.fromList indexedRedeemers , babbageTx @@ -1279,6 +1303,29 @@ assignScriptRedeemers pparams ti utxo redeemers tx = } ) + assignNullRedeemersConway + :: ConwayTx + -> Either ErrAssignRedeemers (Map Alonzo.RdmrPtr Redeemer, ConwayTx) + assignNullRedeemersConway conwayTx = do + (indexedRedeemers, nullRedeemers) <- fmap unzip $ forM redeemers $ \rd -> do + ptr <- + case Alonzo.rdptr (Alonzo.body conwayTx) (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 + , conwayTx + { Alonzo.wits = (Alonzo.wits conwayTx) + { Alonzo.txrdmrs = + Alonzo.Redeemers (Map.fromList nullRedeemers) + } + } + ) + -- | Evaluate execution units of each script/redeemer in the transaction. -- This may fail for each script. evaluateExecutionUnitsAlonzo @@ -1312,7 +1359,6 @@ assignScriptRedeemers pparams ti utxo redeemers tx = -> Either ErrAssignRedeemers (Map Alonzo.RdmrPtr (Either ErrAssignRedeemers Alonzo.ExUnits)) evaluateExecutionUnitsBabbage indexedRedeemers babbageTx = do - let pparams' = Cardano.toLedgerPParams Cardano.ShelleyBasedEraBabbage pparams let costs = toCostModelsAsArray @@ -1331,6 +1377,31 @@ assignScriptRedeemers pparams ti utxo redeemers tx = Right report -> Right $ hoistScriptFailure indexedRedeemers report + evaluateExecutionUnitsConway + :: era ~ Cardano.ConwayEra + => Map Alonzo.RdmrPtr Redeemer + -> ConwayTx + -> Either ErrAssignRedeemers + (Map Alonzo.RdmrPtr (Either ErrAssignRedeemers Alonzo.ExUnits)) + evaluateExecutionUnitsConway indexedRedeemers conwayTx = do + let pparams' = Cardano.toLedgerPParams + Cardano.ShelleyBasedEraConway pparams + let costs = toCostModelsAsArray + (Alonzo.unCostModels $ Conway._costmdls pparams') + + let res = evaluateTransactionExecutionUnits + pparams' + conwayTx + (fromCardanoUTxO utxo) + epochInfo + systemStart + costs + case res of + Left translationError -> + Left $ ErrAssignRedeemersTranslationError translationError + Right report -> + Right $ hoistScriptFailure indexedRedeemers report + hoistScriptFailure :: Show scriptFailure => Map Alonzo.RdmrPtr Redeemer @@ -1354,11 +1425,8 @@ assignScriptRedeemers pparams ti utxo redeemers tx = (Map.zipWithAMatched (const assignUnits)) rdmrs exUnits - pure $ alonzoTx - { Alonzo.wits = wits - { Alonzo.txrdmrs = Alonzo.Redeemers rdmrs' - } - } + pure alonzoTx + { Alonzo.wits = wits { Alonzo.txrdmrs = Alonzo.Redeemers rdmrs' } } assignExecutionUnitsBabbage :: Map Alonzo.RdmrPtr (Either ErrAssignRedeemers Alonzo.ExUnits) @@ -1373,35 +1441,43 @@ assignScriptRedeemers pparams ti utxo redeemers tx = (Map.zipWithAMatched (const assignUnits)) rdmrs exUnits - pure $ babbageTx - { Alonzo.wits = wits - { Alonzo.txrdmrs = Alonzo.Redeemers rdmrs' - } - } + pure babbageTx + { Alonzo.wits = wits { Alonzo.txrdmrs = Alonzo.Redeemers rdmrs' } } + + assignExecutionUnitsConway + :: Map Alonzo.RdmrPtr (Either ErrAssignRedeemers Alonzo.ExUnits) + -> ConwayTx + -> Either ErrAssignRedeemers ConwayTx + assignExecutionUnitsConway exUnits conwayTx = do + let wits = Alonzo.wits conwayTx + let Alonzo.Redeemers rdmrs = Alonzo.txrdmrs wits + rdmrs' <- Map.mergeA + Map.preserveMissing + Map.dropMissing + (Map.zipWithAMatched (const assignUnits)) + rdmrs + exUnits + pure conwayTx + { 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,) + assignUnits (dats, _zero) = fmap (dats,) -- | Finally, calculate and add the script integrity hash with the new -- final redeemers, if any. - addScriptIntegrityHashAlonzo - :: AlonzoTx - -> AlonzoTx + addScriptIntegrityHashAlonzo :: AlonzoTx -> AlonzoTx addScriptIntegrityHashAlonzo alonzoTx = - let - wits = Alonzo.wits alonzoTx + let wits = Alonzo.wits alonzoTx langs = [ l | (_hash, script) <- Map.toList (Alonzo.txscripts wits) , (not . Ledger.isNativeScript @StandardAlonzo) script , Just l <- [Alonzo.language script] ] - in - alonzoTx + in alonzoTx { Alonzo.body = (Alonzo.body alonzoTx) { Alonzo.scriptIntegrityHash = Alonzo.hashScriptIntegrity (Set.fromList $ Alonzo.getLanguageView @@ -1413,20 +1489,16 @@ assignScriptRedeemers pparams ti utxo redeemers tx = } } - addScriptIntegrityHashBabbage - :: BabbageTx - -> BabbageTx + addScriptIntegrityHashBabbage :: BabbageTx -> BabbageTx addScriptIntegrityHashBabbage babbageTx = - let - wits = Alonzo.wits babbageTx + let wits = Alonzo.wits babbageTx langs = [ l | (_hash, script) <- Map.toList (Alonzo.txscripts wits) , (not . Ledger.isNativeScript @StandardBabbage) script , Just l <- [Alonzo.language script] ] - in - babbageTx + in babbageTx { Babbage.body = (Babbage.body babbageTx) { Babbage.scriptIntegrityHash = Alonzo.hashScriptIntegrity (Set.fromList $ Alonzo.getLanguageView @@ -1438,6 +1510,27 @@ assignScriptRedeemers pparams ti utxo redeemers tx = } } + addScriptIntegrityHashConway :: ConwayTx -> ConwayTx + addScriptIntegrityHashConway conwayTx = + let wits = Alonzo.wits conwayTx + langs = + [ l + | (_hash, script) <- Map.toList (Alonzo.txscripts wits) + , (not . Ledger.isNativeScript @StandardConway) script + , Just l <- [Alonzo.language script] + ] + in conwayTx + { Conway.body = (Conway.body conwayTx) + { Conway.scriptIntegrityHash = Alonzo.hashScriptIntegrity + (Set.fromList $ Alonzo.getLanguageView + (Cardano.toLedgerPParams + Cardano.ShelleyBasedEraConway pparams) + <$> langs) + (Alonzo.txrdmrs wits) + (Alonzo.txdats wits) + } + } + txConstraints :: AnyCardanoEra -> ProtocolParameters -> TxWitnessTag -> TxConstraints txConstraints era protocolParams witnessTag = TxConstraints @@ -2309,6 +2402,7 @@ withShelleyBasedEra era fn = case era of AnyCardanoEra MaryEra -> fn ShelleyBasedEraMary AnyCardanoEra AlonzoEra -> fn ShelleyBasedEraAlonzo AnyCardanoEra BabbageEra -> fn ShelleyBasedEraBabbage + AnyCardanoEra ConwayEra -> fn ShelleyBasedEraConway -- FIXME: Make this a Allegra or Shelley transaction depending on the era we're -- in. However, quoting Duncan: @@ -2467,6 +2561,7 @@ mkUnsignedTx era ttl cs md wdrls certs fees mintData burnData mintingScripts inp ShelleyBasedEraMary -> Cardano.TxMetadataInMaryEra ShelleyBasedEraAlonzo -> Cardano.TxMetadataInAlonzoEra ShelleyBasedEraBabbage -> Cardano.TxMetadataInBabbageEra + ShelleyBasedEraConway -> Cardano.TxMetadataInConwayEra certSupported :: Cardano.CertificatesSupportedInEra era certSupported = case era of @@ -2475,6 +2570,7 @@ mkUnsignedTx era ttl cs md wdrls certs fees mintData burnData mintingScripts inp ShelleyBasedEraMary -> Cardano.CertificatesInMaryEra ShelleyBasedEraAlonzo -> Cardano.CertificatesInAlonzoEra ShelleyBasedEraBabbage -> Cardano.CertificatesInBabbageEra + ShelleyBasedEraConway -> Cardano.CertificatesInConwayEra wdrlsSupported :: Cardano.WithdrawalsSupportedInEra era wdrlsSupported = case era of @@ -2483,6 +2579,7 @@ mkUnsignedTx era ttl cs md wdrls certs fees mintData burnData mintingScripts inp ShelleyBasedEraMary -> Cardano.WithdrawalsInMaryEra ShelleyBasedEraAlonzo -> Cardano.WithdrawalsInAlonzoEra ShelleyBasedEraBabbage -> Cardano.WithdrawalsInBabbageEra + ShelleyBasedEraConway -> Cardano.WithdrawalsInConwayEra txValidityUpperBoundSupported :: Cardano.ValidityUpperBoundSupportedInEra era txValidityUpperBoundSupported = case era of @@ -2491,6 +2588,7 @@ mkUnsignedTx era ttl cs md wdrls certs fees mintData burnData mintingScripts inp ShelleyBasedEraMary -> Cardano.ValidityUpperBoundInMaryEra ShelleyBasedEraAlonzo -> Cardano.ValidityUpperBoundInAlonzoEra ShelleyBasedEraBabbage -> Cardano.ValidityUpperBoundInBabbageEra + ShelleyBasedEraConway -> Cardano.ValidityUpperBoundInConwayEra txValidityLowerBoundSupported :: Maybe (Cardano.ValidityLowerBoundSupportedInEra era) @@ -2500,6 +2598,7 @@ mkUnsignedTx era ttl cs md wdrls certs fees mintData burnData mintingScripts inp ShelleyBasedEraMary -> Just Cardano.ValidityLowerBoundInMaryEra ShelleyBasedEraAlonzo -> Just Cardano.ValidityLowerBoundInAlonzoEra ShelleyBasedEraBabbage -> Just Cardano.ValidityLowerBoundInBabbageEra + ShelleyBasedEraConway -> Just Cardano.ValidityLowerBoundInConwayEra txMintingSupported :: Maybe (Cardano.MultiAssetSupportedInEra era) txMintingSupported = case era of @@ -2508,6 +2607,7 @@ mkUnsignedTx era ttl cs md wdrls certs fees mintData burnData mintingScripts inp ShelleyBasedEraMary -> Just Cardano.MultiAssetInMaryEra ShelleyBasedEraAlonzo -> Just Cardano.MultiAssetInAlonzoEra ShelleyBasedEraBabbage -> Just Cardano.MultiAssetInBabbageEra + ShelleyBasedEraConway -> Just Cardano.MultiAssetInConwayEra scriptWitsSupported :: Cardano.ScriptLanguageInEra Cardano.SimpleScript' era @@ -2519,6 +2619,7 @@ mkUnsignedTx era ttl cs md wdrls certs fees mintData burnData mintingScripts inp ShelleyBasedEraMary -> Cardano.SimpleScriptInMary ShelleyBasedEraAlonzo -> Cardano.SimpleScriptInAlonzo ShelleyBasedEraBabbage -> Cardano.SimpleScriptInBabbage + ShelleyBasedEraConway -> Cardano.SimpleScriptInConway toScriptWitness :: Script KeyHash -> Cardano.ScriptWitness witctx era toScriptWitness script = @@ -2592,6 +2693,20 @@ removeDummyInput = \case scriptData aux val + ShelleyBasedEraConway -> + let body' = body + { Conway.inputs = + Set.delete + (toLedger dummyInput) + (Conway.inputs body) + } + in Cardano.ShelleyTxBody + era + body' + scripts + scriptData + aux + val where bailOut = error "removing dummy inputs is only supported \ \for the Alonzo or Babbage era" @@ -2656,3 +2771,5 @@ explicitFees era = case era of Cardano.TxFeeExplicit Cardano.TxFeesExplicitInAlonzoEra ShelleyBasedEraBabbage -> Cardano.TxFeeExplicit Cardano.TxFeesExplicitInBabbageEra + ShelleyBasedEraConway -> + Cardano.TxFeeExplicit Cardano.TxFeesExplicitInConwayEra diff --git a/lib/wallet/src/Cardano/Wallet/Write/Tx.hs b/lib/wallet/src/Cardano/Wallet/Write/Tx.hs index e1333bc37de..1a6df02b73c 100644 --- a/lib/wallet/src/Cardano/Wallet/Write/Tx.hs +++ b/lib/wallet/src/Cardano/Wallet/Write/Tx.hs @@ -168,6 +168,8 @@ import Cardano.Wallet.Primitive.Types.Tx.Constraints ( txOutMaxCoin ) import Cardano.Wallet.Shelley.Compatibility.Ledger ( toLedger ) +import Control.Monad + ( forM ) import Data.ByteString ( ByteString ) import Data.ByteString.Short @@ -198,6 +200,7 @@ import qualified Cardano.Ledger.Alonzo.Tx 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.Conway.TxBody as Conway import qualified Cardano.Ledger.Core as Core import qualified Cardano.Ledger.Shelley.API.Wallet as Shelley import qualified Cardano.Ledger.Shelley.UTxO as Shelley @@ -205,7 +208,6 @@ import qualified Cardano.Ledger.TxIn as Ledger import qualified Data.Aeson as Aeson import qualified Data.Aeson.Types as Aeson import qualified Data.Map as Map -import Control.Monad (forM) -------------------------------------------------------------------------------- -- Eras @@ -753,7 +755,7 @@ txBody :: RecentEra era -> Core.Tx (ShelleyLedgerEra era) -> Core.TxBody (ShelleyLedgerEra era) -txBody RecentEraConway = Alonzo.body +txBody RecentEraConway = Alonzo.body -- same type for conway txBody RecentEraBabbage = Alonzo.body -- same type for babbage txBody RecentEraAlonzo = Alonzo.body @@ -762,7 +764,7 @@ outputs :: RecentEra era -> Core.TxBody (ShelleyLedgerEra era) -> [TxOut (ShelleyLedgerEra era)] -outputs RecentEraConway = map sizedValue . toList . Babbage.outputs +outputs RecentEraConway = map sizedValue . toList . Conway.outputs outputs RecentEraBabbage = map sizedValue . toList . Babbage.outputs outputs RecentEraAlonzo = toList . Alonzo.outputs