From 814c18d8085461f4088305ab01d5ece8ab4e8d15 Mon Sep 17 00:00:00 2001 From: Mateusz Galazyn Date: Fri, 5 Sep 2025 19:00:35 +0200 Subject: [PATCH 1/6] cardano-rpc | Add decoded PlutusData to Datum in proto definition --- .../utxorpc/v1alpha/cardano/cardano.proto | 47 ++++++++++++++++++- .../Cardano/Rpc/Server/Internal/Orphans.hs | 25 ++++++++++ 2 files changed, 71 insertions(+), 1 deletion(-) diff --git a/cardano-rpc/proto/utxorpc/v1alpha/cardano/cardano.proto b/cardano-rpc/proto/utxorpc/v1alpha/cardano/cardano.proto index dc1a1b0773..60f5734413 100644 --- a/cardano-rpc/proto/utxorpc/v1alpha/cardano/cardano.proto +++ b/cardano-rpc/proto/utxorpc/v1alpha/cardano/cardano.proto @@ -16,9 +16,9 @@ message AddressArray { repeated bytes items = 1; } -// TODO u5c: replaced plutus_data with just bytes message Datum { bytes hash = 1; // Hash of this datum as seen on-chain + PlutusData payload = 2; // Parsed Plutus data payload bytes original_cbor = 3; // Original cbor-encoded data as seen on-chain } @@ -38,6 +38,51 @@ message MultiAsset { repeated Asset assets = 2; // List of custom assets. } +// Represents a constructor for Plutus data in Cardano. +message Constr { + uint32 tag = 1; + uint64 any_constructor = 2; + repeated PlutusData fields = 3; +} + +// Represents a big integer for Plutus data in Cardano. +message BigInt { + oneof big_int { + int64 int = 1; + bytes big_u_int = 2; + bytes big_n_int = 3; + } +} + + +// Represents a key-value pair for Plutus data in Cardano. +message PlutusDataPair { + PlutusData key = 1; // Key of the pair. + PlutusData value = 2; // Value of the pair. +} + +// Represents a Plutus data item in Cardano. +message PlutusData { + oneof plutus_data { + Constr constr = 2; // Constructor. + PlutusDataMap map = 3; // Map of Plutus data. + BigInt big_int = 4; // Big integer. + bytes bounded_bytes = 5; // Bounded bytes. + PlutusDataArray array = 6; // Array of Plutus data. + } +} + +// Represents a map of Plutus data in Cardano. +message PlutusDataMap { + repeated PlutusDataPair pairs = 1; // List of key-value pairs. +} + +// Represents an array of Plutus data in Cardano. +message PlutusDataArray { + repeated PlutusData items = 1; // List of Plutus data items. +} + + // Represents a script in Cardano. // TODO u5c: removed native script representation message Script { diff --git a/cardano-rpc/src/Cardano/Rpc/Server/Internal/Orphans.hs b/cardano-rpc/src/Cardano/Rpc/Server/Internal/Orphans.hs index efde50a6be..b2503a6beb 100644 --- a/cardano-rpc/src/Cardano/Rpc/Server/Internal/Orphans.hs +++ b/cardano-rpc/src/Cardano/Rpc/Server/Internal/Orphans.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedLists #-} @@ -87,6 +88,28 @@ instance Inject (ReferenceScript era) (Proto UtxoRpc.Script) where PlutusScript PlutusScriptV3 ps -> defMessage & #plutusV3 .~ serialiseToRawBytes ps +instance Inject ScriptData (Proto UtxoRpc.PlutusData) where + inject = \case + ScriptDataBytes bs -> + defMessage & #boundedBytes .~ bs + ScriptDataNumber int -> + defMessage & #bigInt . #int .~ fromIntegral int + ScriptDataList sds -> + defMessage & #array . #items .~ map inject sds + ScriptDataMap elements -> do + let pairs = + elements <&> \(k, v) -> + defMessage + & #key .~ inject k + & #value .~ inject v + defMessage & #map . #pairs .~ pairs + ScriptDataConstructor tag args -> do + let constr = + defMessage + & #tag .~ fromIntegral tag + & #fields .~ map inject args + defMessage & #constr .~ constr + instance IsCardanoEra era => Inject (UTxO era) [Proto UtxoRpc.AnyUtxoData] where inject utxo = toList utxo <&> \(txIn, TxOut addressInEra txOutValue datum script) -> do @@ -110,10 +133,12 @@ instance IsCardanoEra era => Inject (UTxO era) [Proto UtxoRpc.AnyUtxoData] where TxOutDatumHash _ scriptDataHash -> defMessage & #hash .~ serialiseToRawBytes scriptDataHash + & #maybe'payload .~ Nothing -- we don't have it & #originalCbor .~ mempty -- we don't have it TxOutDatumInline _ hashableScriptData -> defMessage & #hash .~ serialiseToRawBytes (hashScriptDataBytes hashableScriptData) + & #payload .~ inject (getScriptData hashableScriptData) & #originalCbor .~ getOriginalScriptDataBytes hashableScriptData protoTxOut = From a910830b76a3d51218d9c50bcb1651b44edf19bb Mon Sep 17 00:00:00 2001 From: Mateusz Galazyn Date: Mon, 8 Sep 2025 16:09:05 +0200 Subject: [PATCH 2/6] cardano-rpc | Add native script deserialised form --- .../utxorpc/v1alpha/cardano/cardano.proto | 26 ++++++++++++++++-- .../Cardano/Rpc/Server/Internal/Orphans.hs | 27 ++++++++++++++++--- 2 files changed, 47 insertions(+), 6 deletions(-) diff --git a/cardano-rpc/proto/utxorpc/v1alpha/cardano/cardano.proto b/cardano-rpc/proto/utxorpc/v1alpha/cardano/cardano.proto index 60f5734413..164f832fc3 100644 --- a/cardano-rpc/proto/utxorpc/v1alpha/cardano/cardano.proto +++ b/cardano-rpc/proto/utxorpc/v1alpha/cardano/cardano.proto @@ -38,6 +38,29 @@ message MultiAsset { repeated Asset assets = 2; // List of custom assets. } +// Represents a native script in Cardano. +message NativeScript { + oneof native_script { + bytes script_pubkey = 1; // Script based on an address key hash. + NativeScriptList script_all = 2; // Script that requires all nested scripts to be satisfied. + NativeScriptList script_any = 3; // Script that requires any of the nested scripts to be satisfied. + ScriptNOfK script_n_of_k = 4; // Script that requires k out of n nested scripts to be satisfied. + uint64 invalid_before = 5; // Slot number before which the script is invalid. + uint64 invalid_hereafter = 6; // Slot number after which the script is invalid. + } +} + +// Represents a list of native scripts. +message NativeScriptList { + repeated NativeScript items = 1; // List of native scripts. +} + +// Represents a "k out of n" native script. +message ScriptNOfK { + uint32 k = 1; // The number of required satisfied scripts. + repeated NativeScript scripts = 2; // List of native scripts. +} + // Represents a constructor for Plutus data in Cardano. message Constr { uint32 tag = 1; @@ -84,10 +107,9 @@ message PlutusDataArray { // Represents a script in Cardano. -// TODO u5c: removed native script representation message Script { oneof script { - bytes native = 1; // Native script. + NativeScript native = 1; // Native script. bytes plutus_v1 = 2; // Plutus V1 script. bytes plutus_v2 = 3; // Plutus V2 script. bytes plutus_v3 = 4; // Plutus V3 script. diff --git a/cardano-rpc/src/Cardano/Rpc/Server/Internal/Orphans.hs b/cardano-rpc/src/Cardano/Rpc/Server/Internal/Orphans.hs index b2503a6beb..2524e8f914 100644 --- a/cardano-rpc/src/Cardano/Rpc/Server/Internal/Orphans.hs +++ b/cardano-rpc/src/Cardano/Rpc/Server/Internal/Orphans.hs @@ -12,12 +12,12 @@ module Cardano.Rpc.Server.Internal.Orphans () where import Cardano.Api.Address +import Cardano.Api.Block (SlotNo (..)) import Cardano.Api.Era import Cardano.Api.Error import Cardano.Api.Ledger qualified as L import Cardano.Api.Plutus import Cardano.Api.Pretty -import Cardano.Api.Serialise.Cbor import Cardano.Api.Serialise.Raw import Cardano.Api.Tx import Cardano.Api.Value @@ -79,8 +79,8 @@ instance Inject (ReferenceScript era) (Proto UtxoRpc.Script) where inject ReferenceScriptNone = defMessage inject (ReferenceScript _ (ScriptInAnyLang _ script)) = case script of - SimpleScript _ -> - defMessage & #native .~ serialiseToCBOR script + SimpleScript ss -> + defMessage & #native .~ inject ss PlutusScript PlutusScriptV1 ps -> defMessage & #plutusV1 .~ serialiseToRawBytes ps PlutusScript PlutusScriptV2 ps -> @@ -88,6 +88,25 @@ instance Inject (ReferenceScript era) (Proto UtxoRpc.Script) where PlutusScript PlutusScriptV3 ps -> defMessage & #plutusV3 .~ serialiseToRawBytes ps +instance Inject SimpleScript (Proto UtxoRpc.NativeScript) where + inject = \case + RequireSignature paymentKeyHash -> + defMessage & #scriptPubkey .~ serialiseToRawBytes paymentKeyHash + RequireTimeBefore (SlotNo slotNo) -> + defMessage & #invalidHereafter .~ slotNo + RequireTimeAfter (SlotNo slotNo) -> + defMessage & #invalidBefore .~ slotNo + RequireAllOf scripts -> + defMessage & #scriptAll . #items .~ map inject scripts + RequireAnyOf scripts -> + defMessage & #scriptAny . #items .~ map inject scripts + RequireMOf k scripts -> do + let nScriptsOf = + defMessage + & #k .~ fromIntegral k + & #scripts .~ map inject scripts + defMessage & #scriptNOfK .~ nScriptsOf + instance Inject ScriptData (Proto UtxoRpc.PlutusData) where inject = \case ScriptDataBytes bs -> @@ -120,7 +139,7 @@ instance IsCardanoEra era => Inject (UTxO era) [Proto UtxoRpc.AnyUtxoData] where toList policyAssets <&> \(assetName, Quantity qty) -> do defMessage & #name .~ serialiseToRawBytes assetName - -- we don't have access to info it the coin was minted in the transaction, + -- we don't have access to info if the coin was minted in the transaction, -- maybe we should add it later & #maybe'mintCoin .~ Nothing & #outputCoin .~ fromIntegral qty From dd03b9334b2f67e3e139b2f4b1683e205339977a Mon Sep 17 00:00:00 2001 From: Mateusz Galazyn Date: Tue, 9 Sep 2025 17:08:35 +0200 Subject: [PATCH 3/6] cardano-rpc | Add conversion Integer -> proto.BigInt --- cardano-api/src/Cardano/Api/HasTypeProxy.hs | 10 ++++++++++ cardano-api/src/Cardano/Api/Serialise/Raw.hs | 18 +++++++++++++++++- .../Cardano/Api/Serialise/SerialiseUsing.hs | 6 ++++++ .../utxorpc/v1alpha/cardano/cardano.proto | 2 +- .../src/Cardano/Rpc/Server/Internal/Orphans.hs | 16 +++++++++++++--- 5 files changed, 47 insertions(+), 5 deletions(-) diff --git a/cardano-api/src/Cardano/Api/HasTypeProxy.hs b/cardano-api/src/Cardano/Api/HasTypeProxy.hs index 7606261220..4d8c0b8b23 100644 --- a/cardano-api/src/Cardano/Api/HasTypeProxy.hs +++ b/cardano-api/src/Cardano/Api/HasTypeProxy.hs @@ -13,10 +13,12 @@ module Cardano.Api.HasTypeProxy where import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as BSL import Data.Kind (Constraint, Type) import Data.Proxy (Proxy (..)) import Data.Typeable (Typeable) import Data.Word (Word16, Word8) +import Numeric.Natural (Natural) class Typeable t => HasTypeProxy t where -- | A family of singleton types used in this API to indicate which type to @@ -35,10 +37,18 @@ instance HasTypeProxy Word16 where data AsType Word16 = AsWord16 proxyToAsType _ = AsWord16 +instance HasTypeProxy Natural where + data AsType Natural = AsNatural + proxyToAsType _ = AsNatural + instance HasTypeProxy BS.ByteString where data AsType BS.ByteString = AsByteString proxyToAsType _ = AsByteString +instance HasTypeProxy BSL.ByteString where + data AsType BSL.ByteString = AsByteStringLazy + proxyToAsType _ = AsByteStringLazy + data FromSomeType (c :: Type -> Constraint) b where FromSomeType :: c a => AsType a -> (a -> b) -> FromSomeType c b diff --git a/cardano-api/src/Cardano/Api/Serialise/Raw.hs b/cardano-api/src/Cardano/Api/Serialise/Raw.hs index 0ad204498d..15bec28bbf 100644 --- a/cardano-api/src/Cardano/Api/Serialise/Raw.hs +++ b/cardano-api/src/Cardano/Api/Serialise/Raw.hs @@ -26,13 +26,16 @@ import Data.Bits (Bits (..)) import Data.ByteString qualified as BS import Data.ByteString.Base16 qualified as Base16 import Data.ByteString.Builder qualified as BSB -import Data.ByteString.Char8 as BSC +import Data.ByteString.Char8 (ByteString) +import Data.ByteString.Char8 qualified as BSC +import Data.ByteString.Lazy qualified as BSL import Data.Data (typeRep) import Data.Text (Text) import Data.Text qualified as Text import Data.Text.Encoding qualified as Text import Data.Typeable (TypeRep, Typeable) import Data.Word (Word16, Word8) +import Numeric.Natural (Natural) class (HasTypeProxy a, Typeable a) => SerialiseAsRawBytes a where serialiseToRawBytes :: a -> ByteString @@ -60,10 +63,23 @@ instance SerialiseAsRawBytes Word16 where throwError . SerialiseAsRawBytesError $ "Cannot decode Word16 from (hex): " <> BSC.unpack (Base16.encode bs) +instance SerialiseAsRawBytes Natural where + serialiseToRawBytes 0 = BS.singleton 0x00 + serialiseToRawBytes n = BS.toStrict . BSB.toLazyByteString $ go n mempty + where + go 0 acc = acc + go x acc = go (x `shiftR` 8) (BSB.word8 (fromIntegral (x .&. 0xFF)) <> acc) + deserialiseFromRawBytes AsNatural "\x00" = pure 0 + deserialiseFromRawBytes AsNatural input = pure . Prelude.foldl' (\acc byte -> acc `shiftL` 8 .|. fromIntegral byte) 0 $ BS.unpack input + instance SerialiseAsRawBytes BS.ByteString where serialiseToRawBytes = id deserialiseFromRawBytes AsByteString = pure +instance SerialiseAsRawBytes BSL.ByteString where + serialiseToRawBytes = BSL.toStrict + deserialiseFromRawBytes AsByteStringLazy = pure . BSL.fromStrict + serialiseToRawBytesHex :: SerialiseAsRawBytes a => a -> ByteString serialiseToRawBytesHex = Base16.encode . serialiseToRawBytes diff --git a/cardano-api/src/Cardano/Api/Serialise/SerialiseUsing.hs b/cardano-api/src/Cardano/Api/Serialise/SerialiseUsing.hs index 76c01133b1..58b73576e7 100644 --- a/cardano-api/src/Cardano/Api/Serialise/SerialiseUsing.hs +++ b/cardano-api/src/Cardano/Api/Serialise/SerialiseUsing.hs @@ -17,8 +17,10 @@ import Cardano.Api.Serialise.Json import Cardano.Api.Serialise.Raw import Data.Aeson.Types qualified as Aeson +import Data.ByteString qualified as B import Data.Text.Encoding qualified as Text import Data.Typeable (tyConName, typeRep, typeRepTyCon) +import Numeric (showBin) -- | For use with @deriving via@, to provide 'ToCBOR' and 'FromCBOR' instances, -- based on the 'SerialiseAsRawBytes' instance. @@ -39,6 +41,10 @@ instance SerialiseAsRawBytes a => FromCBOR (UsingRawBytes a) where ttoken = proxyToAsType (Proxy :: Proxy a) tname = (tyConName . typeRepTyCon . typeRep) (Proxy :: Proxy a) +-- | Prints the representation in binary format, quoted +instance SerialiseAsRawBytes a => Show (UsingRawBytes a) where + showsPrec _ (UsingRawBytes x) = showChar '"' . mconcat (map showBin . B.unpack $ serialiseToRawBytes x) . showChar '"' + -- | For use with @deriving via@, to provide instances for any\/all of 'Show', -- 'ToJSON', 'FromJSON', 'ToJSONKey', FromJSONKey' using a hex -- encoding, based on the 'SerialiseAsRawBytes' instance. diff --git a/cardano-rpc/proto/utxorpc/v1alpha/cardano/cardano.proto b/cardano-rpc/proto/utxorpc/v1alpha/cardano/cardano.proto index 164f832fc3..0dd7c6cbcf 100644 --- a/cardano-rpc/proto/utxorpc/v1alpha/cardano/cardano.proto +++ b/cardano-rpc/proto/utxorpc/v1alpha/cardano/cardano.proto @@ -71,7 +71,7 @@ message Constr { // Represents a big integer for Plutus data in Cardano. message BigInt { oneof big_int { - int64 int = 1; + int64 int = 1 [jstype = JS_STRING]; bytes big_u_int = 2; bytes big_n_int = 3; } diff --git a/cardano-rpc/src/Cardano/Rpc/Server/Internal/Orphans.hs b/cardano-rpc/src/Cardano/Rpc/Server/Internal/Orphans.hs index 2524e8f914..8e709ff20f 100644 --- a/cardano-rpc/src/Cardano/Rpc/Server/Internal/Orphans.hs +++ b/cardano-rpc/src/Cardano/Rpc/Server/Internal/Orphans.hs @@ -9,8 +9,9 @@ {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-orphans #-} -module Cardano.Rpc.Server.Internal.Orphans () where +module Cardano.Rpc.Server.Internal.Orphans where +import Cardano.Api (SerialiseAsCBOR (serialiseToCBOR), ToCBOR (..)) import Cardano.Api.Address import Cardano.Api.Block (SlotNo (..)) import Cardano.Api.Era @@ -19,6 +20,7 @@ import Cardano.Api.Ledger qualified as L import Cardano.Api.Plutus import Cardano.Api.Pretty import Cardano.Api.Serialise.Raw +import Cardano.Api.Serialise.SerialiseUsing import Cardano.Api.Tx import Cardano.Api.Value import Cardano.Rpc.Proto.Api.UtxoRpc.Query qualified as UtxoRpc @@ -30,6 +32,7 @@ import Cardano.Ledger.Plutus qualified as L import RIO hiding (toList) +import Data.ByteString qualified as B import Data.Default import Data.Map.Strict qualified as M import Data.ProtoLens (defMessage) @@ -111,8 +114,15 @@ instance Inject ScriptData (Proto UtxoRpc.PlutusData) where inject = \case ScriptDataBytes bs -> defMessage & #boundedBytes .~ bs - ScriptDataNumber int -> - defMessage & #bigInt . #int .~ fromIntegral int + ScriptDataNumber int + | int <= fromIntegral (maxBound @Int64) + && int >= fromIntegral (minBound @Int64) -> + defMessage & #bigInt . #int .~ fromIntegral int + | int < 0 -> + -- https://www.rfc-editor.org/rfc/rfc8949.html#name-bignums see 3.4.3 for negative integers + defMessage & #bigInt . #bigNInt .~ serialiseToRawBytes (fromIntegral @_ @Natural (-1 - int)) + | otherwise -> + defMessage & #bigInt . #bigUInt .~ serialiseToRawBytes (fromIntegral @_ @Natural int) ScriptDataList sds -> defMessage & #array . #items .~ map inject sds ScriptDataMap elements -> do From 7a0a1502875bffa027259ab2ff6449b104069782 Mon Sep 17 00:00:00 2001 From: Mateusz Galazyn Date: Thu, 2 Oct 2025 20:25:48 +0200 Subject: [PATCH 4/6] address remarks --- .../Cardano/Rpc/Server/Internal/Orphans.hs | 79 +--------------- .../Rpc/Server/Internal/UtxoRpc/Query.hs | 2 +- .../Rpc/Server/Internal/UtxoRpc/Type.hs | 94 +++++++++++++++++++ 3 files changed, 97 insertions(+), 78 deletions(-) diff --git a/cardano-rpc/src/Cardano/Rpc/Server/Internal/Orphans.hs b/cardano-rpc/src/Cardano/Rpc/Server/Internal/Orphans.hs index 8e709ff20f..58f84e27d6 100644 --- a/cardano-rpc/src/Cardano/Rpc/Server/Internal/Orphans.hs +++ b/cardano-rpc/src/Cardano/Rpc/Server/Internal/Orphans.hs @@ -78,38 +78,6 @@ instance Inject TxIn (Proto UtxoRpc.TxoRef) where & #hash .~ serialiseToRawBytes txId' & #index .~ fromIntegral txIx -instance Inject (ReferenceScript era) (Proto UtxoRpc.Script) where - inject ReferenceScriptNone = defMessage - inject (ReferenceScript _ (ScriptInAnyLang _ script)) = - case script of - SimpleScript ss -> - defMessage & #native .~ inject ss - PlutusScript PlutusScriptV1 ps -> - defMessage & #plutusV1 .~ serialiseToRawBytes ps - PlutusScript PlutusScriptV2 ps -> - defMessage & #plutusV2 .~ serialiseToRawBytes ps - PlutusScript PlutusScriptV3 ps -> - defMessage & #plutusV3 .~ serialiseToRawBytes ps - -instance Inject SimpleScript (Proto UtxoRpc.NativeScript) where - inject = \case - RequireSignature paymentKeyHash -> - defMessage & #scriptPubkey .~ serialiseToRawBytes paymentKeyHash - RequireTimeBefore (SlotNo slotNo) -> - defMessage & #invalidHereafter .~ slotNo - RequireTimeAfter (SlotNo slotNo) -> - defMessage & #invalidBefore .~ slotNo - RequireAllOf scripts -> - defMessage & #scriptAll . #items .~ map inject scripts - RequireAnyOf scripts -> - defMessage & #scriptAny . #items .~ map inject scripts - RequireMOf k scripts -> do - let nScriptsOf = - defMessage - & #k .~ fromIntegral k - & #scripts .~ map inject scripts - defMessage & #scriptNOfK .~ nScriptsOf - instance Inject ScriptData (Proto UtxoRpc.PlutusData) where inject = \case ScriptDataBytes bs -> @@ -135,55 +103,12 @@ instance Inject ScriptData (Proto UtxoRpc.PlutusData) where ScriptDataConstructor tag args -> do let constr = defMessage + -- TODO investigate if tag is the right field, or should any_constructor be used here + -- https://github.com/IntersectMBO/plutus/blob/fc78c36b545ee287ae8796a0c1a7d04cf31f4cee/plutus-core/plutus-core/src/PlutusCore/Data.hs#L72 & #tag .~ fromIntegral tag & #fields .~ map inject args defMessage & #constr .~ constr -instance IsCardanoEra era => Inject (UTxO era) [Proto UtxoRpc.AnyUtxoData] where - inject utxo = - toList utxo <&> \(txIn, TxOut addressInEra txOutValue datum script) -> do - let multiAsset = - fromList $ - toList (valueToPolicyAssets $ txOutValueToValue txOutValue) <&> \(pId, policyAssets) -> do - let assets = - toList policyAssets <&> \(assetName, Quantity qty) -> do - defMessage - & #name .~ serialiseToRawBytes assetName - -- we don't have access to info if the coin was minted in the transaction, - -- maybe we should add it later - & #maybe'mintCoin .~ Nothing - & #outputCoin .~ fromIntegral qty - defMessage - & #policyId .~ serialiseToRawBytes pId - & #assets .~ assets - datumRpc = case datum of - TxOutDatumNone -> - defMessage - TxOutDatumHash _ scriptDataHash -> - defMessage - & #hash .~ serialiseToRawBytes scriptDataHash - & #maybe'payload .~ Nothing -- we don't have it - & #originalCbor .~ mempty -- we don't have it - TxOutDatumInline _ hashableScriptData -> - defMessage - & #hash .~ serialiseToRawBytes (hashScriptDataBytes hashableScriptData) - & #payload .~ inject (getScriptData hashableScriptData) - & #originalCbor .~ getOriginalScriptDataBytes hashableScriptData - - protoTxOut = - defMessage - -- TODO we don't have serialiseToRawBytes for AddressInEra, so perhaps this is wrong, because 'address' - -- has type bytes, but we're putting text there - & #address .~ T.encodeUtf8 (cardanoEraConstraints (cardanoEra @era) $ serialiseAddress addressInEra) - & #coin .~ fromIntegral (L.unCoin (txOutValueToLovelace txOutValue)) - & #assets .~ multiAsset - & #datum .~ datumRpc - & #script .~ inject script - defMessage - & #nativeBytes .~ "" -- TODO where to get that from? run cbor serialisation of utxos list? - & #txoRef .~ inject txIn - & #cardano .~ protoTxOut - instance L.ConwayEraPParams lera => Inject (L.PParams lera) (Proto UtxoRpc.PParams) where inject pparams = do let pparamsCostModels :: Map L.Language [Int64] = diff --git a/cardano-rpc/src/Cardano/Rpc/Server/Internal/UtxoRpc/Query.hs b/cardano-rpc/src/Cardano/Rpc/Server/Internal/UtxoRpc/Query.hs index c046fa40ab..72280de43f 100644 --- a/cardano-rpc/src/Cardano/Rpc/Server/Internal/UtxoRpc/Query.hs +++ b/cardano-rpc/src/Cardano/Rpc/Server/Internal/UtxoRpc/Query.hs @@ -83,7 +83,7 @@ readUtxosMethod req = do pure $ defMessage & #ledgerTip .~ mkChainPointMsg chainPoint blockNo - & #items .~ cardanoEraConstraints era (inject utxo) + & #items .~ cardanoEraConstraints era (utxoToUtxoRpcAnyUtxoData utxo) where txoRefToTxIn :: MonadRpc e m => Proto UtxoRpc.TxoRef -> m TxIn txoRefToTxIn r = do diff --git a/cardano-rpc/src/Cardano/Rpc/Server/Internal/UtxoRpc/Type.hs b/cardano-rpc/src/Cardano/Rpc/Server/Internal/UtxoRpc/Type.hs index 4cc5d56939..3a7405553c 100644 --- a/cardano-rpc/src/Cardano/Rpc/Server/Internal/UtxoRpc/Type.hs +++ b/cardano-rpc/src/Cardano/Rpc/Server/Internal/UtxoRpc/Type.hs @@ -1,28 +1,44 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} module Cardano.Rpc.Server.Internal.UtxoRpc.Type ( utxoRpcPParamsToProtocolParams + , utxoToUtxoRpcAnyUtxoData , protocolParamsToUtxoRpcPParams + , simpleScriptToUtxoRpcNativeScript , mkChainPointMsg ) where +import Cardano.Api (SerialiseAsCBOR (serialiseToCBOR), ToCBOR (..)) +import Cardano.Api.Address import Cardano.Api.Block +import Cardano.Api.Block (SlotNo (..)) import Cardano.Api.Era +import Cardano.Api.Error import Cardano.Api.Experimental.Era import Cardano.Api.Ledger qualified as L import Cardano.Api.Monad.Error +import Cardano.Api.Plutus +import Cardano.Api.Pretty +import Cardano.Api.Serialise.Raw +import Cardano.Api.Serialise.SerialiseUsing +import Cardano.Api.Tx +import Cardano.Api.Value import Cardano.Rpc.Proto.Api.UtxoRpc.Query qualified as UtxoRpc import Cardano.Rpc.Server.Internal.Orphans () import Cardano.Ledger.Api qualified as L import Cardano.Ledger.BaseTypes (WithOrigin (..)) +import Cardano.Ledger.BaseTypes qualified as L import Cardano.Ledger.Binary.Version qualified as L import Cardano.Ledger.Conway.Core qualified as L import Cardano.Ledger.Conway.PParams qualified as L @@ -33,6 +49,7 @@ import RIO hiding (toList) import Data.ByteString.Short qualified as SBS import Data.Default import Data.ProtoLens (defMessage) +import Data.Text.Encoding qualified as T import GHC.IsList import Network.GRPC.Spec @@ -217,3 +234,80 @@ mkChainPointMsg chainPoint blockNo = do & #slot .~ slotNo & #hash .~ blockHash & #height .~ blockHeight + +simpleScriptToUtxoRpcNativeScript :: SimpleScript -> Proto UtxoRpc.NativeScript +simpleScriptToUtxoRpcNativeScript = \case + RequireSignature paymentKeyHash -> + defMessage & #scriptPubkey .~ serialiseToRawBytes paymentKeyHash + RequireTimeBefore (SlotNo slotNo) -> + defMessage & #invalidHereafter .~ slotNo + RequireTimeAfter (SlotNo slotNo) -> + defMessage & #invalidBefore .~ slotNo + RequireAllOf scripts -> + defMessage & #scriptAll . #items .~ map simpleScriptToUtxoRpcNativeScript scripts + RequireAnyOf scripts -> + defMessage & #scriptAny . #items .~ map simpleScriptToUtxoRpcNativeScript scripts + RequireMOf k scripts -> do + let nScriptsOf = + defMessage + & #k .~ fromIntegral k + & #scripts .~ map simpleScriptToUtxoRpcNativeScript scripts + defMessage & #scriptNOfK .~ nScriptsOf + +referenceScriptToUtxoRpcScript :: ReferenceScript era -> Proto UtxoRpc.Script +referenceScriptToUtxoRpcScript ReferenceScriptNone = defMessage +referenceScriptToUtxoRpcScript (ReferenceScript _ (ScriptInAnyLang _ script)) = + case script of + SimpleScript ss -> + defMessage & #native .~ simpleScriptToUtxoRpcNativeScript ss + PlutusScript PlutusScriptV1 ps -> + defMessage & #plutusV1 .~ serialiseToRawBytes ps + PlutusScript PlutusScriptV2 ps -> + defMessage & #plutusV2 .~ serialiseToRawBytes ps + PlutusScript PlutusScriptV3 ps -> + defMessage & #plutusV3 .~ serialiseToRawBytes ps + +utxoToUtxoRpcAnyUtxoData :: forall era. IsCardanoEra era => UTxO era -> [Proto UtxoRpc.AnyUtxoData] +utxoToUtxoRpcAnyUtxoData utxo = + toList utxo <&> \(txIn, TxOut addressInEra txOutValue datum script) -> do + let multiAsset = + fromList $ + toList (valueToPolicyAssets $ txOutValueToValue txOutValue) <&> \(pId, policyAssets) -> do + let assets = + toList policyAssets <&> \(assetName, Quantity qty) -> do + defMessage + & #name .~ serialiseToRawBytes assetName + -- we don't have access to info if the coin was minted in the transaction, + -- maybe we should add it later + & #maybe'mintCoin .~ Nothing + & #outputCoin .~ fromIntegral qty + defMessage + & #policyId .~ serialiseToRawBytes pId + & #assets .~ assets + datumRpc = case datum of + TxOutDatumNone -> + defMessage + TxOutDatumHash _ scriptDataHash -> + defMessage + & #hash .~ serialiseToRawBytes scriptDataHash + & #maybe'payload .~ Nothing -- we don't have it + & #originalCbor .~ mempty -- we don't have it + TxOutDatumInline _ hashableScriptData -> + defMessage + & #hash .~ serialiseToRawBytes (hashScriptDataBytes hashableScriptData) + & #payload .~ inject (getScriptData hashableScriptData) + & #originalCbor .~ getOriginalScriptDataBytes hashableScriptData + + protoTxOut = + defMessage + -- TODO we don't have serialiseToRawBytes for AddressInEra, so perhaps this is wrong, because 'address' + -- has type bytes, but we're putting text there + & #address .~ T.encodeUtf8 (cardanoEraConstraints (cardanoEra @era) $ serialiseAddress addressInEra) + & #coin .~ fromIntegral (L.unCoin (txOutValueToLovelace txOutValue)) + & #assets .~ multiAsset + & #datum .~ datumRpc + & #script .~ referenceScriptToUtxoRpcScript script + defMessage + & #nativeBytes .~ "" -- TODO where to get that from? run cbor serialisation of utxos list? + & #txoRef .~ inject txIn + & #cardano .~ protoTxOut From 810f789b7d3ff6e4d83b5fc2c441c0324502f398 Mon Sep 17 00:00:00 2001 From: Mateusz Galazyn Date: Tue, 21 Oct 2025 21:46:53 +0200 Subject: [PATCH 5/6] Implement ScriptData Constr serialisation --- cardano-rpc/src/Cardano/Rpc/Server/Internal/Orphans.hs | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/cardano-rpc/src/Cardano/Rpc/Server/Internal/Orphans.hs b/cardano-rpc/src/Cardano/Rpc/Server/Internal/Orphans.hs index 58f84e27d6..4fb0836f84 100644 --- a/cardano-rpc/src/Cardano/Rpc/Server/Internal/Orphans.hs +++ b/cardano-rpc/src/Cardano/Rpc/Server/Internal/Orphans.hs @@ -101,11 +101,14 @@ instance Inject ScriptData (Proto UtxoRpc.PlutusData) where & #value .~ inject v defMessage & #map . #pairs .~ pairs ScriptDataConstructor tag args -> do + -- Details of plutus tag serialisation: + -- https://github.com/IntersectMBO/plutus/blob/fc78c36b545ee287ae8796a0c1a7d04cf31f4cee/plutus-core/plutus-core/src/PlutusCore/Data.hs#L72 let constr = defMessage - -- TODO investigate if tag is the right field, or should any_constructor be used here - -- https://github.com/IntersectMBO/plutus/blob/fc78c36b545ee287ae8796a0c1a7d04cf31f4cee/plutus-core/plutus-core/src/PlutusCore/Data.hs#L72 - & #tag .~ fromIntegral tag + & ( if tag <= fromIntegral (maxBound @Word32) + then #tag .~ fromIntegral tag + else (#tag .~ 102) . (#anyConstructor .~ fromIntegral @_ @Word64 tag) + ) & #fields .~ map inject args defMessage & #constr .~ constr From ca99912ee68a5a2631066f6a8ac0353e7f4d7b8a Mon Sep 17 00:00:00 2001 From: Mateusz Galazyn Date: Wed, 22 Oct 2025 18:52:50 +0200 Subject: [PATCH 6/6] wip --- .../Cardano/Rpc/Server/Internal/Orphans.hs | 34 ----------------- .../Rpc/Server/Internal/UtxoRpc/Type.hs | 37 ++++++++++++++++++- .../Test/Cardano/Rpc/TxOutput.hs | 33 +++++++++++++++++ 3 files changed, 69 insertions(+), 35 deletions(-) create mode 100644 cardano-rpc/test/cardano-rpc-test/Test/Cardano/Rpc/TxOutput.hs diff --git a/cardano-rpc/src/Cardano/Rpc/Server/Internal/Orphans.hs b/cardano-rpc/src/Cardano/Rpc/Server/Internal/Orphans.hs index 4fb0836f84..ffa6a1dd1f 100644 --- a/cardano-rpc/src/Cardano/Rpc/Server/Internal/Orphans.hs +++ b/cardano-rpc/src/Cardano/Rpc/Server/Internal/Orphans.hs @@ -78,40 +78,6 @@ instance Inject TxIn (Proto UtxoRpc.TxoRef) where & #hash .~ serialiseToRawBytes txId' & #index .~ fromIntegral txIx -instance Inject ScriptData (Proto UtxoRpc.PlutusData) where - inject = \case - ScriptDataBytes bs -> - defMessage & #boundedBytes .~ bs - ScriptDataNumber int - | int <= fromIntegral (maxBound @Int64) - && int >= fromIntegral (minBound @Int64) -> - defMessage & #bigInt . #int .~ fromIntegral int - | int < 0 -> - -- https://www.rfc-editor.org/rfc/rfc8949.html#name-bignums see 3.4.3 for negative integers - defMessage & #bigInt . #bigNInt .~ serialiseToRawBytes (fromIntegral @_ @Natural (-1 - int)) - | otherwise -> - defMessage & #bigInt . #bigUInt .~ serialiseToRawBytes (fromIntegral @_ @Natural int) - ScriptDataList sds -> - defMessage & #array . #items .~ map inject sds - ScriptDataMap elements -> do - let pairs = - elements <&> \(k, v) -> - defMessage - & #key .~ inject k - & #value .~ inject v - defMessage & #map . #pairs .~ pairs - ScriptDataConstructor tag args -> do - -- Details of plutus tag serialisation: - -- https://github.com/IntersectMBO/plutus/blob/fc78c36b545ee287ae8796a0c1a7d04cf31f4cee/plutus-core/plutus-core/src/PlutusCore/Data.hs#L72 - let constr = - defMessage - & ( if tag <= fromIntegral (maxBound @Word32) - then #tag .~ fromIntegral tag - else (#tag .~ 102) . (#anyConstructor .~ fromIntegral @_ @Word64 tag) - ) - & #fields .~ map inject args - defMessage & #constr .~ constr - instance L.ConwayEraPParams lera => Inject (L.PParams lera) (Proto UtxoRpc.PParams) where inject pparams = do let pparamsCostModels :: Map L.Language [Int64] = diff --git a/cardano-rpc/src/Cardano/Rpc/Server/Internal/UtxoRpc/Type.hs b/cardano-rpc/src/Cardano/Rpc/Server/Internal/UtxoRpc/Type.hs index 3a7405553c..6fa79855e2 100644 --- a/cardano-rpc/src/Cardano/Rpc/Server/Internal/UtxoRpc/Type.hs +++ b/cardano-rpc/src/Cardano/Rpc/Server/Internal/UtxoRpc/Type.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedLabels #-} @@ -267,6 +268,40 @@ referenceScriptToUtxoRpcScript (ReferenceScript _ (ScriptInAnyLang _ script)) = PlutusScript PlutusScriptV3 ps -> defMessage & #plutusV3 .~ serialiseToRawBytes ps +scriptDataToUtxoRpcPlutusData :: ScriptData -> Proto UtxoRpc.PlutusData +scriptDataToUtxoRpcPlutusData = \case + ScriptDataBytes bs -> + defMessage & #boundedBytes .~ bs + ScriptDataNumber int + | int <= fromIntegral (maxBound @Int64) + && int >= fromIntegral (minBound @Int64) -> + defMessage & #bigInt . #int .~ fromIntegral int + | int < 0 -> + -- https://www.rfc-editor.org/rfc/rfc8949.html#name-bignums see 3.4.3 for negative integers + defMessage & #bigInt . #bigNInt .~ serialiseToRawBytes (fromIntegral @_ @Natural (-1 - int)) + | otherwise -> + defMessage & #bigInt . #bigUInt .~ serialiseToRawBytes (fromIntegral @_ @Natural int) + ScriptDataList sds -> + defMessage & #array . #items .~ map scriptDataToUtxoRpcPlutusData sds + ScriptDataMap elements -> do + let pairs = + elements <&> \(k, v) -> + defMessage + & #key .~ scriptDataToUtxoRpcPlutusData k + & #value .~ scriptDataToUtxoRpcPlutusData v + defMessage & #map . #pairs .~ pairs + ScriptDataConstructor tag args -> do + -- Details of plutus tag serialisation: + -- https://github.com/IntersectMBO/plutus/blob/fc78c36b545ee287ae8796a0c1a7d04cf31f4cee/plutus-core/plutus-core/src/PlutusCore/Data.hs#L72 + let constr = + defMessage + & ( if tag <= fromIntegral (maxBound @Word32) + then #tag .~ fromIntegral tag + else (#tag .~ 102) . (#anyConstructor .~ fromIntegral @_ @Word64 tag) + ) + & #fields .~ map scriptDataToUtxoRpcPlutusData args + defMessage & #constr .~ constr + utxoToUtxoRpcAnyUtxoData :: forall era. IsCardanoEra era => UTxO era -> [Proto UtxoRpc.AnyUtxoData] utxoToUtxoRpcAnyUtxoData utxo = toList utxo <&> \(txIn, TxOut addressInEra txOutValue datum script) -> do @@ -295,7 +330,7 @@ utxoToUtxoRpcAnyUtxoData utxo = TxOutDatumInline _ hashableScriptData -> defMessage & #hash .~ serialiseToRawBytes (hashScriptDataBytes hashableScriptData) - & #payload .~ inject (getScriptData hashableScriptData) + & #payload .~ scriptDataToUtxoRpcPlutusData (getScriptData hashableScriptData) & #originalCbor .~ getOriginalScriptDataBytes hashableScriptData protoTxOut = diff --git a/cardano-rpc/test/cardano-rpc-test/Test/Cardano/Rpc/TxOutput.hs b/cardano-rpc/test/cardano-rpc-test/Test/Cardano/Rpc/TxOutput.hs new file mode 100644 index 0000000000..25bfbd188a --- /dev/null +++ b/cardano-rpc/test/cardano-rpc-test/Test/Cardano/Rpc/TxOutput.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Test.Cardano.Rpc.TxOutput where + +import Cardano.Api.Experimental.Era +import Cardano.Api.ProtocolParameters +import Cardano.Rpc.Server.Internal.UtxoRpc.Type + +import Cardano.Ledger.Api qualified as L +import Cardano.Ledger.BaseTypes qualified as L +import Cardano.Ledger.Coin qualified as L +import Cardano.Ledger.Conway.PParams qualified as L +import Cardano.Ledger.Plutus qualified as L + +import RIO + +import Data.Bits +import Data.Map.Strict qualified as M +import Data.Ratio +import GHC.IsList + +import Test.Gen.Cardano.Api.Typed (genValidProtocolParameters) + +import Hedgehog +import Hedgehog qualified as H + +-- | Test if protocol parameters roundtrip between ledger and proto representation +hprop_roundtrip_tx_output :: Property +hprop_roundtrip_tx_output = H.property $ do + pure ()