wip

Author: carbolymer

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] =

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 #-}
@@ -268,6 +269,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
@@ -296,7 +331,7 @@ utxoToUtxoRpcAnyUtxoData utxo =
           TxOutDatumInline _ hashableScriptData ->
             defMessage
               & #hash .~ serialiseToRawBytes (hashScriptDataBytes hashableScriptData)
-              & #payload .~ inject (getScriptData hashableScriptData)
+              & #payload .~ scriptDataToUtxoRpcPlutusData (getScriptData hashableScriptData)
               & #originalCbor .~ getOriginalScriptDataBytes hashableScriptData
 
         protoTxOut =

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