wip

Author: carbolymer

cardano-rpc/cardano-rpc.cabal

@@ -135,3 +135,4 @@ test-suite cardano-rpc-test
   other-modules:
     Test.Cardano.Rpc.ProtocolParameters
     Test.Cardano.Rpc.TxOutput
+    Test.Cardano.Rpc.Type

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

@@ -4,6 +4,7 @@
 {-# LANGUAGE OverloadedLabels #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 module Cardano.Rpc.Server.Internal.Orphans where
@@ -63,6 +64,23 @@ instance Inject TxIn (Proto UtxoRpc.TxoRef) where
 instance Message a => Default (Proto a) where
   def = defMessage
 
+instance Inject Integer (Proto UtxoRpc.BigInt) where
+  inject int
+    | int <= fromIntegral (maxBound @Int64)
+        && int >= fromIntegral (minBound @Int64) =
+        inject @Int64 $ fromIntegral int
+    | int < 0 =
+        -- https://www.rfc-editor.org/rfc/rfc8949.html#name-bignums see 3.4.3 for negative integers
+        defMessage & #bigNInt .~ serialiseToRawBytes (fromIntegral @_ @Natural (-1 - int))
+    | otherwise =
+        defMessage & #bigUInt .~ serialiseToRawBytes (fromIntegral @_ @Natural int)
+
+instance Inject Int64 (Proto UtxoRpc.BigInt) where
+  inject int = defMessage & #int .~ int
+
+instance Inject L.Coin (Proto UtxoRpc.BigInt) where
+  inject = inject . fromIntegral @_ @Integer
+
 -----------
 -- Errors
 -----------

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

@@ -18,6 +18,7 @@ module Cardano.Rpc.Server.Internal.UtxoRpc.Type
   , utxoRpcTxOutputToTxOut
   , protocolParamsToUtxoRpcPParams
   , simpleScriptToUtxoRpcNativeScript
+  , utxoRpcBigIntToInteger
   , mkChainPointMsg
   )
 where
@@ -70,20 +71,20 @@ protocolParamsToUtxoRpcPParams era pparams = obtainCommonConstraints era $ do
       drepVotingThresholds :: L.DRepVotingThresholds =
         pparams ^. L.ppDRepVotingThresholdsL
   def
-    & #coinsPerUtxoByte .~ pparams ^. L.ppCoinsPerUTxOByteL . to L.unCoinPerByte . to fromIntegral
+    & #coinsPerUtxoByte .~ pparams ^. L.ppCoinsPerUTxOByteL . to L.unCoinPerByte . to inject
     & #maxTxSize .~ pparams ^. L.ppMaxTxSizeL . to fromIntegral
-    & #minFeeCoefficient .~ pparams ^. L.ppMinFeeBL . to fromIntegral
-    & #minFeeConstant .~ pparams ^. L.ppMinFeeAL . to fromIntegral
+    & #minFeeCoefficient .~ pparams ^. L.ppMinFeeBL . to inject
+    & #minFeeConstant .~ pparams ^. L.ppMinFeeAL . to inject
     & #maxBlockBodySize .~ pparams ^. L.ppMaxBBSizeL . to fromIntegral
     & #maxBlockHeaderSize .~ pparams ^. L.ppMaxBHSizeL . to fromIntegral
-    & #stakeKeyDeposit .~ pparams ^. L.ppKeyDepositL . to fromIntegral
-    & #poolDeposit .~ pparams ^. L.ppPoolDepositL . to fromIntegral
+    & #stakeKeyDeposit .~ pparams ^. L.ppKeyDepositL . to inject
+    & #poolDeposit .~ pparams ^. L.ppPoolDepositL . to inject
     & #poolRetirementEpochBound .~ pparams ^. L.ppEMaxL . to L.unEpochInterval . to fromIntegral
     & #desiredNumberOfPools .~ pparams ^. L.ppNOptL . to fromIntegral
     & #poolInfluence .~ pparams ^. L.ppA0L . to L.unboundRational . to inject
     & #monetaryExpansion .~ pparams ^. L.ppRhoL . to L.unboundRational . to inject
     & #treasuryExpansion .~ pparams ^. L.ppTauL . to L.unboundRational . to inject
-    & #minPoolCost .~ pparams ^. L.ppMinPoolCostL . to fromIntegral
+    & #minPoolCost .~ pparams ^. L.ppMinPoolCostL . to inject
     & #protocolVersion . #major .~ pparams ^. L.ppProtocolVersionL . to L.pvMajor . to L.getVersion
     & #protocolVersion . #minor .~ pparams ^. L.ppProtocolVersionL . to L.pvMinor . to fromIntegral
     & #maxValueSize .~ pparams ^. L.ppMaxValSizeL . to fromIntegral
@@ -129,8 +130,8 @@ protocolParamsToUtxoRpcPParams era pparams = obtainCommonConstraints era $ do
       .~ pparams ^. L.ppCommitteeMaxTermLengthL . to L.unEpochInterval . to fromIntegral
     & #governanceActionValidityPeriod
       .~ pparams ^. L.ppGovActionLifetimeL . to L.unEpochInterval . to fromIntegral
-    & #governanceActionDeposit .~ pparams ^. L.ppGovActionDepositL . to fromIntegral
-    & #drepDeposit .~ pparams ^. L.ppDRepDepositL . to fromIntegral
+    & #governanceActionDeposit .~ pparams ^. L.ppGovActionDepositL . to inject
+    & #drepDeposit .~ pparams ^. L.ppDRepDepositL . to inject
     & #drepInactivityPeriod .~ pparams ^. L.ppDRepActivityL . to L.unEpochInterval . to fromIntegral
 
 utxoRpcPParamsToProtocolParams
@@ -140,8 +141,10 @@ utxoRpcPParamsToProtocolParams
 utxoRpcPParamsToProtocolParams era pp = conwayEraOnwardsConstraints (convert era) $ do
   def
     & appFuns
-      [ pure
-          . (L.ppCoinsPerUTxOByteL .~ pp ^. #coinsPerUtxoByte . to fromIntegral . to L.Coin . to L.CoinPerByte)
+      [ \r -> do
+          coinsPerUtxoByte <-
+            pp ^. #coinsPerUtxoByte . to utxoRpcBigIntToInteger ?! "Invalid coinsPerUtxoByte"
+          pure $ set L.ppCoinsPerUTxOByteL (L.CoinPerByte $ L.Coin coinsPerUtxoByte) r
       , pure . (L.ppMaxTxSizeL .~ pp ^. #maxTxSize . to fromIntegral)
       , pure . (L.ppMinFeeBL .~ pp ^. #minFeeCoefficient . to fromIntegral)
       , pure . (L.ppMinFeeAL .~ pp ^. #minFeeConstant . to fromIntegral)
@@ -399,15 +402,7 @@ 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)
+  ScriptDataNumber int -> defMessage & #bigInt .~ inject int
   ScriptDataList sds ->
     defMessage & #array . #items .~ map scriptDataToUtxoRpcPlutusData sds
   ScriptDataMap elements -> do
@@ -563,3 +558,18 @@ utxoRpcTxOutputToTxOut txOutput = do
       )
       datum
       referenceScript
+
+utxoRpcBigIntToInteger
+  :: forall m
+   . HasCallStack
+  => MonadThrow m
+  => Proto UtxoRpc.BigInt
+  -> m Integer
+utxoRpcBigIntToInteger bigInt
+  | Just int <- bigInt ^. #maybe'int = fromIntegral int
+  | Just bytes <- bigInt ^. #maybe'bigNInt = do
+      n <- fmap fromIntegral . liftEitherError $ deserialiseFromRawBytes AsNatural bytes
+      pure $ -n - 1
+  | Just bytes <- bigInt ^. #maybe'bigUInt =
+      map fromIntegral . liftEitherError $ deserialiseFromRawBytes AsNatural bytes
+  | otherwise = pure 0 -- assume default value

cardano-rpc/test/cardano-rpc-test/Test/Cardano/Rpc/Type.hs

@@ -0,0 +1,45 @@
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Test.Cardano.Rpc.Type where
+
+import Cardano.Api.Experimental.Era
+import Cardano.Rpc.Server.Internal.UtxoRpc.Type
+
+import RIO
+
+import Test.Gen.Cardano.Api.Typed
+  ( genTxOutUTxOContext
+  )
+
+import Hedgehog as H
+import Hedgehog.Extras qualified as H
+import Hedgehog.Gen as H
+import Hedgehog.Range as H
+
+-- | Test that @BigInt@ protobuf type conversion to/from Integer roundtrips
+hprop_roundtrip_bigint :: Property
+hprop_roundtrip_bigint = do
+  int <- genLargeInteger
+  let bigInt = inject int
+
+  int' <- utxoRpcBigIntToInteger bigInt
+  H.note_ "Check that Integer -> BigInt -> Integer preserves the value"
+  int === int'
+
+  let bigInt' = inject int'
+  H.note_ "Check that BigInt -> Integer -> BigInt preserves the value"
+  bitInt === bigInt'
+
+-- generate integer for each of the BigInt proto type constructors
+genLargeInteger :: Gen Integer
+genLargeInteger =
+  H.choice
+    [ Gen.integral $ H.linearFrom 0 (maxI64 + 1) (2 ^ 128) -- large positive - bigUInt
+    , Gen.integral $ H.linearFrom 0 - (2 ^ 128) (minI64 - 1) -- large negative - bigNInt
+    , Gen.integral $ H.linearFrom 0 minI64 maxI64 -- within Int64 size - int
+    ]
+ where
+  minI64 = fromIntegral $ minBound @Int64 :: Integer
+  maxI64 = fromIntegral $ maxBound @Int64 :: Integer