Skip to content

Commit 369f3eb

Browse files
carbolymercarbolymer
committed
cardano-rpc | Add UTxO RPC readUtxos query
1 parent 7c187b3 commit 369f3eb

File tree

7 files changed

+209
-24
lines changed

7 files changed

+209
-24
lines changed

‎cardano-rpc/cardano-rpc.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -99,3 +99,4 @@ library
9999
proto-lens-protobuf-types,
100100
proto-lens-runtime,
101101
rio,
102+
text,

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

Lines changed: 16 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -21,6 +21,11 @@ message TxoRef {
2121
uint32 index = 2; // Output index.
2222
}
2323

24+
message TxoRefArray {
25+
// TODO u5c: changed to repeated
26+
repeated TxoRef items = 1;
27+
}
28+
2429
// Request to get the chain parameters
2530
message ReadParamsRequest {
2631
google.protobuf.FieldMask field_mask = 1; // Field mask to selectively return fields in the parsed response.
@@ -39,6 +44,11 @@ message ReadParamsResponse {
3944
ChainPoint ledger_tip = 2; // The chain point that represent the ledger current position.
4045
}
4146

47+
// TODO u5c: new type
48+
message AddressArray {
49+
repeated bytes items = 1;
50+
}
51+
4252
// An evenlope that holds an UTxO from any of compatible chains
4353
message AnyUtxoData {
4454
bytes native_bytes = 1; // Original bytes as defined by the chain
@@ -50,8 +60,12 @@ message AnyUtxoData {
5060

5161
// Request to get specific UTxOs
5262
message ReadUtxosRequest {
53-
repeated TxoRef keys = 1; // List of keys UTxOs.
54-
google.protobuf.FieldMask field_mask = 2; // Field mask to selectively return fields.
63+
// TODO u5c: new oneof
64+
oneof query_args {
65+
TxoRefArray txoRefs = 1; // Array of Tx Output references
66+
AddressArray addresses = 2; // Array of addresses
67+
}
68+
google.protobuf.FieldMask field_mask = 3; // Field mask to selectively return fields.
5569
}
5670

5771
// Response containing the UTxOs associated with the requested addresses.

‎cardano-rpc/src/Cardano/Rpc/Proto/Api/UtxoRpc/Query.hs‎

Lines changed: 6 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -14,7 +14,12 @@ import Network.GRPC.Common.Protobuf
1414

1515
import Proto.Utxorpc.V1alpha.Cardano.Cardano
1616
import Proto.Utxorpc.V1alpha.Cardano.Cardano_Fields hiding
17-
( values
17+
( hash
18+
, index
19+
, items
20+
, key
21+
, values
22+
, vec'items
1823
, vec'values
1924
)
2025
import Proto.Utxorpc.V1alpha.Query.Query

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

Lines changed: 4 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -56,7 +56,9 @@ methodsUtxoRpc
5656
:: MonadRpc e m
5757
=> Methods m (ProtobufMethodsOf UtxoRpc.QueryService)
5858
methodsUtxoRpc =
59-
Method (mkNonStreaming readParamsMethod) NoMoreMethods
59+
Method (mkNonStreaming readParamsMethod)
60+
. Method (mkNonStreaming readUtxosMethod)
61+
$ NoMoreMethods
6062

6163
runRpcServer
6264
:: Tracer IO String
@@ -86,7 +88,7 @@ runRpcServer tracer loadRpcConfig = handleFatalExceptions $ do
8688

8789
-- TODO this is logged by node configuration already, so it would make sense to log it again when
8890
-- configuration gets reloaded
89-
-- traceWith $ "RPC configuration: " <> show rpcConfig
91+
-- traceWith tracer $ "RPC configuration: " <> show rpcConfig
9092

9193
when isEnabled $
9294
runRIO rpcEnv $

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

Lines changed: 137 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -1,23 +1,42 @@
11
{-# LANGUAGE FlexibleInstances #-}
2+
{-# LANGUAGE GADTs #-}
3+
{-# LANGUAGE LambdaCase #-}
24
{-# LANGUAGE MultiParamTypeClasses #-}
35
{-# LANGUAGE OverloadedLabels #-}
6+
{-# LANGUAGE ScopedTypeVariables #-}
7+
{-# LANGUAGE TypeApplications #-}
48
{-# OPTIONS_GHC -Wno-orphans #-}
59

610
module Cardano.Rpc.Server.Internal.Orphans () where
711

8-
import Cardano.Api.Block (ChainPoint (..), Hash (..), SlotNo (..))
9-
import Cardano.Api.Era (Inject (..))
12+
import Cardano.Api.Address
13+
import Cardano.Api.Block
14+
import Cardano.Api.Era
15+
import Cardano.Api.Error
16+
import Cardano.Api.Ledger qualified as L
17+
import Cardano.Api.Plutus
18+
import Cardano.Api.Pretty
19+
import Cardano.Api.Serialise.Raw
20+
import Cardano.Api.Tx
21+
import Cardano.Api.Value
1022
import Cardano.Rpc.Proto.Api.UtxoRpc.Query qualified as UtxoRpc
1123

12-
import Cardano.Ledger.Plutus qualified as L
24+
import RIO hiding (toList)
1325

14-
import RIO
15-
16-
import Data.ByteString.Short qualified as SBS
1726
import Data.ProtoLens (defMessage)
1827
import Data.Ratio (Ratio, denominator, numerator, (%))
28+
import Data.Text.Encoding qualified as T
29+
import GHC.IsList
1930
import Network.GRPC.Spec
2031

32+
---------------
33+
-- Conversion
34+
---------------
35+
36+
-- It's easier to use 'Proto a' wrappers for RPC types, because it makes lens automatically available.
37+
38+
-- TODO: write property tests for bijections
39+
2140
instance Inject (Proto UtxoRpc.RationalNumber) (Ratio Integer) where
2241
inject r = r ^. #numerator . to fromIntegral % r ^. #denominator . to fromIntegral
2342

@@ -40,12 +59,116 @@ instance Inject L.ExUnits (Proto UtxoRpc.ExUnits) where
4059
& #memory .~ fromIntegral mem
4160
& #steps .~ fromIntegral steps
4261

43-
instance Inject ChainPoint (Proto UtxoRpc.ChainPoint) where
44-
inject chainPoint = do
45-
let (slotNo, blockHash) =
46-
case chainPoint of
47-
ChainPointAtGenesis -> (0, mempty)
48-
ChainPoint (SlotNo slot) (HeaderHash hash) -> (slot, SBS.fromShort hash)
62+
-- | Note that conversion is not total in the other direction
63+
instance Inject TxIn (Proto UtxoRpc.TxoRef) where
64+
inject (TxIn txId' (TxIx txIx)) =
4965
defMessage
50-
& #slot .~ slotNo
51-
& #hash .~ blockHash
66+
& #hash .~ serialiseToRawBytes txId'
67+
& #index .~ fromIntegral txIx
68+
69+
instance Inject ScriptData (Proto UtxoRpc.PlutusData) where
70+
inject = \case
71+
ScriptDataBytes bs ->
72+
defMessage & #boundedBytes .~ bs
73+
ScriptDataNumber int ->
74+
defMessage & #bigInt . #int .~ fromIntegral int
75+
ScriptDataList sds ->
76+
defMessage & #array . #items .~ map inject sds
77+
ScriptDataMap elements -> do
78+
let pairs =
79+
elements <&> \(k, v) ->
80+
defMessage
81+
& #key .~ inject k
82+
& #value .~ inject v
83+
defMessage & #map . #pairs .~ pairs
84+
ScriptDataConstructor tag args -> do
85+
let constr =
86+
defMessage
87+
& #tag .~ fromIntegral tag
88+
& #fields .~ map inject args
89+
defMessage & #constr .~ constr
90+
91+
instance Inject (ReferenceScript era) (Proto UtxoRpc.Script) where
92+
inject ReferenceScriptNone = defMessage
93+
inject (ReferenceScript _ (ScriptInAnyLang _ script)) =
94+
case script of
95+
SimpleScript ss ->
96+
defMessage & #native .~ inject ss
97+
PlutusScript PlutusScriptV1 ps ->
98+
defMessage & #plutusV1 .~ serialiseToRawBytes ps
99+
PlutusScript PlutusScriptV2 ps ->
100+
defMessage & #plutusV2 .~ serialiseToRawBytes ps
101+
PlutusScript PlutusScriptV3 ps ->
102+
defMessage & #plutusV3 .~ serialiseToRawBytes ps
103+
104+
instance Inject SimpleScript (Proto UtxoRpc.NativeScript) where
105+
inject = \case
106+
RequireSignature paymentKeyHash ->
107+
defMessage & #scriptPubkey .~ serialiseToRawBytes paymentKeyHash
108+
RequireTimeBefore (SlotNo slotNo) ->
109+
defMessage & #invalidHereafter .~ slotNo
110+
RequireTimeAfter (SlotNo slotNo) ->
111+
defMessage & #invalidBefore .~ slotNo
112+
RequireAllOf scripts ->
113+
defMessage & #scriptAll . #items .~ map inject scripts
114+
RequireAnyOf scripts ->
115+
defMessage & #scriptAny . #items .~ map inject scripts
116+
RequireMOf k scripts -> do
117+
let nScriptsOf =
118+
defMessage
119+
& #k .~ fromIntegral k
120+
& #scripts .~ map inject scripts
121+
defMessage & #scriptNOfK .~ nScriptsOf
122+
123+
instance IsCardanoEra era => Inject (UTxO era) [Proto UtxoRpc.AnyUtxoData] where
124+
inject utxo =
125+
toList utxo <&> \(txIn, TxOut addressInEra txOutValue datum script) -> do
126+
let multiAsset =
127+
fromList $
128+
toList (valueToPolicyAssets $ txOutValueToValue txOutValue) <&> \(pId, policyAssets) -> do
129+
let assets =
130+
toList policyAssets <&> \(assetName, Quantity qty) -> do
131+
defMessage
132+
& #name .~ serialiseToRawBytes assetName
133+
& #outputCoin .~ fromIntegral qty
134+
& #mintCoin .~ 0 -- TODO what is this supposed to mean?
135+
defMessage
136+
& #policyId .~ serialiseToRawBytes pId
137+
& #assets .~ assets
138+
& #redeemer .~ defMessage -- TODO remove this field from proto
139+
datumRpc = case datum of
140+
TxOutDatumNone ->
141+
defMessage
142+
TxOutDatumHash _ scriptDataHash ->
143+
defMessage
144+
& #hash .~ serialiseToRawBytes scriptDataHash
145+
& #maybe'payload .~ Nothing -- we don't have it
146+
& #originalCbor .~ mempty -- we don't have it
147+
TxOutDatumInline _ hashableScriptData ->
148+
defMessage
149+
& #hash .~ serialiseToRawBytes (hashScriptDataBytes hashableScriptData)
150+
& #payload .~ inject (getScriptData hashableScriptData)
151+
& #originalCbor .~ getOriginalScriptDataBytes hashableScriptData
152+
153+
protoTxOut =
154+
defMessage
155+
-- TODO we don't have serialiseToRawBytes for AddressInEra, so perhaps this is wrong, because 'address'
156+
-- has type bytes, but we're putting text there
157+
& #address .~ T.encodeUtf8 (cardanoEraConstraints (cardanoEra @era) $ serialiseAddress addressInEra)
158+
& #coin .~ fromIntegral (L.unCoin (txOutValueToLovelace txOutValue))
159+
& #assets .~ multiAsset
160+
& #datum .~ datumRpc
161+
& #script .~ inject script
162+
defMessage
163+
& #nativeBytes .~ "" -- TODO where to get that from? run cbor serialisation of utxos list?
164+
& #txoRef .~ inject txIn
165+
& #cardano .~ protoTxOut
166+
167+
-----------
168+
-- Errors
169+
-----------
170+
171+
-- TODO add RIO to cardano-api and move this instance there
172+
173+
instance Error StringException where
174+
prettyError = pshow

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

Lines changed: 44 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -3,18 +3,21 @@
33
{-# LANGUAGE DerivingVia #-}
44
{-# LANGUAGE FlexibleContexts #-}
55
{-# LANGUAGE GADTs #-}
6+
{-# LANGUAGE MultiWayIf #-}
67
{-# LANGUAGE OverloadedLabels #-}
78
{-# LANGUAGE QuantifiedConstraints #-}
89
{-# LANGUAGE RankNTypes #-}
910
{-# LANGUAGE ScopedTypeVariables #-}
1011

1112
module Cardano.Rpc.Server.Internal.UtxoRpc.Query
1213
( readParamsMethod
14+
, readUtxosMethod
1315
)
1416
where
1517

1618
import Cardano.Api
1719
import Cardano.Api.Ledger qualified as L
20+
import Cardano.Api.Parser.Text qualified as P
1821
import Cardano.Rpc.Proto.Api.UtxoRpc.Query qualified as UtxoRpc
1922
import Cardano.Rpc.Server.Internal.Error
2023
import Cardano.Rpc.Server.Internal.Monad
@@ -27,11 +30,13 @@ import Cardano.Ledger.Conway.Core qualified as L
2730
import Cardano.Ledger.Conway.PParams qualified as L
2831
import Cardano.Ledger.Plutus qualified as L
2932

30-
import RIO
33+
import RIO hiding (toList)
3134

3235
import Data.ByteString.Short qualified as SBS
3336
import Data.Map.Strict qualified as M
3437
import Data.ProtoLens (defMessage)
38+
import Data.Text.Encoding qualified as T
39+
import GHC.IsList
3540
import Network.GRPC.Spec
3641

3742
readParamsMethod
@@ -63,8 +68,7 @@ readParamsMethod _req = do
6368
drepVotingThresholds :: L.DRepVotingThresholds =
6469
conwayEraOnwardsConstraints eon $
6570
pparams ^. L.ppDRepVotingThresholdsL
66-
67-
let pparamsMsg =
71+
pparamsMsg =
6872
conwayEraOnwardsConstraints eon $
6973
defMessage
7074
& #coinsPerUtxoByte .~ pparams ^. L.ppCoinsPerUTxOByteL . to L.unCoinPerByte . to fromIntegral
@@ -149,4 +153,40 @@ mkChainPointMsg chainPoint blockNo = do
149153
& #hash .~ blockHash
150154
& #height .~ blockHeight
151155

152-
-- & #timestamp .~ timestamp -- not supported currently
156+
readUtxosMethod
157+
:: MonadRpc e m
158+
=> Proto UtxoRpc.ReadUtxosRequest
159+
-> m (Proto UtxoRpc.ReadUtxosResponse)
160+
readUtxosMethod req = do
161+
utxoFilter <-
162+
if
163+
| Just txoRefs <- req ^. #maybe'txoRefs ->
164+
QueryUTxOByTxIn . fromList <$> mapM txoRefToTxIn (txoRefs ^. #items)
165+
| Just addressesProto <- req ^. #maybe'addresses ->
166+
QueryUTxOByAddress . fromList <$> mapM readAddress (addressesProto ^. #items)
167+
| otherwise -> pure QueryUTxOWhole
168+
169+
nodeConnInfo <- grab
170+
AnyCardanoEra era <- liftIO . throwExceptT $ determineEra nodeConnInfo
171+
eon <- forEraInEon era (error "Minimum Shelley era required") pure
172+
173+
let target = VolatileTip
174+
(utxo, chainPoint, blockNo) <- liftIO . (throwEither =<<) $ executeLocalStateQueryExpr nodeConnInfo target $ do
175+
utxo <- throwEither =<< throwEither =<< queryUtxo eon utxoFilter
176+
chainPoint <- throwEither =<< queryChainPoint
177+
blockNo <- throwEither =<< queryChainBlockNo
178+
pure (utxo, chainPoint, blockNo)
179+
180+
pure $
181+
defMessage
182+
& #ledgerTip .~ mkChainPointMsg chainPoint blockNo
183+
& #items .~ cardanoEraConstraints era (inject utxo)
184+
where
185+
txoRefToTxIn :: MonadRpc e m => Proto UtxoRpc.TxoRef -> m TxIn
186+
txoRefToTxIn r = do
187+
txId' <- throwEither $ deserialiseFromRawBytes AsTxId $ r ^. #hash
188+
pure $ TxIn txId' (TxIx . fromIntegral $ r ^. #index)
189+
190+
readAddress :: MonadRpc e m => ByteString -> m AddressAny
191+
readAddress =
192+
throwEither . first stringException . P.runParser parseAddressAny <=< throwEither . T.decodeUtf8'

‎fourmolu.yaml‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -55,7 +55,7 @@ sort-deriving-clauses: false
5555
trailing-section-operators: true
5656
unicode: never
5757
respectful: false
58-
fixities:
58+
fixities:
5959
- infixl 1 &
6060
- infixr 4 .~
6161
reexports: []

0 commit comments

Comments
 (0)