Merge pull request #906 from IntersectMBO/mgalazyn/feature/add-utxorpc-protocol-parameters-query-pp-reverse

carbolymer · web-flow · commit ee5af3f9c1a8 · 2025-07-23T09:07:15.000Z
cardano-rpc | UTxO RPC: add reverse conversion from UTxO RPC protocol params, to ledger ones
diff --git a/cardano-api/src/Cardano/Api/Address.hs b/cardano-api/src/Cardano/Api/Address.hs
@@ -92,8 +92,8 @@ where
 import Cardano.Api.Byron.Internal.Key
 import Cardano.Api.Era
 import Cardano.Api.HasTypeProxy
-import Cardano.Api.Internal.Utils
 import Cardano.Api.Key.Internal
+import Cardano.Api.Monad.Error
 import Cardano.Api.Network.Internal.NetworkId
 import Cardano.Api.Parser.Text qualified as P
 import Cardano.Api.Plutus.Internal.Script
diff --git a/cardano-api/src/Cardano/Api/Experimental/Era.hs b/cardano-api/src/Cardano/Api/Experimental/Era.hs
@@ -21,6 +21,7 @@ module Cardano.Api.Experimental.Era
   , IsEra (..)
   , Some (..)
   , Inject (..)
+  , Convert (..)
   , LedgerEra
   , DeprecatedEra (..)
   , EraCommonConstraints
diff --git a/cardano-api/src/Cardano/Api/Internal/Utils.hs b/cardano-api/src/Cardano/Api/Internal/Utils.hs
@@ -5,24 +5,13 @@
 
 -- | Internal utils for the other Api modules
 module Cardano.Api.Internal.Utils
-  ( (?!)
-  , (?!.)
-  , (<<$>>)
+  ( (<<$>>)
   , (<<<$>>>)
   , noInlineMaybeToStrictMaybe
   )
 where
 
 import Cardano.Ledger.BaseTypes
-import Cardano.Ledger.Shelley ()
-
-(?!) :: Maybe a -> e -> Either e a
-Nothing ?! e = Left e
-Just x ?! _ = Right x
-
-(?!.) :: Either e a -> (e -> e') -> Either e' a
-Left e ?!. f = Left (f e)
-Right x ?!. _ = Right x
 
 infixl 4 <<$>>
 
diff --git a/cardano-api/src/Cardano/Api/Monad/Error.hs b/cardano-api/src/Cardano/Api/Monad/Error.hs
@@ -15,6 +15,8 @@ module Cardano.Api.Monad.Error
   , liftMaybe
   , failEither
   , failEitherWith
+  , (?!)
+  , (?!&)
   , module Control.Monad.Except
   , module Control.Monad.IO.Class
   , module Control.Monad.Trans.Class
@@ -118,6 +120,18 @@ liftMaybe
   -> m a
 liftMaybe e = maybe (throwError e) pure
 
+-- | Infix 'liftMaybe', with arguments flipped
+(?!) :: MonadError e m => Maybe a -> e -> m a
+(?!) = flip liftMaybe
+
+infixl 8 ?!
+
+-- | Map over the 'Left' value of 'Either e a'. Infix 'first' with its arguments flipped.
+(?!&) :: Either e a -> (e -> e') -> Either e' a
+(?!&) = flip first
+
+infixl 8 ?!&
+
 -- | Lift 'Either' to `MonadFail`
 failEither
   :: MonadFail m
diff --git a/cardano-api/src/Cardano/Api/Serialise/Bech32.hs b/cardano-api/src/Cardano/Api/Serialise/Bech32.hs
@@ -18,7 +18,7 @@ where
 import Cardano.Api.Error
 import Cardano.Api.HasTypeProxy
 import Cardano.Api.Internal.Orphans.Misc ()
-import Cardano.Api.Internal.Utils
+import Cardano.Api.Monad.Error
 import Cardano.Api.Pretty
 import Cardano.Api.Serialise.Raw
 
@@ -52,7 +52,7 @@ deserialiseFromBech32
 deserialiseFromBech32 bech32Str = do
   (prefix, dataPart) <-
     Bech32.decodeLenient bech32Str
-      ?!. Bech32DecodingError
+      ?!& Bech32DecodingError
 
   let actualPrefix = Bech32.humanReadablePartToText prefix
       permittedPrefixes = bech32PrefixesPermitted (asType @a)
@@ -83,7 +83,7 @@ deserialiseAnyOfFromBech32
 deserialiseAnyOfFromBech32 types bech32Str = do
   (prefix, dataPart) <-
     Bech32.decodeLenient bech32Str
-      ?!. Bech32DecodingError
+      ?!& Bech32DecodingError
 
   let actualPrefix = Bech32.humanReadablePartToText prefix
 
diff --git a/cardano-api/src/Cardano/Api/Serialise/Cip129.hs b/cardano-api/src/Cardano/Api/Serialise/Cip129.hs
@@ -20,7 +20,7 @@ where
 import Cardano.Api.Governance.Internal.Action.ProposalProcedure
 import Cardano.Api.HasTypeProxy
 import Cardano.Api.Internal.Orphans (AsType (..))
-import Cardano.Api.Internal.Utils
+import Cardano.Api.Monad.Error
 import Cardano.Api.Serialise.Bech32
 import Cardano.Api.Serialise.Raw
 import Cardano.Api.Tx.Internal.TxIn
@@ -98,7 +98,7 @@ deserialiseFromBech32Cip129
 deserialiseFromBech32Cip129 bech32Str = do
   (prefix, dataPart) <-
     Bech32.decodeLenient bech32Str
-      ?!. Bech32DecodingError
+      ?!& Bech32DecodingError
 
   let actualPrefix = Bech32.humanReadablePartToText prefix
       permittedPrefixes = cip129Bech32PrefixesPermitted (asType @a)
@@ -160,7 +160,7 @@ deserialiseGovActionIdFromBech32Cip129 bech32Str = do
   let permittedPrefixes = ["gov_action"]
   (prefix, dataPart) <-
     Bech32.decodeLenient bech32Str
-      ?!. Bech32DecodingError
+      ?!& Bech32DecodingError
   let actualPrefix = Bech32.humanReadablePartToText prefix
   guard (actualPrefix `elem` permittedPrefixes)
     ?! Bech32UnexpectedPrefix actualPrefix (fromList permittedPrefixes)
diff --git a/cardano-api/src/Cardano/Api/Tx/Internal/Body.hs b/cardano-api/src/Cardano/Api/Tx/Internal/Body.hs
@@ -248,9 +248,9 @@ import Cardano.Api.Experimental.Plutus.Internal.Shim.LegacyScripts
 import Cardano.Api.Experimental.Tx.Internal.TxScriptWitnessRequirements
 import Cardano.Api.Governance.Internal.Action.ProposalProcedure
 import Cardano.Api.Governance.Internal.Action.VotingProcedure
-import Cardano.Api.Internal.Utils
 import Cardano.Api.Key.Internal
 import Cardano.Api.Ledger.Internal.Reexport qualified as Ledger
+import Cardano.Api.Monad.Error
 import Cardano.Api.Network.Internal.NetworkId
 import Cardano.Api.Plutus.Internal.Script
 import Cardano.Api.Plutus.Internal.ScriptData
diff --git a/cardano-api/src/Cardano/Api/Tx/Internal/Output.hs b/cardano-api/src/Cardano/Api/Tx/Internal/Output.hs
@@ -63,8 +63,8 @@ import Cardano.Api.Era.Internal.Eon.Convert
 import Cardano.Api.Era.Internal.Eon.ShelleyBasedEra
 import Cardano.Api.Error (Error (..), displayError)
 import Cardano.Api.Hash
-import Cardano.Api.Internal.Utils
 import Cardano.Api.Ledger.Internal.Reexport qualified as Ledger
+import Cardano.Api.Monad.Error
 import Cardano.Api.Parser.Text qualified as P
 import Cardano.Api.Plutus.Internal.Script
 import Cardano.Api.Plutus.Internal.ScriptData
diff --git a/cardano-rpc/cardano-rpc.cabal b/cardano-rpc/cardano-rpc.cabal
@@ -61,6 +61,7 @@ library
     Cardano.Rpc.Server.Internal.Error
     Cardano.Rpc.Server.Internal.Monad
     Cardano.Rpc.Server.Internal.UtxoRpc.Query
+    Cardano.Rpc.Server.Internal.UtxoRpc.Type
     Proto.Cardano.Rpc.Node
     Proto.Cardano.Rpc.Node_Fields
     Proto.Utxorpc.V1alpha.Cardano.Cardano
@@ -91,6 +92,7 @@ library
     cardano-ledger-core,
     containers,
     contra-tracer,
+    data-default,
     filepath,
     generic-data,
     grapesy,
@@ -100,3 +102,30 @@ library
     proto-lens-runtime,
     rio,
     text,
+
+test-suite cardano-rpc-test
+  import: project-config
+  hs-source-dirs: test/cardano-rpc-test
+  main-is: cardano-rpc-test.hs
+  type: exitcode-stdio-1.0
+  build-depends:
+    cardano-api,
+    cardano-api:gen,
+    cardano-ledger-api,
+    cardano-ledger-conway,
+    cardano-ledger-core,
+    cardano-rpc,
+    containers,
+    hedgehog >=1.1,
+    rio,
+    tasty,
+    tasty-hedgehog,
+
+  ghc-options:
+    -threaded
+    -rtsopts
+    "-with-rtsopts=-N -T"
+
+  build-tool-depends: tasty-discover:tasty-discover
+  other-modules:
+    Test.Cardano.Rpc.ProtocolParameters
diff --git a/cardano-rpc/proto/utxorpc/v1alpha/cardano/cardano.proto b/cardano-rpc/proto/utxorpc/v1alpha/cardano/cardano.proto
@@ -44,9 +44,10 @@ message Script {
 }
 
 // Represents a rational number as a fraction.
+// TODO u5c increased precision to 64 bits
 message RationalNumber {
-  int32 numerator = 1;
-  uint32 denominator = 2;
+  int64 numerator = 1;
+  uint64 denominator = 2;
 }
 
 // PARAMS
diff --git a/cardano-rpc/src/Cardano/Rpc/Server/Internal/Orphans.hs b/cardano-rpc/src/Cardano/Rpc/Server/Internal/Orphans.hs
@@ -2,6 +2,8 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
@@ -20,10 +22,18 @@ import Cardano.Api.Tx
 import Cardano.Api.Value
 import Cardano.Rpc.Proto.Api.UtxoRpc.Query qualified as UtxoRpc
 
+import Cardano.Ledger.Api qualified as L
+import Cardano.Ledger.BaseTypes qualified as L
+import Cardano.Ledger.Conway.PParams qualified as L
+import Cardano.Ledger.Plutus qualified as L
+
 import RIO hiding (toList)
 
+import Data.Default
+import Data.Map.Strict qualified as M
 import Data.ProtoLens (defMessage)
-import Data.Ratio (Ratio, denominator, numerator, (%))
+import Data.ProtoLens.Message (Message)
+import Data.Ratio (denominator, numerator, (%))
 import Data.Text.Encoding qualified as T
 import GHC.IsList
 import Network.GRPC.Spec
@@ -34,12 +44,11 @@ import Network.GRPC.Spec
 
 -- It's easier to use 'Proto a' wrappers for RPC types, because it makes lens automatically available.
 
--- TODO: write property tests for bijections
-
-instance Inject (Proto UtxoRpc.RationalNumber) (Ratio Integer) where
+instance Inject (Proto UtxoRpc.RationalNumber) Rational where
   inject r = r ^. #numerator . to fromIntegral % r ^. #denominator . to fromIntegral
 
-instance Inject (Ratio Integer) (Proto UtxoRpc.RationalNumber) where
+-- NB. this clips value in Integer -> Int64/Word64 conversion here
+instance Inject Rational (Proto UtxoRpc.RationalNumber) where
   inject r =
     defMessage
       & #numerator .~ fromIntegral (numerator r)
@@ -121,6 +130,80 @@ instance IsCardanoEra era => Inject (UTxO era) [Proto UtxoRpc.AnyUtxoData] where
         & #txoRef .~ inject txIn
         & #cardano .~ protoTxOut
 
+instance L.ConwayEraPParams lera => Inject (L.PParams lera) (Proto UtxoRpc.PParams) where
+  inject pparams = do
+    let pparamsCostModels :: Map L.Language [Int64] =
+          L.getCostModelParams <$> pparams ^. L.ppCostModelsL . to L.costModelsValid
+        poolVotingThresholds :: L.PoolVotingThresholds =
+          pparams ^. L.ppPoolVotingThresholdsL
+        drepVotingThresholds :: L.DRepVotingThresholds =
+          pparams ^. L.ppDRepVotingThresholdsL
+    def
+      & #coinsPerUtxoByte .~ pparams ^. L.ppCoinsPerUTxOByteL . to L.unCoinPerByte . to fromIntegral
+      & #maxTxSize .~ pparams ^. L.ppMaxTxSizeL . to fromIntegral
+      & #minFeeCoefficient .~ pparams ^. L.ppMinFeeBL . to fromIntegral
+      & #minFeeConstant .~ pparams ^. L.ppMinFeeAL . to fromIntegral
+      & #maxBlockBodySize .~ pparams ^. L.ppMaxBBSizeL . to fromIntegral
+      & #maxBlockHeaderSize .~ pparams ^. L.ppMaxBHSizeL . to fromIntegral
+      & #stakeKeyDeposit .~ pparams ^. L.ppKeyDepositL . to fromIntegral
+      & #poolDeposit .~ pparams ^. L.ppPoolDepositL . to fromIntegral
+      & #poolRetirementEpochBound .~ pparams ^. L.ppEMaxL . to L.unEpochInterval . to fromIntegral
+      & #desiredNumberOfPools .~ pparams ^. L.ppNOptL . to fromIntegral
+      & #poolInfluence .~ pparams ^. L.ppA0L . to L.unboundRational . to inject
+      & #monetaryExpansion .~ pparams ^. L.ppRhoL . to L.unboundRational . to inject
+      & #treasuryExpansion .~ pparams ^. L.ppTauL . to L.unboundRational . to inject
+      & #minPoolCost .~ pparams ^. L.ppMinPoolCostL . to fromIntegral
+      & #protocolVersion . #major .~ pparams ^. L.ppProtocolVersionL . to L.pvMajor . to L.getVersion
+      & #protocolVersion . #minor .~ pparams ^. L.ppProtocolVersionL . to L.pvMinor . to fromIntegral
+      & #maxValueSize .~ pparams ^. L.ppMaxValSizeL . to fromIntegral
+      & #collateralPercentage .~ pparams ^. L.ppCollateralPercentageL . to fromIntegral
+      & #maxCollateralInputs .~ pparams ^. L.ppMaxCollateralInputsL . to fromIntegral
+      & #costModels . #plutusV1 . #values .~ (join . maybeToList) (M.lookup L.PlutusV1 pparamsCostModels)
+      & #costModels . #plutusV2 . #values .~ (join . maybeToList) (M.lookup L.PlutusV2 pparamsCostModels)
+      & #costModels . #plutusV3 . #values .~ (join . maybeToList) (M.lookup L.PlutusV3 pparamsCostModels)
+      & #prices . #steps .~ pparams ^. L.ppPricesL . to L.prSteps . to L.unboundRational . to inject
+      & #prices . #memory .~ pparams ^. L.ppPricesL . to L.prMem . to L.unboundRational . to inject
+      & #maxExecutionUnitsPerTransaction .~ pparams ^. L.ppMaxTxExUnitsL . to inject
+      & #maxExecutionUnitsPerBlock .~ pparams ^. L.ppMaxBlockExUnitsL . to inject
+      & #minFeeScriptRefCostPerByte
+        .~ pparams ^. L.ppMinFeeRefScriptCostPerByteL . to L.unboundRational . to inject
+      & #poolVotingThresholds . #thresholds
+        .~ ( inject . L.unboundRational
+               -- order taken from https://github.com/cardano-foundation/CIPs/blob/acb4b2348c968003dfc370cd3769615bfca1f159/CIP-1694/README.md#requirements
+               <$> [ poolVotingThresholds ^. L.pvtMotionNoConfidenceL
+                   , poolVotingThresholds ^. L.pvtCommitteeNormalL
+                   , poolVotingThresholds ^. L.pvtCommitteeNoConfidenceL
+                   , poolVotingThresholds ^. L.pvtHardForkInitiationL
+                   , poolVotingThresholds ^. L.pvtPPSecurityGroupL
+                   ]
+           )
+      & #drepVotingThresholds . #thresholds
+        .~ ( inject . L.unboundRational
+               -- order taken from https://github.com/cardano-foundation/CIPs/blob/acb4b2348c968003dfc370cd3769615bfca1f159/CIP-1694/README.md#requirements
+               <$> [ drepVotingThresholds ^. L.dvtMotionNoConfidenceL
+                   , drepVotingThresholds ^. L.dvtCommitteeNormalL
+                   , drepVotingThresholds ^. L.dvtCommitteeNoConfidenceL
+                   , drepVotingThresholds ^. L.dvtUpdateToConstitutionL
+                   , drepVotingThresholds ^. L.dvtHardForkInitiationL
+                   , drepVotingThresholds ^. L.dvtPPNetworkGroupL
+                   , drepVotingThresholds ^. L.dvtPPEconomicGroupL
+                   , drepVotingThresholds ^. L.dvtPPTechnicalGroupL
+                   , drepVotingThresholds ^. L.dvtPPGovGroupL
+                   , drepVotingThresholds ^. L.dvtTreasuryWithdrawalL
+                   ]
+           )
+      & #minCommitteeSize .~ pparams ^. L.ppCommitteeMinSizeL . to fromIntegral
+      & #committeeTermLimit
+        .~ pparams ^. L.ppCommitteeMaxTermLengthL . to L.unEpochInterval . to fromIntegral
+      & #governanceActionValidityPeriod
+        .~ pparams ^. L.ppGovActionLifetimeL . to L.unEpochInterval . to fromIntegral
+      & #governanceActionDeposit .~ pparams ^. L.ppGovActionDepositL . to fromIntegral
+      & #drepDeposit .~ pparams ^. L.ppDRepDepositL . to fromIntegral
+      & #drepInactivityPeriod .~ pparams ^. L.ppDRepActivityL . to L.unEpochInterval . to fromIntegral
+
+instance Message a => Default (Proto a) where
+  def = defMessage
+
 -----------
 -- Errors
 -----------
@@ -129,3 +212,6 @@ instance IsCardanoEra era => Inject (UTxO era) [Proto UtxoRpc.AnyUtxoData] where
 
 instance Error StringException where
   prettyError = pshow
+
+instance IsString e => MonadFail (Either e) where
+  fail = Left . fromString
diff --git a/cardano-rpc/src/Cardano/Rpc/Server/Internal/UtxoRpc/Query.hs b/cardano-rpc/src/Cardano/Rpc/Server/Internal/UtxoRpc/Query.hs
diff --git a/cardano-rpc/src/Cardano/Rpc/Server/Internal/UtxoRpc/Type.hs b/cardano-rpc/src/Cardano/Rpc/Server/Internal/UtxoRpc/Type.hs
diff --git a/cardano-rpc/test/cardano-rpc-test/Test/Cardano/Rpc/ProtocolParameters.hs b/cardano-rpc/test/cardano-rpc-test/Test/Cardano/Rpc/ProtocolParameters.hs
diff --git a/cardano-rpc/test/cardano-rpc-test/cardano-rpc-test.hs b/cardano-rpc/test/cardano-rpc-test/cardano-rpc-test.hs

Original file line number	Diff line number	Diff line change
`@@ -44,9 +44,10 @@ message Script {`
`44`	`44`	`}`
`45`	`45`
`46`	`46`	`// Represents a rational number as a fraction.`
	`47`	`+// TODO u5c increased precision to 64 bits`
`47`	`48`	`message RationalNumber {`
`48`		`- int32 numerator = 1;`
`49`		`- uint32 denominator = 2;`
	`49`	`+ int64 numerator = 1;`
	`50`	`+ uint64 denominator = 2;`
`50`	`51`	`}`
`51`	`52`
`52`	`53`	`// PARAMS`