WIP: Make cardano-api compatible with cardano-ledger-api-1.5.0.0

IntersectMBO · Sep 4, 2023 · fd1cda8 · fd1cda8
1 parent 1712879
commit fd1cda8
Show file tree

Hide file tree

Showing 8 changed files with 74 additions and 19 deletions.
diff --git 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
@@ -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
@@ -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
@@ -30,13 +30,16 @@ 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 (..))
 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
@@ -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
@@ -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
@@ -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
@@ -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
 --