Skip to content

Commit 70a5ffd

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

File tree

6 files changed

+185
-22
lines changed

6 files changed

+185
-22
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/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 roundtripping injections
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: 36 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -10,6 +10,7 @@
1010

1111
module Cardano.Rpc.Server.Internal.UtxoRpc.Query
1212
( readParamsMethod
13+
, readUtxosMethod
1314
)
1415
where
1516

@@ -27,11 +28,12 @@ import Cardano.Ledger.Conway.Core qualified as L
2728
import Cardano.Ledger.Conway.PParams qualified as L
2829
import Cardano.Ledger.Plutus qualified as L
2930

30-
import RIO
31+
import RIO hiding (toList)
3132

3233
import Data.ByteString.Short qualified as SBS
3334
import Data.Map.Strict qualified as M
3435
import Data.ProtoLens (defMessage)
36+
import GHC.IsList (fromList, toList)
3537
import Network.GRPC.Spec
3638

3739
readParamsMethod
@@ -63,8 +65,7 @@ readParamsMethod _req = do
6365
drepVotingThresholds :: L.DRepVotingThresholds =
6466
conwayEraOnwardsConstraints eon $
6567
pparams ^. L.ppDRepVotingThresholdsL
66-
67-
let pparamsMsg =
68+
pparamsMsg =
6869
conwayEraOnwardsConstraints eon $
6970
defMessage
7071
& #coinsPerUtxoByte .~ pparams ^. L.ppCoinsPerUTxOByteL . to L.unCoinPerByte . to fromIntegral
@@ -149,4 +150,35 @@ mkChainPointMsg chainPoint blockNo = do
149150
& #hash .~ blockHash
150151
& #height .~ blockHeight
151152

152-
-- & #timestamp .~ timestamp -- not supported currently
153+
readUtxosMethod
154+
:: MonadRpc e m
155+
=> Proto UtxoRpc.ReadUtxosRequest
156+
-> m (Proto UtxoRpc.ReadUtxosResponse)
157+
readUtxosMethod req = do
158+
txIns' <- mapM txoRefToTxIn $ req ^. #keys
159+
-- TODO Make this explicit in the request type definition in proto, that no txins will return whole utxo
160+
let utxoFilter =
161+
if null txIns'
162+
then QueryUTxOWhole
163+
else QueryUTxOByTxIn . fromList . toList $ txIns'
164+
165+
nodeConnInfo <- grab
166+
AnyCardanoEra era <- liftIO . throwExceptT $ determineEra nodeConnInfo
167+
eon <- forEraInEon era (error "Minimum Shelley era required") pure
168+
169+
let target = VolatileTip
170+
(utxo, chainPoint, blockNo) <- liftIO . (throwEither =<<) $ executeLocalStateQueryExpr nodeConnInfo target $ do
171+
utxo <- throwEither =<< throwEither =<< queryUtxo eon utxoFilter
172+
chainPoint <- throwEither =<< queryChainPoint
173+
blockNo <- throwEither =<< queryChainBlockNo
174+
pure (utxo, chainPoint, blockNo)
175+
176+
pure $
177+
defMessage
178+
& #ledgerTip .~ mkChainPointMsg chainPoint blockNo
179+
& #items .~ cardanoEraConstraints era (inject utxo)
180+
where
181+
txoRefToTxIn :: MonadRpc e m => Proto UtxoRpc.TxoRef -> m TxIn
182+
txoRefToTxIn r = do
183+
txId' <- throwEither $ deserialiseFromRawBytes AsTxId $ r ^. #hash
184+
pure $ TxIn txId' (TxIx . fromIntegral $ r ^. #index)

‎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)