Skip to content

Commit 2e8dc19

Browse files
carbolymercarbolymer
committed
cardano-rpc | Add UTxO RPC readUtxos query
1 parent 87b2afa commit 2e8dc19

File tree

5 files changed

+172
-18
lines changed

5 files changed

+172
-18
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/Server.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -93,7 +93,7 @@ runRpcServer tracer loadRpcConfig = handleFatalExceptions $ do
9393

9494
-- TODO this is logged by node configuration already, so it would make sense to log it again when
9595
-- configuration gets reloaded
96-
-- traceWith $ "RPC configuration: " <> show rpcConfig
96+
-- traceWith tracer $ "RPC configuration: " <> show rpcConfig
9797

9898
when isEnabled $
9999
runRIO rpcEnv $

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

Lines changed: 138 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -1,23 +1,45 @@
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.UTxO (UTxO)
22+
import Cardano.Api.Value
1023
import Cardano.Rpc.Proto.Api.UtxoRpc.Query qualified as UtxoRpc
1124

1225
import Cardano.Ledger.Plutus qualified as L
1326

14-
import RIO
27+
import RIO hiding (toList)
1528

16-
import Data.ByteString.Short qualified as SBS
1729
import Data.ProtoLens (defMessage)
1830
import Data.Ratio (Ratio, denominator, numerator, (%))
31+
import Data.Text.Encoding qualified as T
32+
import GHC.IsList
1933
import Network.GRPC.Spec
2034

35+
---------------
36+
-- Conversion
37+
---------------
38+
39+
-- It's easier to use 'Proto a' wrappers for RPC types, because it makes lens automatically available.
40+
41+
-- TODO: write property tests for roundtripping injections
42+
2143
instance Inject (Proto UtxoRpc.RationalNumber) (Ratio Integer) where
2244
inject r = r ^. #numerator . to fromIntegral % r ^. #denominator . to fromIntegral
2345

@@ -40,12 +62,116 @@ instance Inject L.ExUnits (Proto UtxoRpc.ExUnits) where
4062
& #memory .~ fromIntegral mem
4163
& #steps .~ fromIntegral steps
4264

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

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

Lines changed: 31 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -33,11 +33,12 @@ import Cardano.Ledger.Conway.Core qualified as L
3333
import Cardano.Ledger.Conway.PParams qualified as L
3434
import Cardano.Ledger.Plutus qualified as L
3535

36-
import RIO
36+
import RIO hiding (toList)
3737

3838
import Data.ByteString.Short qualified as SBS
3939
import Data.Map.Strict qualified as M
4040
import Data.ProtoLens (defMessage)
41+
import GHC.IsList (fromList, toList)
4142
import Network.GRPC.Spec
4243

4344
readParamsMethod
@@ -69,8 +70,7 @@ readParamsMethod _req = do
6970
drepVotingThresholds :: L.DRepVotingThresholds =
7071
conwayEraOnwardsConstraints eon $
7172
pparams ^. L.ppDRepVotingThresholdsL
72-
73-
let pparamsMsg =
73+
pparamsMsg =
7474
conwayEraOnwardsConstraints eon $
7575
defMessage
7676
& #coinsPerUtxoByte .~ pparams ^. L.ppCoinsPerUTxOByteL . to L.unCoinPerByte . to fromIntegral
@@ -179,7 +179,34 @@ readUtxosMethod
179179
:: MonadRpc e m
180180
=> Proto UtxoRpc.ReadUtxosRequest
181181
-> m (Proto UtxoRpc.ReadUtxosResponse)
182-
readUtxosMethod _req = throwIO GrpcUnimplemented
182+
readUtxosMethod req = do
183+
txIns' <- mapM txoRefToTxIn $ req ^. #keys
184+
-- TODO Make this explicit in the request type definition in proto, that no txins will return whole utxo
185+
let utxoFilter =
186+
if null txIns'
187+
then QueryUTxOWhole
188+
else QueryUTxOByTxIn . fromList . toList $ txIns'
189+
190+
nodeConnInfo <- grab
191+
AnyCardanoEra era <- liftIO . throwExceptT $ determineEra nodeConnInfo
192+
eon <- forEraInEon era (error "Minimum Shelley era required") pure
193+
194+
let target = VolatileTip
195+
(utxo, chainPoint, blockNo) <- liftIO . (throwEither =<<) $ executeLocalStateQueryExpr nodeConnInfo target $ do
196+
utxo <- throwEither =<< throwEither =<< queryUtxo eon utxoFilter
197+
chainPoint <- throwEither =<< queryChainPoint
198+
blockNo <- throwEither =<< queryChainBlockNo
199+
pure (utxo, chainPoint, blockNo)
200+
201+
pure $
202+
defMessage
203+
& #ledgerTip .~ mkChainPointMsg chainPoint blockNo
204+
& #items .~ cardanoEraConstraints era (inject utxo)
205+
where
206+
txoRefToTxIn :: MonadRpc e m => Proto UtxoRpc.TxoRef -> m TxIn
207+
txoRefToTxIn r = do
208+
txId' <- throwEither $ deserialiseFromRawBytes AsTxId $ r ^. #hash
209+
pure $ TxIn txId' (TxIx . fromIntegral $ r ^. #index)
183210

184211
readDataMethod
185212
:: MonadRpc e m

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