From fd1cda822b4529a7a64e5e6dbebc7ca7d080a6da Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Mon, 4 Sep 2023 17:44:40 +0200 Subject: [PATCH] WIP: Make cardano-api compatible with cardano-ledger-api-1.5.0.0 --- cabal.project | 4 +-- cardano-api/internal/Cardano/Api/Address.hs | 29 +++++++++++++++++++ .../Cardano/Api/Convenience/Construction.hs | 5 ++-- .../internal/Cardano/Api/Convenience/Query.hs | 15 ++++++++-- cardano-api/internal/Cardano/Api/Fees.hs | 20 ++++++++++--- cardano-api/internal/Cardano/Api/Query.hs | 11 +++---- .../internal/Cardano/Api/Query/Expr.hs | 6 ++-- cardano-api/internal/Cardano/Api/Script.hs | 3 +- 8 files changed, 74 insertions(+), 19 deletions(-) diff --git a/cabal.project b/cabal.project index 76d12dd97f..2ebe9a6aae 100644 --- a/cabal.project +++ b/cabal.project @@ -45,7 +45,7 @@ write-ghc-environment-files: always source-repository-package type: git location: https://github.com/input-output-hk/cardano-ledger - tag: 642b86e3263a5ffdc43b89b0b4130475c309e1a2 + tag: 9e2f8151e3b9a0dde9faeb29a7dd2456e854427c subdir: libs/ledger-state libs/non-integral @@ -77,7 +77,7 @@ source-repository-package source-repository-package type: git location: https://github.com/input-output-hk/ouroboros-consensus - tag: f353dcbe9ff0d03009df57515156f4ee6d630f86 + tag: 1a1f366e9f9bc1f8107acb60eed2f28f542f3eff subdir: sop-extras strict-sop-core diff --git a/cardano-api/internal/Cardano/Api/Address.hs b/cardano-api/internal/Cardano/Api/Address.hs index 84c013d206..c81bfcb854 100644 --- a/cardano-api/internal/Cardano/Api/Address.hs +++ b/cardano-api/internal/Cardano/Api/Address.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} @@ -66,6 +67,11 @@ module Cardano.Api.Address ( fromShelleyStakeCredential, fromShelleyStakeReference, + -- * DRep addresses + DRepCredential(..), + toShelleyDRepCredential, + fromShelleyDRepCredential, + -- * Serialising addresses SerialiseAddress(..), @@ -95,6 +101,7 @@ import qualified Cardano.Ledger.Alonzo.TxInfo as Alonzo import qualified Cardano.Ledger.BaseTypes as Shelley import qualified Cardano.Ledger.Credential as Shelley import Cardano.Ledger.Crypto (StandardCrypto) +import qualified Cardano.Ledger.Keys as Shelley import qualified PlutusLedgerApi.V1 as Plutus import Control.Applicative ((<|>)) @@ -551,6 +558,11 @@ instance ToJSON StakeCredential where StakeCredentialByScript scriptHash -> ["stakingScriptHash" .= serialiseToRawBytesHexText scriptHash] +data DRepCredential + = DRepCredentialByKey (Hash DRepKey) + | DRepCredentialByScript ScriptHash + deriving (Eq, Ord, Show) + data StakeAddressReference = StakeAddressByValue StakeCredential | StakeAddressByPointer StakeAddressPointer @@ -702,6 +714,23 @@ fromShelleyStakeCredential (Shelley.KeyHashObj kh) = fromShelleyStakeCredential (Shelley.ScriptHashObj sh) = StakeCredentialByScript (fromShelleyScriptHash sh) +fromShelleyDRepCredential + :: Shelley.Credential 'Shelley.DRepRole StandardCrypto + -> DRepCredential +fromShelleyDRepCredential (Shelley.KeyHashObj kh) = + DRepCredentialByKey (DRepKeyHash kh) +fromShelleyDRepCredential (Shelley.ScriptHashObj sh) = + DRepCredentialByScript (fromShelleyScriptHash sh) + +toShelleyDRepCredential + :: DRepCredential + -> Shelley.Credential 'Shelley.DRepRole StandardCrypto +toShelleyDRepCredential (DRepCredentialByKey (DRepKeyHash kh)) = + Shelley.KeyHashObj kh +toShelleyDRepCredential (DRepCredentialByScript sh) = + Shelley.ScriptHashObj (toShelleyScriptHash sh) + + fromShelleyPaymentCredential :: Shelley.PaymentCredential StandardCrypto -> PaymentCredential fromShelleyPaymentCredential (Shelley.KeyHashObj kh) = diff --git a/cardano-api/internal/Cardano/Api/Convenience/Construction.hs b/cardano-api/internal/Cardano/Api/Convenience/Construction.hs index e62294778d..b656ad8eed 100644 --- a/cardano-api/internal/Cardano/Api/Convenience/Construction.hs +++ b/cardano-api/internal/Cardano/Api/Convenience/Construction.hs @@ -46,16 +46,17 @@ constructBalancedTx -> SystemStart -> Set PoolId -- ^ The set of registered stake pools -> Map.Map StakeCredential Lovelace + -> Map.Map DRepCredential Lovelace -> [ShelleyWitnessSigningKey] -> Either TxBodyErrorAutoBalance (Tx era) constructBalancedTx txbodcontent changeAddr mOverrideWits utxo lpp ledgerEpochInfo systemStart stakePools - stakeDelegDeposits shelleyWitSigningKeys = do + stakeDelegDeposits drepDelegDeposits shelleyWitSigningKeys = do BalancedTxBody _ txbody _txBalanceOutput _fee <- makeTransactionBodyAutoBalance systemStart ledgerEpochInfo - lpp stakePools stakeDelegDeposits utxo txbodcontent + lpp stakePools stakeDelegDeposits drepDelegDeposits utxo txbodcontent changeAddr mOverrideWits let keyWits = map (makeShelleyKeyWitness txbody) shelleyWitSigningKeys diff --git a/cardano-api/internal/Cardano/Api/Convenience/Query.hs b/cardano-api/internal/Cardano/Api/Convenience/Query.hs index 96517b1072..1f9f404ba3 100644 --- a/cardano-api/internal/Cardano/Api/Convenience/Query.hs +++ b/cardano-api/internal/Cardano/Api/Convenience/Query.hs @@ -30,6 +30,8 @@ import Cardano.Api.TxBody import Cardano.Api.Utils import Cardano.Api.Value +import Cardano.Ledger.DRepDistr (DRepState (..)) + import Ouroboros.Consensus.HardFork.Combinator.AcrossEras (EraMismatch (..)) import Control.Monad.Trans (MonadTrans (..)) @@ -37,6 +39,7 @@ import Control.Monad.Trans.Except (ExceptT (..), runExceptT) import Control.Monad.Trans.Except.Extra (left, onLeft, onNothing) import Data.Function ((&)) import Data.Map (Map) +import qualified Data.Map as Map import Data.Maybe (mapMaybe) import Data.Set (Set) import qualified Data.Set as Set @@ -81,7 +84,8 @@ queryStateForBalancedTx :: () , EraHistory CardanoMode , SystemStart , Set PoolId - , Map StakeCredential Lovelace)) + , Map StakeCredential Lovelace + , Map DRepCredential Lovelace)) queryStateForBalancedTx era allTxIns certs = runExceptT $ do sbe <- requireShelleyBasedEra era & onNothing (left ByronEraNotSupported) @@ -90,6 +94,7 @@ queryStateForBalancedTx era allTxIns certs = runExceptT $ do & onNothing (left (EraConsensusModeMismatch (AnyConsensusMode CardanoMode) (getIsCardanoEraConstraint era $ AnyCardanoEra era))) let stakeCreds = Set.fromList $ mapMaybe (filterUnRegCreds sbe) certs + drepCreds = undefined :: Set DRepCredential -- TODO: should `drepCreds` come from certs? -- Query execution utxo <- lift (queryUtxo qeInMode sbe (QueryUTxOByTxIn (Set.fromList allTxIns))) @@ -118,7 +123,13 @@ queryStateForBalancedTx era allTxIns certs = runExceptT $ do & onLeft (left . QceUnsupportedNtcVersion) & onLeft (left . QueryEraMismatch) - pure (utxo, LedgerProtocolParameters pparams, eraHistory, systemStart, stakePools, stakeDelegDeposits) + drepDelegDeposits <- + Map.map (fromShelleyLovelace . drepDeposit) <$> + (lift (queryDRepState qeInMode sbe drepCreds) + & onLeft (left . QceUnsupportedNtcVersion) + & onLeft (left . QueryEraMismatch)) + + pure (utxo, LedgerProtocolParameters pparams, eraHistory, systemStart, stakePools, stakeDelegDeposits, drepDelegDeposits) -- | Query the node to determine which era it is in. determineEra diff --git a/cardano-api/internal/Cardano/Api/Fees.hs b/cardano-api/internal/Cardano/Api/Fees.hs index 881c571774..3d8834f5f9 100644 --- a/cardano-api/internal/Cardano/Api/Fees.hs +++ b/cardano-api/internal/Cardano/Api/Fees.hs @@ -645,14 +645,15 @@ evaluateTransactionBalance :: forall era. => Ledger.PParams (ShelleyLedgerEra era) -> Set PoolId -> Map StakeCredential Lovelace + -> Map DRepCredential Lovelace -> UTxO era -> TxBody era -> TxOutValue era -evaluateTransactionBalance _ _ _ _ (ByronTxBody _) = +evaluateTransactionBalance _ _ _ _ _ (ByronTxBody _) = case shelleyBasedEra :: ShelleyBasedEra era of {} --TODO: we could actually support Byron here, it'd be different but simpler -evaluateTransactionBalance pp poolids stakeDelegDeposits utxo +evaluateTransactionBalance pp poolids stakeDelegDeposits drepDelegDeposits utxo (ShelleyTxBody sbe txbody _ _ _ _) = withLedgerConstraints sbe @@ -668,6 +669,12 @@ evaluateTransactionBalance pp poolids stakeDelegDeposits utxo toShelleyLovelace <$> Map.lookup (fromShelleyStakeCredential stakeCred) stakeDelegDeposits + lookupDRepDeposit :: + Ledger.Credential 'Ledger.DRepRole L.StandardCrypto -> Maybe Ledger.Coin + lookupDRepDeposit drepCred = + toShelleyLovelace <$> + Map.lookup (fromShelleyDRepCredential drepCred) drepDelegDeposits + evalMultiAsset :: forall ledgerera. ShelleyLedgerEra era ~ ledgerera => LedgerEraConstraints ledgerera @@ -679,6 +686,7 @@ evaluateTransactionBalance pp poolids stakeDelegDeposits utxo L.evalBalanceTxBody pp lookupDelegDeposit + lookupDRepDeposit isRegPool (toLedgerUTxO sbe utxo) txbody @@ -694,6 +702,7 @@ evaluateTransactionBalance pp poolids stakeDelegDeposits utxo $ L.evalBalanceTxBody pp lookupDelegDeposit + lookupDRepDeposit isRegPool (toLedgerUTxO sbe utxo) txbody @@ -904,13 +913,16 @@ makeTransactionBodyAutoBalance -> Map StakeCredential Lovelace -- ^ Map of all deposits for stake credentials that are being -- unregistered in this transaction + -> Map DRepCredential Lovelace + -- ^ Map of all deposits for drep credentials that are being + -- unregistered in this transaction -> UTxO era -- ^ Just the transaction inputs, not the entire 'UTxO'. -> TxBodyContent BuildTx era -> AddressInEra era -- ^ Change address -> Maybe Word -- ^ Override key witnesses -> Either TxBodyErrorAutoBalance (BalancedTxBody era) makeTransactionBodyAutoBalance systemstart history lpp@(LedgerProtocolParameters pp) poolids stakeDelegDeposits - utxo txbodycontent changeaddr mnkeys = do + drepDelegDeposits utxo txbodycontent changeaddr mnkeys = do -- Our strategy is to: -- 1. evaluate all the scripts to get the exec units, update with ex units -- 2. figure out the overall min fees @@ -1006,7 +1018,7 @@ makeTransactionBodyAutoBalance systemstart history lpp@(LedgerProtocolParameters txReturnCollateral = retColl, txTotalCollateral = reqCol } - let balance = evaluateTransactionBalance pp poolids stakeDelegDeposits utxo txbody2 + let balance = evaluateTransactionBalance pp poolids stakeDelegDeposits drepDelegDeposits utxo txbody2 forM_ (txOuts txbodycontent1) $ \txout -> checkMinUTxOValue txout pp diff --git a/cardano-api/internal/Cardano/Api/Query.hs b/cardano-api/internal/Cardano/Api/Query.hs index 734be653e0..5367623e7e 100644 --- a/cardano-api/internal/Cardano/Api/Query.hs +++ b/cardano-api/internal/Cardano/Api/Query.hs @@ -99,7 +99,6 @@ import qualified Cardano.Ledger.Api as L import Cardano.Ledger.Binary import qualified Cardano.Ledger.Binary.Plain as Plain import qualified Cardano.Ledger.CertState as L -import qualified Cardano.Ledger.Credential as L import qualified Cardano.Ledger.Credential as Shelley import Cardano.Ledger.Crypto (Crypto) import qualified Cardano.Ledger.Shelley.API as Shelley @@ -305,8 +304,8 @@ data QueryInShelleyBasedEra era result where :: QueryInShelleyBasedEra era (L.GovState (ShelleyLedgerEra era)) QueryDRepState - :: Set (L.Credential Shelley.DRepRole StandardCrypto) - -> QueryInShelleyBasedEra era (Map (L.Credential Shelley.DRepRole StandardCrypto) (L.DRepState StandardCrypto)) + :: Set DRepCredential + -> QueryInShelleyBasedEra era (Map DRepCredential (L.DRepState StandardCrypto)) QueryDRepStakeDistr :: Set (Core.DRep StandardCrypto) @@ -679,7 +678,9 @@ toConsensusQueryShelleyBased erainmode QueryGovState = Some (consensusQueryInEraInMode erainmode Consensus.GetGovState) toConsensusQueryShelleyBased erainmode (QueryDRepState creds) = - Some (consensusQueryInEraInMode erainmode (Consensus.GetDRepState creds)) + Some (consensusQueryInEraInMode erainmode (Consensus.GetDRepState creds')) + where + creds' = Set.map toShelleyDRepCredential creds toConsensusQueryShelleyBased erainmode (QueryDRepStakeDistr dreps) = Some (consensusQueryInEraInMode erainmode (Consensus.GetDRepStakeDistr dreps)) @@ -962,7 +963,7 @@ fromConsensusQueryResultShelleyBased _ QueryGovState{} q' govState' = fromConsensusQueryResultShelleyBased _ QueryDRepState{} q' drepState' = case q' of - Consensus.GetDRepState{} -> drepState' + Consensus.GetDRepState{} -> Map.mapKeysMonotonic fromShelleyDRepCredential drepState' _ -> fromConsensusQueryResultMismatch fromConsensusQueryResultShelleyBased _ QueryDRepStakeDistr{} q' stakeDistr' = diff --git a/cardano-api/internal/Cardano/Api/Query/Expr.hs b/cardano-api/internal/Cardano/Api/Query/Expr.hs index 5c7f8e0796..74a27d898b 100644 --- a/cardano-api/internal/Cardano/Api/Query/Expr.hs +++ b/cardano-api/internal/Cardano/Api/Query/Expr.hs @@ -250,10 +250,10 @@ queryGovState eraInMode sbe = queryDRepState :: () => EraInMode era mode -> ShelleyBasedEra era - -> Set (L.Credential L.DRepRole L.StandardCrypto) - -> LocalStateQueryExpr block point (QueryInMode mode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Map (L.Credential L.DRepRole L.StandardCrypto) (L.DRepState L.StandardCrypto)))) + -> Set DRepCredential + -> LocalStateQueryExpr block point (QueryInMode mode) r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Map DRepCredential (L.DRepState L.StandardCrypto)))) queryDRepState eraInMode sbe drepCreds = - queryExpr $ QueryInEra eraInMode $ QueryInShelleyBasedEra sbe $ QueryDRepState drepCreds + queryExpr $ QueryInEra eraInMode $ QueryInShelleyBasedEra sbe $ QueryDRepState drepCreds queryDRepStakeDistribution :: () => EraInMode era mode diff --git a/cardano-api/internal/Cardano/Api/Script.hs b/cardano-api/internal/Cardano/Api/Script.hs index 3bddbea4f8..5fa17a46cd 100644 --- a/cardano-api/internal/Cardano/Api/Script.hs +++ b/cardano-api/internal/Cardano/Api/Script.hs @@ -1,7 +1,9 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralisedNewtypeDeriving #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} @@ -996,7 +998,6 @@ toShelleyScriptHash (ScriptHash h) = h fromShelleyScriptHash :: Shelley.ScriptHash StandardCrypto -> ScriptHash fromShelleyScriptHash = ScriptHash - -- ---------------------------------------------------------------------------- -- The simple script language --