Skip to content

Commit 88632e6

Browse files
carbolymercarbolymer
committed
cardano-rpc | Add test for UTxO RPC protocol params roundtrip conversion
1 parent 5aa852f commit 88632e6

File tree

8 files changed

+471
-107
lines changed

8 files changed

+471
-107
lines changed

‎cardano-api/src/Cardano/Api/Experimental/Era.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -21,6 +21,7 @@ module Cardano.Api.Experimental.Era
2121
, IsEra (..)
2222
, Some (..)
2323
, Inject (..)
24+
, Convert (..)
2425
, LedgerEra
2526
, DeprecatedEra (..)
2627
, EraCommonConstraints

‎cardano-rpc/cardano-rpc.cabal‎

Lines changed: 29 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -61,6 +61,7 @@ library
6161
Cardano.Rpc.Server.Internal.Error
6262
Cardano.Rpc.Server.Internal.Monad
6363
Cardano.Rpc.Server.Internal.UtxoRpc.Query
64+
Cardano.Rpc.Server.Internal.UtxoRpc.Type
6465
Proto.Cardano.Rpc.Node
6566
Proto.Cardano.Rpc.Node_Fields
6667
Proto.Utxorpc.V1alpha.Cardano.Cardano
@@ -91,6 +92,7 @@ library
9192
cardano-ledger-core,
9293
containers,
9394
contra-tracer,
95+
data-default,
9496
filepath,
9597
generic-data,
9698
grapesy,
@@ -100,3 +102,30 @@ library
100102
proto-lens-runtime,
101103
rio,
102104
text,
105+
106+
test-suite cardano-rpc-test
107+
import: project-config
108+
hs-source-dirs: test/cardano-rpc-test
109+
main-is: cardano-rpc-test.hs
110+
type: exitcode-stdio-1.0
111+
build-depends:
112+
cardano-api,
113+
cardano-api:gen,
114+
cardano-ledger-api,
115+
cardano-ledger-conway,
116+
cardano-ledger-core,
117+
cardano-rpc,
118+
containers,
119+
hedgehog >=1.1,
120+
rio,
121+
tasty,
122+
tasty-hedgehog,
123+
124+
ghc-options:
125+
-threaded
126+
-rtsopts
127+
"-with-rtsopts=-N -T"
128+
129+
build-tool-depends: tasty-discover:tasty-discover
130+
other-modules:
131+
Test.Cardano.Rpc.ProtocolParameters

‎cardano-rpc/proto/utxorpc/v1alpha/cardano/cardano.proto‎

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -44,9 +44,10 @@ message Script {
4444
}
4545

4646
// Represents a rational number as a fraction.
47+
// TODO u5c increased precision to 64 bits
4748
message RationalNumber {
48-
int32 numerator = 1;
49-
uint32 denominator = 2;
49+
int64 numerator = 1;
50+
uint64 denominator = 2;
5051
}
5152

5253
// PARAMS

‎cardano-rpc/src/Cardano/Rpc/Server/Internal/Orphans.hs‎

Lines changed: 91 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -2,6 +2,8 @@
22
{-# LANGUAGE GADTs #-}
33
{-# LANGUAGE MultiParamTypeClasses #-}
44
{-# LANGUAGE OverloadedLabels #-}
5+
{-# LANGUAGE OverloadedLists #-}
6+
{-# LANGUAGE RankNTypes #-}
57
{-# LANGUAGE ScopedTypeVariables #-}
68
{-# LANGUAGE TypeApplications #-}
79
{-# OPTIONS_GHC -Wno-orphans #-}
@@ -20,10 +22,18 @@ import Cardano.Api.Tx
2022
import Cardano.Api.Value
2123
import Cardano.Rpc.Proto.Api.UtxoRpc.Query qualified as UtxoRpc
2224

25+
import Cardano.Ledger.Api qualified as L
26+
import Cardano.Ledger.BaseTypes qualified as L
27+
import Cardano.Ledger.Conway.PParams qualified as L
28+
import Cardano.Ledger.Plutus qualified as L
29+
2330
import RIO hiding (toList)
2431

32+
import Data.Default
33+
import Data.Map.Strict qualified as M
2534
import Data.ProtoLens (defMessage)
26-
import Data.Ratio (Ratio, denominator, numerator, (%))
35+
import Data.ProtoLens.Message (Message)
36+
import Data.Ratio (denominator, numerator, (%))
2737
import Data.Text.Encoding qualified as T
2838
import GHC.IsList
2939
import Network.GRPC.Spec
@@ -34,12 +44,11 @@ import Network.GRPC.Spec
3444

3545
-- It's easier to use 'Proto a' wrappers for RPC types, because it makes lens automatically available.
3646

37-
-- TODO: write property tests for bijections
38-
39-
instance Inject (Proto UtxoRpc.RationalNumber) (Ratio Integer) where
47+
instance Inject (Proto UtxoRpc.RationalNumber) Rational where
4048
inject r = r ^. #numerator . to fromIntegral % r ^. #denominator . to fromIntegral
4149

42-
instance Inject (Ratio Integer) (Proto UtxoRpc.RationalNumber) where
50+
-- NB. this clips value in Integer -> Int64/Word64 conversion here
51+
instance Inject Rational (Proto UtxoRpc.RationalNumber) where
4352
inject r =
4453
defMessage
4554
& #numerator .~ fromIntegral (numerator r)
@@ -121,6 +130,80 @@ instance IsCardanoEra era => Inject (UTxO era) [Proto UtxoRpc.AnyUtxoData] where
121130
& #txoRef .~ inject txIn
122131
& #cardano .~ protoTxOut
123132

133+
instance L.ConwayEraPParams lera => Inject (L.PParams lera) (Proto UtxoRpc.PParams) where
134+
inject pparams = do
135+
let pparamsCostModels :: Map L.Language [Int64] =
136+
L.getCostModelParams <$> pparams ^. L.ppCostModelsL . to L.costModelsValid
137+
poolVotingThresholds :: L.PoolVotingThresholds =
138+
pparams ^. L.ppPoolVotingThresholdsL
139+
drepVotingThresholds :: L.DRepVotingThresholds =
140+
pparams ^. L.ppDRepVotingThresholdsL
141+
def
142+
& #coinsPerUtxoByte .~ pparams ^. L.ppCoinsPerUTxOByteL . to L.unCoinPerByte . to fromIntegral
143+
& #maxTxSize .~ pparams ^. L.ppMaxTxSizeL . to fromIntegral
144+
& #minFeeCoefficient .~ pparams ^. L.ppMinFeeBL . to fromIntegral
145+
& #minFeeConstant .~ pparams ^. L.ppMinFeeAL . to fromIntegral
146+
& #maxBlockBodySize .~ pparams ^. L.ppMaxBBSizeL . to fromIntegral
147+
& #maxBlockHeaderSize .~ pparams ^. L.ppMaxBHSizeL . to fromIntegral
148+
& #stakeKeyDeposit .~ pparams ^. L.ppKeyDepositL . to fromIntegral
149+
& #poolDeposit .~ pparams ^. L.ppPoolDepositL . to fromIntegral
150+
& #poolRetirementEpochBound .~ pparams ^. L.ppEMaxL . to L.unEpochInterval . to fromIntegral
151+
& #desiredNumberOfPools .~ pparams ^. L.ppNOptL . to fromIntegral
152+
& #poolInfluence .~ pparams ^. L.ppA0L . to L.unboundRational . to inject
153+
& #monetaryExpansion .~ pparams ^. L.ppRhoL . to L.unboundRational . to inject
154+
& #treasuryExpansion .~ pparams ^. L.ppTauL . to L.unboundRational . to inject
155+
& #minPoolCost .~ pparams ^. L.ppMinPoolCostL . to fromIntegral
156+
& #protocolVersion . #major .~ pparams ^. L.ppProtocolVersionL . to L.pvMajor . to L.getVersion
157+
& #protocolVersion . #minor .~ pparams ^. L.ppProtocolVersionL . to L.pvMinor . to fromIntegral
158+
& #maxValueSize .~ pparams ^. L.ppMaxValSizeL . to fromIntegral
159+
& #collateralPercentage .~ pparams ^. L.ppCollateralPercentageL . to fromIntegral
160+
& #maxCollateralInputs .~ pparams ^. L.ppMaxCollateralInputsL . to fromIntegral
161+
& #costModels . #plutusV1 . #values .~ (join . maybeToList) (M.lookup L.PlutusV1 pparamsCostModels)
162+
& #costModels . #plutusV2 . #values .~ (join . maybeToList) (M.lookup L.PlutusV2 pparamsCostModels)
163+
& #costModels . #plutusV3 . #values .~ (join . maybeToList) (M.lookup L.PlutusV3 pparamsCostModels)
164+
& #prices . #steps .~ pparams ^. L.ppPricesL . to L.prSteps . to L.unboundRational . to inject
165+
& #prices . #memory .~ pparams ^. L.ppPricesL . to L.prMem . to L.unboundRational . to inject
166+
& #maxExecutionUnitsPerTransaction .~ pparams ^. L.ppMaxTxExUnitsL . to inject
167+
& #maxExecutionUnitsPerBlock .~ pparams ^. L.ppMaxBlockExUnitsL . to inject
168+
& #minFeeScriptRefCostPerByte
169+
.~ pparams ^. L.ppMinFeeRefScriptCostPerByteL . to L.unboundRational . to inject
170+
& #poolVotingThresholds . #thresholds
171+
.~ ( inject . L.unboundRational
172+
-- order taken from https://github.com/cardano-foundation/CIPs/blob/acb4b2348c968003dfc370cd3769615bfca1f159/CIP-1694/README.md#requirements
173+
<$> [ poolVotingThresholds ^. L.pvtMotionNoConfidenceL
174+
, poolVotingThresholds ^. L.pvtCommitteeNormalL
175+
, poolVotingThresholds ^. L.pvtCommitteeNoConfidenceL
176+
, poolVotingThresholds ^. L.pvtHardForkInitiationL
177+
, poolVotingThresholds ^. L.pvtPPSecurityGroupL
178+
]
179+
)
180+
& #drepVotingThresholds . #thresholds
181+
.~ ( inject . L.unboundRational
182+
-- order taken from https://github.com/cardano-foundation/CIPs/blob/acb4b2348c968003dfc370cd3769615bfca1f159/CIP-1694/README.md#requirements
183+
<$> [ drepVotingThresholds ^. L.dvtMotionNoConfidenceL
184+
, drepVotingThresholds ^. L.dvtCommitteeNormalL
185+
, drepVotingThresholds ^. L.dvtCommitteeNoConfidenceL
186+
, drepVotingThresholds ^. L.dvtUpdateToConstitutionL
187+
, drepVotingThresholds ^. L.dvtHardForkInitiationL
188+
, drepVotingThresholds ^. L.dvtPPNetworkGroupL
189+
, drepVotingThresholds ^. L.dvtPPEconomicGroupL
190+
, drepVotingThresholds ^. L.dvtPPTechnicalGroupL
191+
, drepVotingThresholds ^. L.dvtPPGovGroupL
192+
, drepVotingThresholds ^. L.dvtTreasuryWithdrawalL
193+
]
194+
)
195+
& #minCommitteeSize .~ pparams ^. L.ppCommitteeMinSizeL . to fromIntegral
196+
& #committeeTermLimit
197+
.~ pparams ^. L.ppCommitteeMaxTermLengthL . to L.unEpochInterval . to fromIntegral
198+
& #governanceActionValidityPeriod
199+
.~ pparams ^. L.ppGovActionLifetimeL . to L.unEpochInterval . to fromIntegral
200+
& #governanceActionDeposit .~ pparams ^. L.ppGovActionDepositL . to fromIntegral
201+
& #drepDeposit .~ pparams ^. L.ppDRepDepositL . to fromIntegral
202+
& #drepInactivityPeriod .~ pparams ^. L.ppDRepActivityL . to L.unEpochInterval . to fromIntegral
203+
204+
instance Message a => Default (Proto a) where
205+
def = defMessage
206+
124207
-----------
125208
-- Errors
126209
-----------
@@ -129,3 +212,6 @@ instance IsCardanoEra era => Inject (UTxO era) [Proto UtxoRpc.AnyUtxoData] where
129212

130213
instance Error StringException where
131214
prettyError = pshow
215+
216+
instance IsString e => MonadFail (Either e) where
217+
fail = Left . fromString

‎cardano-rpc/src/Cardano/Rpc/Server/Internal/UtxoRpc/Query.hs‎

Lines changed: 2 additions & 100 deletions
Original file line numberDiff line numberDiff line change
@@ -16,24 +16,15 @@ module Cardano.Rpc.Server.Internal.UtxoRpc.Query
1616
where
1717

1818
import Cardano.Api
19-
import Cardano.Api.Ledger qualified as L
2019
import Cardano.Api.Parser.Text qualified as P
2120
import Cardano.Rpc.Proto.Api.UtxoRpc.Query qualified as UtxoRpc
2221
import Cardano.Rpc.Server.Internal.Error
2322
import Cardano.Rpc.Server.Internal.Monad
2423
import Cardano.Rpc.Server.Internal.Orphans ()
25-
26-
import Cardano.Ledger.Api qualified as L
27-
import Cardano.Ledger.BaseTypes (WithOrigin (..))
28-
import Cardano.Ledger.Binary.Version qualified as L
29-
import Cardano.Ledger.Conway.Core qualified as L
30-
import Cardano.Ledger.Conway.PParams qualified as L
31-
import Cardano.Ledger.Plutus qualified as L
24+
import Cardano.Rpc.Server.Internal.UtxoRpc.Type
3225

3326
import RIO hiding (toList)
3427

35-
import Data.ByteString.Short qualified as SBS
36-
import Data.Map.Strict qualified as M
3728
import Data.ProtoLens (defMessage)
3829
import Data.Text.Encoding qualified as T
3930
import GHC.IsList
@@ -59,99 +50,10 @@ readParamsMethod _req = do
5950
blockNo <- throwEither =<< queryChainBlockNo
6051
pure (pparams, chainPoint, blockNo)
6152

62-
let pparamsCostModels :: Map L.Language [Int64] =
63-
babbageEraOnwardsConstraints (convert eon) $
64-
L.getCostModelParams <$> pparams ^. L.ppCostModelsL . to L.costModelsValid
65-
poolVotingThresholds :: L.PoolVotingThresholds =
66-
conwayEraOnwardsConstraints eon $
67-
pparams ^. L.ppPoolVotingThresholdsL
68-
drepVotingThresholds :: L.DRepVotingThresholds =
69-
conwayEraOnwardsConstraints eon $
70-
pparams ^. L.ppDRepVotingThresholdsL
71-
pparamsMsg =
72-
conwayEraOnwardsConstraints eon $
73-
defMessage
74-
& #coinsPerUtxoByte .~ pparams ^. L.ppCoinsPerUTxOByteL . to L.unCoinPerByte . to fromIntegral
75-
& #maxTxSize .~ pparams ^. L.ppMaxTxSizeL . to fromIntegral
76-
& #minFeeCoefficient .~ pparams ^. L.ppMinFeeBL . to fromIntegral
77-
& #minFeeConstant .~ pparams ^. L.ppMinFeeAL . to fromIntegral
78-
& #maxBlockBodySize .~ pparams ^. L.ppMaxBBSizeL . to fromIntegral
79-
& #maxBlockHeaderSize .~ pparams ^. L.ppMaxBHSizeL . to fromIntegral
80-
& #stakeKeyDeposit .~ pparams ^. L.ppKeyDepositL . to fromIntegral
81-
& #poolDeposit .~ pparams ^. L.ppPoolDepositL . to fromIntegral
82-
& #poolRetirementEpochBound .~ pparams ^. L.ppEMaxL . to L.unEpochInterval . to fromIntegral
83-
& #desiredNumberOfPools .~ pparams ^. L.ppNOptL . to fromIntegral
84-
& #poolInfluence .~ pparams ^. L.ppA0L . to L.unboundRational . to inject
85-
& #desiredNumberOfPools .~ pparams ^. L.ppNOptL . to fromIntegral
86-
& #monetaryExpansion .~ pparams ^. L.ppRhoL . to L.unboundRational . to inject
87-
& #minPoolCost .~ pparams ^. L.ppMinPoolCostL . to fromIntegral
88-
& #protocolVersion . #major .~ pparams ^. L.ppProtocolVersionL . to L.pvMajor . to L.getVersion
89-
& #protocolVersion . #minor .~ pparams ^. L.ppProtocolVersionL . to L.pvMinor . to fromIntegral
90-
& #maxValueSize .~ pparams ^. L.ppMaxValSizeL . to fromIntegral
91-
& #collateralPercentage .~ pparams ^. L.ppCollateralPercentageL . to fromIntegral
92-
& #maxCollateralInputs .~ pparams ^. L.ppMaxCollateralInputsL . to fromIntegral
93-
& #costModels . #plutusV1 . #values .~ (join . maybeToList) (M.lookup L.PlutusV1 pparamsCostModels)
94-
& #costModels . #plutusV2 . #values .~ (join . maybeToList) (M.lookup L.PlutusV2 pparamsCostModels)
95-
& #costModels . #plutusV3 . #values .~ (join . maybeToList) (M.lookup L.PlutusV3 pparamsCostModels)
96-
& #prices . #steps .~ pparams ^. L.ppPricesL . to L.prSteps . to L.unboundRational . to inject
97-
& #prices . #memory .~ pparams ^. L.ppPricesL . to L.prMem . to L.unboundRational . to inject
98-
& #maxExecutionUnitsPerTransaction .~ pparams ^. L.ppMaxTxExUnitsL . to inject
99-
& #maxExecutionUnitsPerBlock .~ pparams ^. L.ppMaxBlockExUnitsL . to inject
100-
& #minFeeScriptRefCostPerByte
101-
.~ pparams ^. L.ppMinFeeRefScriptCostPerByteL . to L.unboundRational . to inject
102-
& #poolVotingThresholds . #thresholds
103-
.~ ( inject . L.unboundRational
104-
-- order taken from https://github.com/cardano-foundation/CIPs/blob/acb4b2348c968003dfc370cd3769615bfca1f159/CIP-1694/README.md#requirements
105-
<$> [ poolVotingThresholds ^. L.pvtMotionNoConfidenceL
106-
, poolVotingThresholds ^. L.pvtCommitteeNormalL
107-
, poolVotingThresholds ^. L.pvtCommitteeNoConfidenceL
108-
, poolVotingThresholds ^. L.pvtHardForkInitiationL
109-
, poolVotingThresholds ^. L.pvtPPSecurityGroupL
110-
]
111-
)
112-
& #drepVotingThresholds . #thresholds
113-
.~ ( inject . L.unboundRational
114-
-- order taken from https://github.com/cardano-foundation/CIPs/blob/acb4b2348c968003dfc370cd3769615bfca1f159/CIP-1694/README.md#requirements
115-
<$> [ drepVotingThresholds ^. L.dvtMotionNoConfidenceL
116-
, drepVotingThresholds ^. L.dvtCommitteeNormalL
117-
, drepVotingThresholds ^. L.dvtCommitteeNoConfidenceL
118-
, drepVotingThresholds ^. L.dvtUpdateToConstitutionL
119-
, drepVotingThresholds ^. L.dvtHardForkInitiationL
120-
, drepVotingThresholds ^. L.dvtPPNetworkGroupL
121-
, drepVotingThresholds ^. L.dvtPPEconomicGroupL
122-
, drepVotingThresholds ^. L.dvtPPTechnicalGroupL
123-
, drepVotingThresholds ^. L.dvtPPGovGroupL
124-
, drepVotingThresholds ^. L.dvtTreasuryWithdrawalL
125-
]
126-
)
127-
& #minCommitteeSize .~ pparams ^. L.ppCommitteeMinSizeL . to fromIntegral
128-
& #committeeTermLimit
129-
.~ pparams ^. L.ppCommitteeMaxTermLengthL . to L.unEpochInterval . to fromIntegral
130-
& #governanceActionValidityPeriod
131-
.~ pparams ^. L.ppGovActionLifetimeL . to L.unEpochInterval . to fromIntegral
132-
& #governanceActionDeposit .~ pparams ^. L.ppGovActionDepositL . to fromIntegral
133-
& #drepDeposit .~ pparams ^. L.ppDRepDepositL . to fromIntegral
134-
& #drepInactivityPeriod .~ pparams ^. L.ppDRepActivityL . to L.unEpochInterval . to fromIntegral
13553
pure $
13654
defMessage
13755
& #ledgerTip .~ mkChainPointMsg chainPoint blockNo
138-
& #values . #cardano .~ pparamsMsg
139-
140-
mkChainPointMsg
141-
:: ChainPoint
142-
-> WithOrigin BlockNo
143-
-> Proto UtxoRpc.ChainPoint
144-
mkChainPointMsg chainPoint blockNo = do
145-
let (slotNo, blockHash) = case chainPoint of
146-
ChainPointAtGenesis -> (0, mempty)
147-
ChainPoint (SlotNo slot) (HeaderHash hash) -> (slot, SBS.fromShort hash)
148-
blockHeight = case blockNo of
149-
Origin -> 0
150-
At (BlockNo h) -> h
151-
defMessage
152-
& #slot .~ slotNo
153-
& #hash .~ blockHash
154-
& #height .~ blockHeight
56+
& #values . #cardano .~ conwayEraOnwardsConstraints eon (inject pparams)
15557

15658
readUtxosMethod
15759
:: MonadRpc e m

0 commit comments

Comments
 (0)