Skip to content

Commit ab400b4

Browse files
carbolymercarbolymer
committed
cardano-rpc | Add TxOutput roundtrip test
1 parent 62dc4a9 commit ab400b4

File tree

9 files changed

+350
-213
lines changed

9 files changed

+350
-213
lines changed

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

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -309,9 +309,9 @@ type EraCommonConstraints era =
309309
, L.EraTxCert (LedgerEra era)
310310
, L.EraTxOut (LedgerEra era)
311311
, L.EraUTxO (LedgerEra era)
312+
, L.Value (LedgerEra era) ~ L.MaryValue
312313
, FromCBOR (ChainDepState (ConsensusProtocol era))
313-
, -- , FromCBOR (L.TxCert (LedgerEra era))
314-
L.NativeScript (LedgerEra era) ~ L.Timelock (LedgerEra era)
314+
, L.NativeScript (LedgerEra era) ~ L.Timelock (LedgerEra era)
315315
, PraosProtocolSupportsNode (ConsensusProtocol era)
316316
, ShelleyLedgerEra era ~ LedgerEra era
317317
, ToJSON (ChainDepState (ConsensusProtocol era))

‎cardano-api/src/Cardano/Api/Ledger/Internal/Reexport.hs‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -59,6 +59,7 @@ module Cardano.Api.Ledger.Internal.Reexport
5959
, TxId (..)
6060
, TxIn (..)
6161
, Value
62+
, MaryValue (..)
6263
, MultiAsset (..)
6364
, addDeltaCoin
6465
, castSafeHash
@@ -343,7 +344,7 @@ import Cardano.Ledger.Keys
343344
, hashWithSerialiser
344345
, toVRFVerKeyHash
345346
)
346-
import Cardano.Ledger.Mary.Value (MultiAsset (..))
347+
import Cardano.Ledger.Mary.Value (MaryValue (..), MultiAsset (..))
347348
import Cardano.Ledger.Plutus.Data (Data (..), unData)
348349
import Cardano.Ledger.Plutus.Language (Language, Plutus, languageToText, plutusBinary)
349350
import Cardano.Ledger.Shelley.API

‎cardano-api/src/Cardano/Api/Serialise/Raw.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -63,6 +63,7 @@ instance SerialiseAsRawBytes Word16 where
6363
throwError . SerialiseAsRawBytesError $
6464
"Cannot decode Word16 from (hex): " <> BSC.unpack (Base16.encode bs)
6565

66+
-- | Convert the number into binary value
6667
instance SerialiseAsRawBytes Natural where
6768
serialiseToRawBytes 0 = BS.singleton 0x00
6869
serialiseToRawBytes n = BS.toStrict . BSB.toLazyByteString $ go n mempty

‎cardano-api/src/Cardano/Api/Tx/Internal/Fee.hs‎

Lines changed: 0 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -84,7 +84,6 @@ import Cardano.Ledger.Api qualified as L
8484
import Cardano.Ledger.Coin qualified as L
8585
import Cardano.Ledger.Conway.Governance qualified as L
8686
import Cardano.Ledger.Credential as Ledger (Credential)
87-
import Cardano.Ledger.Mary.Value qualified as L
8887
import Cardano.Ledger.Plutus.Language qualified as Plutus
8988
import Cardano.Ledger.Val qualified as L
9089
import Ouroboros.Consensus.HardFork.History qualified as Consensus

‎cardano-rpc/cardano-rpc.cabal‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -69,7 +69,6 @@ library
6969
bytestring,
7070
cardano-api >=10.17,
7171
cardano-ledger-api,
72-
cardano-ledger-binary,
7372
cardano-ledger-conway,
7473
cardano-ledger-core,
7574
cardano-rpc:gen,
@@ -132,3 +131,4 @@ test-suite cardano-rpc-test
132131
build-tool-depends: tasty-discover:tasty-discover
133132
other-modules:
134133
Test.Cardano.Rpc.ProtocolParameters
134+
Test.Cardano.Rpc.TxOutput

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

Lines changed: 1 addition & 199 deletions
Original file line numberDiff line numberDiff line change
@@ -1,45 +1,27 @@
11
{-# LANGUAGE FlexibleInstances #-}
22
{-# LANGUAGE GADTs #-}
3-
{-# LANGUAGE LambdaCase #-}
43
{-# LANGUAGE MultiParamTypeClasses #-}
54
{-# LANGUAGE OverloadedLabels #-}
6-
{-# LANGUAGE OverloadedLists #-}
75
{-# LANGUAGE RankNTypes #-}
86
{-# LANGUAGE ScopedTypeVariables #-}
9-
{-# LANGUAGE TypeApplications #-}
107
{-# OPTIONS_GHC -Wno-orphans #-}
118

129
module Cardano.Rpc.Server.Internal.Orphans where
1310

14-
import Cardano.Api (SerialiseAsCBOR (serialiseToCBOR), ToCBOR (..))
15-
import Cardano.Api.Address
16-
import Cardano.Api.Block (SlotNo (..))
1711
import Cardano.Api.Era
1812
import Cardano.Api.Error
1913
import Cardano.Api.Ledger qualified as L
20-
import Cardano.Api.Plutus
2114
import Cardano.Api.Pretty
2215
import Cardano.Api.Serialise.Raw
23-
import Cardano.Api.Serialise.SerialiseUsing
2416
import Cardano.Api.Tx
25-
import Cardano.Api.Value
2617
import Cardano.Rpc.Proto.Api.UtxoRpc.Query qualified as UtxoRpc
2718

28-
import Cardano.Ledger.Api qualified as L
29-
import Cardano.Ledger.BaseTypes qualified as L
30-
import Cardano.Ledger.Conway.PParams qualified as L
31-
import Cardano.Ledger.Plutus qualified as L
32-
3319
import RIO hiding (toList)
3420

35-
import Data.ByteString qualified as B
3621
import Data.Default
37-
import Data.Map.Strict qualified as M
3822
import Data.ProtoLens (defMessage)
3923
import Data.ProtoLens.Message (Message)
4024
import Data.Ratio (denominator, numerator, (%))
41-
import Data.Text.Encoding qualified as T
42-
import GHC.IsList
4325
import Network.GRPC.Spec
4426

4527
---------------
@@ -78,186 +60,6 @@ instance Inject TxIn (Proto UtxoRpc.TxoRef) where
7860
& #hash .~ serialiseToRawBytes txId'
7961
& #index .~ fromIntegral txIx
8062

81-
instance Inject (ReferenceScript era) (Proto UtxoRpc.Script) where
82-
inject ReferenceScriptNone = defMessage
83-
inject (ReferenceScript _ (ScriptInAnyLang _ script)) =
84-
case script of
85-
SimpleScript ss ->
86-
defMessage & #native .~ inject ss
87-
PlutusScript PlutusScriptV1 ps ->
88-
defMessage & #plutusV1 .~ serialiseToRawBytes ps
89-
PlutusScript PlutusScriptV2 ps ->
90-
defMessage & #plutusV2 .~ serialiseToRawBytes ps
91-
PlutusScript PlutusScriptV3 ps ->
92-
defMessage & #plutusV3 .~ serialiseToRawBytes ps
93-
PlutusScript PlutusScriptV4 ps ->
94-
defMessage & #plutusV4 .~ serialiseToRawBytes ps
95-
96-
instance Inject SimpleScript (Proto UtxoRpc.NativeScript) where
97-
inject = \case
98-
RequireSignature paymentKeyHash ->
99-
defMessage & #scriptPubkey .~ serialiseToRawBytes paymentKeyHash
100-
RequireTimeBefore (SlotNo slotNo) ->
101-
defMessage & #invalidHereafter .~ slotNo
102-
RequireTimeAfter (SlotNo slotNo) ->
103-
defMessage & #invalidBefore .~ slotNo
104-
RequireAllOf scripts ->
105-
defMessage & #scriptAll . #items .~ map inject scripts
106-
RequireAnyOf scripts ->
107-
defMessage & #scriptAny . #items .~ map inject scripts
108-
RequireMOf k scripts -> do
109-
let nScriptsOf =
110-
defMessage
111-
& #k .~ fromIntegral k
112-
& #scripts .~ map inject scripts
113-
defMessage & #scriptNOfK .~ nScriptsOf
114-
115-
instance Inject ScriptData (Proto UtxoRpc.PlutusData) where
116-
inject = \case
117-
ScriptDataBytes bs ->
118-
defMessage & #boundedBytes .~ bs
119-
ScriptDataNumber int
120-
| int <= fromIntegral (maxBound @Int64)
121-
&& int >= fromIntegral (minBound @Int64) ->
122-
defMessage & #bigInt . #int .~ fromIntegral int
123-
| int < 0 ->
124-
-- https://www.rfc-editor.org/rfc/rfc8949.html#name-bignums see 3.4.3 for negative integers
125-
defMessage & #bigInt . #bigNInt .~ serialiseToRawBytes (fromIntegral @_ @Natural (-1 - int))
126-
| otherwise ->
127-
defMessage & #bigInt . #bigUInt .~ serialiseToRawBytes (fromIntegral @_ @Natural int)
128-
ScriptDataList sds ->
129-
defMessage & #array . #items .~ map inject sds
130-
ScriptDataMap elements -> do
131-
let pairs =
132-
elements <&> \(k, v) ->
133-
defMessage
134-
& #key .~ inject k
135-
& #value .~ inject v
136-
defMessage & #map . #pairs .~ pairs
137-
ScriptDataConstructor tag args -> do
138-
let constr =
139-
defMessage
140-
& #tag .~ fromIntegral tag
141-
& #fields .~ map inject args
142-
defMessage & #constr .~ constr
143-
144-
instance IsCardanoEra era => Inject (UTxO era) [Proto UtxoRpc.AnyUtxoData] where
145-
inject utxo =
146-
toList utxo <&> \(txIn, TxOut addressInEra txOutValue datum script) -> do
147-
let multiAsset =
148-
fromList $
149-
toList (valueToPolicyAssets $ txOutValueToValue txOutValue) <&> \(pId, policyAssets) -> do
150-
let assets =
151-
toList policyAssets <&> \(assetName, Quantity qty) -> do
152-
defMessage
153-
& #name .~ serialiseToRawBytes assetName
154-
-- we don't have access to info if the coin was minted in the transaction,
155-
-- maybe we should add it later
156-
& #maybe'mintCoin .~ Nothing
157-
& #outputCoin .~ fromIntegral qty
158-
defMessage
159-
& #policyId .~ serialiseToRawBytes pId
160-
& #assets .~ assets
161-
datumRpc = case datum of
162-
TxOutDatumNone ->
163-
defMessage
164-
TxOutDatumHash _ scriptDataHash ->
165-
defMessage
166-
& #hash .~ serialiseToRawBytes scriptDataHash
167-
& #maybe'payload .~ Nothing -- we don't have it
168-
& #originalCbor .~ mempty -- we don't have it
169-
TxOutDatumInline _ hashableScriptData ->
170-
defMessage
171-
& #hash .~ serialiseToRawBytes (hashScriptDataBytes hashableScriptData)
172-
& #payload .~ inject (getScriptData hashableScriptData)
173-
& #originalCbor .~ getOriginalScriptDataBytes hashableScriptData
174-
175-
protoTxOut =
176-
defMessage
177-
-- TODO we don't have serialiseToRawBytes for AddressInEra, so perhaps this is wrong, because 'address'
178-
-- has type bytes, but we're putting text there
179-
& #address .~ T.encodeUtf8 (cardanoEraConstraints (cardanoEra @era) $ serialiseAddress addressInEra)
180-
& #coin .~ fromIntegral (L.unCoin (txOutValueToLovelace txOutValue))
181-
& #assets .~ multiAsset
182-
& #datum .~ datumRpc
183-
& #script .~ inject script
184-
defMessage
185-
& #nativeBytes .~ "" -- TODO where to get that from? run cbor serialisation of utxos list?
186-
& #txoRef .~ inject txIn
187-
& #cardano .~ protoTxOut
188-
189-
instance L.ConwayEraPParams lera => Inject (L.PParams lera) (Proto UtxoRpc.PParams) where
190-
inject pparams = do
191-
let pparamsCostModels :: Map L.Language [Int64] =
192-
L.getCostModelParams <$> pparams ^. L.ppCostModelsL . to L.costModelsValid
193-
poolVotingThresholds :: L.PoolVotingThresholds =
194-
pparams ^. L.ppPoolVotingThresholdsL
195-
drepVotingThresholds :: L.DRepVotingThresholds =
196-
pparams ^. L.ppDRepVotingThresholdsL
197-
def
198-
& #coinsPerUtxoByte .~ pparams ^. L.ppCoinsPerUTxOByteL . to L.unCoinPerByte . to fromIntegral
199-
& #maxTxSize .~ pparams ^. L.ppMaxTxSizeL . to fromIntegral
200-
& #minFeeCoefficient .~ pparams ^. L.ppMinFeeBL . to fromIntegral
201-
& #minFeeConstant .~ pparams ^. L.ppMinFeeAL . to fromIntegral
202-
& #maxBlockBodySize .~ pparams ^. L.ppMaxBBSizeL . to fromIntegral
203-
& #maxBlockHeaderSize .~ pparams ^. L.ppMaxBHSizeL . to fromIntegral
204-
& #stakeKeyDeposit .~ pparams ^. L.ppKeyDepositL . to fromIntegral
205-
& #poolDeposit .~ pparams ^. L.ppPoolDepositL . to fromIntegral
206-
& #poolRetirementEpochBound .~ pparams ^. L.ppEMaxL . to L.unEpochInterval . to fromIntegral
207-
& #desiredNumberOfPools .~ pparams ^. L.ppNOptL . to fromIntegral
208-
& #poolInfluence .~ pparams ^. L.ppA0L . to L.unboundRational . to inject
209-
& #monetaryExpansion .~ pparams ^. L.ppRhoL . to L.unboundRational . to inject
210-
& #treasuryExpansion .~ pparams ^. L.ppTauL . to L.unboundRational . to inject
211-
& #minPoolCost .~ pparams ^. L.ppMinPoolCostL . to fromIntegral
212-
& #protocolVersion . #major .~ pparams ^. L.ppProtocolVersionL . to L.pvMajor . to L.getVersion
213-
& #protocolVersion . #minor .~ pparams ^. L.ppProtocolVersionL . to L.pvMinor . to fromIntegral
214-
& #maxValueSize .~ pparams ^. L.ppMaxValSizeL . to fromIntegral
215-
& #collateralPercentage .~ pparams ^. L.ppCollateralPercentageL . to fromIntegral
216-
& #maxCollateralInputs .~ pparams ^. L.ppMaxCollateralInputsL . to fromIntegral
217-
& #costModels . #plutusV1 . #values .~ (join . maybeToList) (M.lookup L.PlutusV1 pparamsCostModels)
218-
& #costModels . #plutusV2 . #values .~ (join . maybeToList) (M.lookup L.PlutusV2 pparamsCostModels)
219-
& #costModels . #plutusV3 . #values .~ (join . maybeToList) (M.lookup L.PlutusV3 pparamsCostModels)
220-
& #costModels . #plutusV4 . #values .~ (join . maybeToList) (M.lookup L.PlutusV4 pparamsCostModels)
221-
& #prices . #steps .~ pparams ^. L.ppPricesL . to L.prSteps . to L.unboundRational . to inject
222-
& #prices . #memory .~ pparams ^. L.ppPricesL . to L.prMem . to L.unboundRational . to inject
223-
& #maxExecutionUnitsPerTransaction .~ pparams ^. L.ppMaxTxExUnitsL . to inject
224-
& #maxExecutionUnitsPerBlock .~ pparams ^. L.ppMaxBlockExUnitsL . to inject
225-
& #minFeeScriptRefCostPerByte
226-
.~ pparams ^. L.ppMinFeeRefScriptCostPerByteL . to L.unboundRational . to inject
227-
& #poolVotingThresholds . #thresholds
228-
.~ ( inject . L.unboundRational
229-
-- order taken from https://github.com/cardano-foundation/CIPs/blob/acb4b2348c968003dfc370cd3769615bfca1f159/CIP-1694/README.md#requirements
230-
<$> [ poolVotingThresholds ^. L.pvtMotionNoConfidenceL
231-
, poolVotingThresholds ^. L.pvtCommitteeNormalL
232-
, poolVotingThresholds ^. L.pvtCommitteeNoConfidenceL
233-
, poolVotingThresholds ^. L.pvtHardForkInitiationL
234-
, poolVotingThresholds ^. L.pvtPPSecurityGroupL
235-
]
236-
)
237-
& #drepVotingThresholds . #thresholds
238-
.~ ( inject . L.unboundRational
239-
-- order taken from https://github.com/cardano-foundation/CIPs/blob/acb4b2348c968003dfc370cd3769615bfca1f159/CIP-1694/README.md#requirements
240-
<$> [ drepVotingThresholds ^. L.dvtMotionNoConfidenceL
241-
, drepVotingThresholds ^. L.dvtCommitteeNormalL
242-
, drepVotingThresholds ^. L.dvtCommitteeNoConfidenceL
243-
, drepVotingThresholds ^. L.dvtUpdateToConstitutionL
244-
, drepVotingThresholds ^. L.dvtHardForkInitiationL
245-
, drepVotingThresholds ^. L.dvtPPNetworkGroupL
246-
, drepVotingThresholds ^. L.dvtPPEconomicGroupL
247-
, drepVotingThresholds ^. L.dvtPPTechnicalGroupL
248-
, drepVotingThresholds ^. L.dvtPPGovGroupL
249-
, drepVotingThresholds ^. L.dvtTreasuryWithdrawalL
250-
]
251-
)
252-
& #minCommitteeSize .~ pparams ^. L.ppCommitteeMinSizeL . to fromIntegral
253-
& #committeeTermLimit
254-
.~ pparams ^. L.ppCommitteeMaxTermLengthL . to L.unEpochInterval . to fromIntegral
255-
& #governanceActionValidityPeriod
256-
.~ pparams ^. L.ppGovActionLifetimeL . to L.unEpochInterval . to fromIntegral
257-
& #governanceActionDeposit .~ pparams ^. L.ppGovActionDepositL . to fromIntegral
258-
& #drepDeposit .~ pparams ^. L.ppDRepDepositL . to fromIntegral
259-
& #drepInactivityPeriod .~ pparams ^. L.ppDRepActivityL . to L.unEpochInterval . to fromIntegral
260-
26163
instance Message a => Default (Proto a) where
26264
def = defMessage
26365

@@ -268,7 +70,7 @@ instance Message a => Default (Proto a) where
26870
-- TODO add RIO to cardano-api and move this instance there
26971

27072
instance Error StringException where
271-
prettyError = pshow
73+
prettyError = prettyException
27274

27375
instance IsString e => MonadFail (Either e) where
27476
fail = Left . fromString

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

Lines changed: 7 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -8,6 +8,7 @@
88
{-# LANGUAGE QuantifiedConstraints #-}
99
{-# LANGUAGE RankNTypes #-}
1010
{-# LANGUAGE ScopedTypeVariables #-}
11+
{-# LANGUAGE TypeApplications #-}
1112

1213
module Cardano.Rpc.Server.Internal.UtxoRpc.Query
1314
( readParamsMethod
@@ -16,6 +17,7 @@ module Cardano.Rpc.Server.Internal.UtxoRpc.Query
1617
where
1718

1819
import Cardano.Api
20+
import Cardano.Api.Experimental.Era
1921
import Cardano.Api.Parser.Text qualified as P
2022
import Cardano.Rpc.Proto.Api.UtxoRpc.Query qualified as UtxoRpc
2123
import Cardano.Rpc.Server.Internal.Error
@@ -41,7 +43,7 @@ readParamsMethod _req = do
4143
-- let fieldMask :: [Text] = req ^. #fieldMask . #paths
4244
nodeConnInfo <- grab
4345
AnyCardanoEra era <- liftIO . throwExceptT $ determineEra nodeConnInfo
44-
eon <- forEraInEon era (error "Minimum Conway era required") pure
46+
eon <- forEraInEon @Era era (error "Minimum Conway era required") pure
4547
let sbe = convert eon
4648

4749
let target = VolatileTip
@@ -54,7 +56,7 @@ readParamsMethod _req = do
5456
pure $
5557
def
5658
& #ledgerTip .~ mkChainPointMsg chainPoint blockNo
57-
& #values . #cardano .~ conwayEraOnwardsConstraints eon (inject pparams)
59+
& #values . #cardano .~ obtainCommonConstraints eon (protocolParamsToUtxoRpcPParams eon pparams)
5860

5961
readUtxosMethod
6062
:: MonadRpc e m
@@ -71,19 +73,19 @@ readUtxosMethod req = do
7173

7274
nodeConnInfo <- grab
7375
AnyCardanoEra era <- liftIO . throwExceptT $ determineEra nodeConnInfo
74-
eon <- forEraInEon era (error "Minimum Shelley era required") pure
76+
eon <- forEraInEon @Era era (error "Minimum Conway era required") pure
7577

7678
let target = VolatileTip
7779
(utxo, chainPoint, blockNo) <- liftIO . (throwEither =<<) $ executeLocalStateQueryExpr nodeConnInfo target $ do
78-
utxo <- throwEither =<< throwEither =<< queryUtxo eon utxoFilter
80+
utxo <- throwEither =<< throwEither =<< queryUtxo (convert eon) utxoFilter
7981
chainPoint <- throwEither =<< queryChainPoint
8082
blockNo <- throwEither =<< queryChainBlockNo
8183
pure (utxo, chainPoint, blockNo)
8284

8385
pure $
8486
defMessage
8587
& #ledgerTip .~ mkChainPointMsg chainPoint blockNo
86-
& #items .~ cardanoEraConstraints era (inject utxo)
88+
& #items .~ obtainCommonConstraints eon (utxoToUtxoRpcAnyUtxoData utxo)
8789
where
8890
txoRefToTxIn :: MonadRpc e m => Proto UtxoRpc.TxoRef -> m TxIn
8991
txoRefToTxIn r = do

0 commit comments

Comments
 (0)