Skip to content

Commit fa689b9

Browse files
carbolymercarbolymer
committed
wip
1 parent b5686e2 commit fa689b9

File tree

4 files changed

+122
-34
lines changed

4 files changed

+122
-34
lines changed

‎cardano-rpc/cardano-rpc.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -135,3 +135,4 @@ test-suite cardano-rpc-test
135135
other-modules:
136136
Test.Cardano.Rpc.ProtocolParameters
137137
Test.Cardano.Rpc.TxOutput
138+
Test.Cardano.Rpc.Type

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

Lines changed: 18 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -4,6 +4,7 @@
44
{-# LANGUAGE OverloadedLabels #-}
55
{-# LANGUAGE RankNTypes #-}
66
{-# LANGUAGE ScopedTypeVariables #-}
7+
{-# LANGUAGE TypeApplications #-}
78
{-# OPTIONS_GHC -Wno-orphans #-}
89

910
module Cardano.Rpc.Server.Internal.Orphans where
@@ -63,6 +64,23 @@ instance Inject TxIn (Proto UtxoRpc.TxoRef) where
6364
instance Message a => Default (Proto a) where
6465
def = defMessage
6566

67+
instance Inject Integer (Proto UtxoRpc.BigInt) where
68+
inject int
69+
| int <= fromIntegral (maxBound @Int64)
70+
&& int >= fromIntegral (minBound @Int64) =
71+
inject @Int64 $ fromIntegral int
72+
| int < 0 =
73+
-- https://www.rfc-editor.org/rfc/rfc8949.html#name-bignums see 3.4.3 for negative integers
74+
defMessage & #bigNInt .~ serialiseToRawBytes (fromIntegral @_ @Natural (-1 - int))
75+
| otherwise =
76+
defMessage & #bigUInt .~ serialiseToRawBytes (fromIntegral @_ @Natural int)
77+
78+
instance Inject Int64 (Proto UtxoRpc.BigInt) where
79+
inject int = defMessage & #int .~ int
80+
81+
instance Inject L.Coin (Proto UtxoRpc.BigInt) where
82+
inject = inject . fromIntegral @_ @Integer
83+
6684
-----------
6785
-- Errors
6886
-----------

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

Lines changed: 58 additions & 34 deletions
Original file line numberDiff line numberDiff line change
@@ -18,6 +18,7 @@ module Cardano.Rpc.Server.Internal.UtxoRpc.Type
1818
, utxoRpcTxOutputToTxOut
1919
, protocolParamsToUtxoRpcPParams
2020
, simpleScriptToUtxoRpcNativeScript
21+
, utxoRpcBigIntToInteger
2122
, mkChainPointMsg
2223
)
2324
where
@@ -70,20 +71,20 @@ protocolParamsToUtxoRpcPParams era pparams = obtainCommonConstraints era $ do
7071
drepVotingThresholds :: L.DRepVotingThresholds =
7172
pparams ^. L.ppDRepVotingThresholdsL
7273
def
73-
& #coinsPerUtxoByte .~ pparams ^. L.ppCoinsPerUTxOByteL . to L.unCoinPerByte . to fromIntegral
74+
& #coinsPerUtxoByte .~ pparams ^. L.ppCoinsPerUTxOByteL . to L.unCoinPerByte . to inject
7475
& #maxTxSize .~ pparams ^. L.ppMaxTxSizeL . to fromIntegral
75-
& #minFeeCoefficient .~ pparams ^. L.ppMinFeeBL . to fromIntegral
76-
& #minFeeConstant .~ pparams ^. L.ppMinFeeAL . to fromIntegral
76+
& #minFeeCoefficient .~ pparams ^. L.ppMinFeeBL . to inject
77+
& #minFeeConstant .~ pparams ^. L.ppMinFeeAL . to inject
7778
& #maxBlockBodySize .~ pparams ^. L.ppMaxBBSizeL . to fromIntegral
7879
& #maxBlockHeaderSize .~ pparams ^. L.ppMaxBHSizeL . to fromIntegral
79-
& #stakeKeyDeposit .~ pparams ^. L.ppKeyDepositL . to fromIntegral
80-
& #poolDeposit .~ pparams ^. L.ppPoolDepositL . to fromIntegral
80+
& #stakeKeyDeposit .~ pparams ^. L.ppKeyDepositL . to inject
81+
& #poolDeposit .~ pparams ^. L.ppPoolDepositL . to inject
8182
& #poolRetirementEpochBound .~ pparams ^. L.ppEMaxL . to L.unEpochInterval . to fromIntegral
8283
& #desiredNumberOfPools .~ pparams ^. L.ppNOptL . to fromIntegral
8384
& #poolInfluence .~ pparams ^. L.ppA0L . to L.unboundRational . to inject
8485
& #monetaryExpansion .~ pparams ^. L.ppRhoL . to L.unboundRational . to inject
8586
& #treasuryExpansion .~ pparams ^. L.ppTauL . to L.unboundRational . to inject
86-
& #minPoolCost .~ pparams ^. L.ppMinPoolCostL . to fromIntegral
87+
& #minPoolCost .~ pparams ^. L.ppMinPoolCostL . to inject
8788
& #protocolVersion . #major .~ pparams ^. L.ppProtocolVersionL . to L.pvMajor . to L.getVersion
8889
& #protocolVersion . #minor .~ pparams ^. L.ppProtocolVersionL . to L.pvMinor . to fromIntegral
8990
& #maxValueSize .~ pparams ^. L.ppMaxValSizeL . to fromIntegral
@@ -129,8 +130,8 @@ protocolParamsToUtxoRpcPParams era pparams = obtainCommonConstraints era $ do
129130
.~ pparams ^. L.ppCommitteeMaxTermLengthL . to L.unEpochInterval . to fromIntegral
130131
& #governanceActionValidityPeriod
131132
.~ pparams ^. L.ppGovActionLifetimeL . to L.unEpochInterval . to fromIntegral
132-
& #governanceActionDeposit .~ pparams ^. L.ppGovActionDepositL . to fromIntegral
133-
& #drepDeposit .~ pparams ^. L.ppDRepDepositL . to fromIntegral
133+
& #governanceActionDeposit .~ pparams ^. L.ppGovActionDepositL . to inject
134+
& #drepDeposit .~ pparams ^. L.ppDRepDepositL . to inject
134135
& #drepInactivityPeriod .~ pparams ^. L.ppDRepActivityL . to L.unEpochInterval . to fromIntegral
135136

136137
utxoRpcPParamsToProtocolParams
@@ -140,15 +141,25 @@ utxoRpcPParamsToProtocolParams
140141
utxoRpcPParamsToProtocolParams era pp = conwayEraOnwardsConstraints (convert era) $ do
141142
def
142143
& appFuns
143-
[ pure
144-
. (L.ppCoinsPerUTxOByteL .~ pp ^. #coinsPerUtxoByte . to fromIntegral . to L.Coin . to L.CoinPerByte)
144+
[ \r -> do
145+
coinsPerUtxoByte <-
146+
pp ^. #coinsPerUtxoByte . to utxoRpcBigIntToInteger ?! "Invalid coinsPerUtxoByte"
147+
pure $ set L.ppCoinsPerUTxOByteL (L.CoinPerByte $ L.Coin coinsPerUtxoByte) r
145148
, pure . (L.ppMaxTxSizeL .~ pp ^. #maxTxSize . to fromIntegral)
146-
, pure . (L.ppMinFeeBL .~ pp ^. #minFeeCoefficient . to fromIntegral)
147-
, pure . (L.ppMinFeeAL .~ pp ^. #minFeeConstant . to fromIntegral)
149+
, \r -> do
150+
minFeeCoeff <- pp ^. #minFeeCoefficient . to utxoRpcBigIntToInteger ?! "Invalid minFeeCoefficient"
151+
pure $ set L.ppMinFeeBL (L.Coin minFeeCoeff) r
152+
, \r -> do
153+
minFeeConst <- pp ^. #minFeeConstant . to utxoRpcBigIntToInteger ?! "Invalid minFeeConstant"
154+
pure $ set L.ppMinFeeAL (L.Coin minFeeConst) r
148155
, pure . (L.ppMaxBBSizeL .~ pp ^. #maxBlockBodySize . to fromIntegral)
149156
, pure . (L.ppMaxBHSizeL .~ pp ^. #maxBlockHeaderSize . to fromIntegral)
150-
, pure . (L.ppKeyDepositL .~ pp ^. #stakeKeyDeposit . to fromIntegral)
151-
, pure . (L.ppPoolDepositL .~ pp ^. #poolDeposit . to fromIntegral)
157+
, \r -> do
158+
stakeKeyDeposit <- pp ^. #stakeKeyDeposit . to utxoRpcBigIntToInteger ?! "Invalid stakeKeyDeposit"
159+
pure $ set L.ppKeyDepositL (L.Coin stakeKeyDeposit) r
160+
, \r -> do
161+
poolDeposit <- pp ^. #poolDeposit . to utxoRpcBigIntToInteger ?! "Invalid poolDeposit"
162+
pure $ set L.ppPoolDepositL (L.Coin poolDeposit) r
152163
, pure . (L.ppEMaxL .~ pp ^. #poolRetirementEpochBound . to fromIntegral . to L.EpochInterval)
153164
, pure . (L.ppNOptL .~ pp ^. #desiredNumberOfPools . to fromIntegral)
154165
, \r -> do
@@ -162,7 +173,9 @@ utxoRpcPParamsToProtocolParams era pp = conwayEraOnwardsConstraints (convert era
162173
treasuryExpansion <-
163174
pp ^. #treasuryExpansion . to inject . to L.boundRational ?! "Invalid treasuryExpansion"
164175
pure $ set L.ppTauL treasuryExpansion r
165-
, pure . (L.ppMinPoolCostL .~ pp ^. #minPoolCost . to fromIntegral)
176+
, \r -> do
177+
minPoolCost <- pp ^. #minPoolCost . to utxoRpcBigIntToInteger ?! "Invalid minPoolCost"
178+
pure $ set L.ppMinPoolCostL (L.Coin minPoolCost) r
166179
, \r -> do
167180
major <- L.mkVersion64 $ pp ^. #protocolVersion . #major . to fromIntegral
168181
pure $ set (L.ppProtocolVersionL . pvMajorL) major r
@@ -273,8 +286,13 @@ utxoRpcPParamsToProtocolParams era pp = conwayEraOnwardsConstraints (convert era
273286
. ( L.ppGovActionLifetimeL
274287
.~ pp ^. #governanceActionValidityPeriod . to fromIntegral . to L.EpochInterval
275288
)
276-
, pure . (L.ppGovActionDepositL .~ pp ^. #governanceActionDeposit . to fromIntegral)
277-
, pure . (L.ppDRepDepositL .~ pp ^. #drepDeposit . to fromIntegral)
289+
, \r -> do
290+
govActionDeposit <-
291+
pp ^. #governanceActionDeposit . to utxoRpcBigIntToInteger ?! "Invalid governanceActionDeposit"
292+
pure $ set L.ppGovActionDepositL (L.Coin govActionDeposit) r
293+
, \r -> do
294+
drepDeposit <- pp ^. #drepDeposit . to utxoRpcBigIntToInteger ?! "Invalid drepDeposit"
295+
pure $ set L.ppDRepDepositL (L.Coin drepDeposit) r
278296
, pure . (L.ppDRepActivityL .~ pp ^. #drepInactivityPeriod . to fromIntegral . to L.EpochInterval)
279297
]
280298
where
@@ -313,7 +331,7 @@ mkChainPointMsg chainPoint blockNo = do
313331
simpleScriptToUtxoRpcNativeScript :: SimpleScript -> Proto UtxoRpc.NativeScript
314332
simpleScriptToUtxoRpcNativeScript = \case
315333
RequireSignature paymentKeyHash ->
316-
defMessage & #scriptPubkey .~ serialiseToRawBytes paymentKeyHash
334+
defMessage & #scriptPubkeyHash .~ serialiseToRawBytes paymentKeyHash
317335
RequireTimeBefore (SlotNo slotNo) ->
318336
defMessage & #invalidHereafter .~ slotNo
319337
RequireTimeAfter (SlotNo slotNo) ->
@@ -335,7 +353,7 @@ utxoRpcNativeScriptToSimpleScript
335353
=> Proto UtxoRpc.NativeScript
336354
-> m SimpleScript
337355
utxoRpcNativeScriptToSimpleScript scriptRpc
338-
| Just paymentKeyHash <- scriptRpc ^. #maybe'scriptPubkey =
356+
| Just paymentKeyHash <- scriptRpc ^. #maybe'scriptPubkeyHash =
339357
RequireSignature <$> liftEitherError (deserialiseFromRawBytes asType paymentKeyHash)
340358
| Just slotNo <- scriptRpc ^. #maybe'invalidHereafter =
341359
pure . RequireTimeBefore $ SlotNo slotNo
@@ -399,15 +417,7 @@ scriptDataToUtxoRpcPlutusData :: ScriptData -> Proto UtxoRpc.PlutusData
399417
scriptDataToUtxoRpcPlutusData = \case
400418
ScriptDataBytes bs ->
401419
defMessage & #boundedBytes .~ bs
402-
ScriptDataNumber int
403-
| int <= fromIntegral (maxBound @Int64)
404-
&& int >= fromIntegral (minBound @Int64) ->
405-
defMessage & #bigInt . #int .~ fromIntegral int
406-
| int < 0 ->
407-
-- https://www.rfc-editor.org/rfc/rfc8949.html#name-bignums see 3.4.3 for negative integers
408-
defMessage & #bigInt . #bigNInt .~ serialiseToRawBytes (fromIntegral @_ @Natural (-1 - int))
409-
| otherwise ->
410-
defMessage & #bigInt . #bigUInt .~ serialiseToRawBytes (fromIntegral @_ @Natural int)
420+
ScriptDataNumber int -> defMessage & #bigInt .~ inject int
411421
ScriptDataList sds ->
412422
defMessage & #array . #items .~ map scriptDataToUtxoRpcPlutusData sds
413423
ScriptDataMap elements -> do
@@ -489,7 +499,7 @@ txOutToUtxoRpcTxOutput (TxOut addressInEra txOutValue datum script) = do
489499
-- we don't have access to info if the coin was minted in the transaction,
490500
-- maybe we should add it later
491501
-- & #maybe'mintCoin .~ Nothing
492-
& #outputCoin .~ fromIntegral qty
502+
& #quantity .~ inject qty
493503
defMessage
494504
& #policyId .~ serialiseToRawBytes pId
495505
& #assets .~ assets
@@ -511,7 +521,7 @@ txOutToUtxoRpcTxOutput (TxOut addressInEra txOutValue datum script) = do
511521

512522
defMessage
513523
& #address .~ T.encodeUtf8 (obtainCommonConstraints (useEra @era) $ serialiseAddress addressInEra)
514-
& #coin .~ fromIntegral (L.unCoin (txOutValueToLovelace txOutValue))
524+
& #coin .~ inject (L.unCoin (txOutValueToLovelace txOutValue))
515525
& #assets .~ multiAsset
516526
& #maybe'datum .~ datumRpc
517527
& #script .~ referenceScriptToUtxoRpcScript script
@@ -544,17 +554,16 @@ utxoRpcTxOutputToTxOut txOutput = do
544554
<$> deserialiseFromRawBytes asType (datumRpc ^. #hash)
545555
Nothing -> pure TxOutDatumNone
546556
referenceScript <- utxoRpcScriptToReferenceScript (txOutput ^. #script)
547-
let coinValue = txOutput ^. #coin . to fromIntegral . to L.Coin . to lovelaceToValue
557+
coinValue <- lovelaceToValue . L.Coin <$> txOutput ^. #coin . to utxoRpcBigIntToInteger
548558
multiAssetValue <- fmap (fromList @Value . join) . forM (txOutput ^. #assets) $ \policyAssets -> do
549559
pId <-
550560
liftEitherError $ deserialiseFromRawBytes AsPolicyId (policyAssets ^. #policyId)
551561
forM (policyAssets ^. #assets) $ \asset -> do
552562
assetName <-
553563
liftEitherError $
554564
deserialiseFromRawBytes AsAssetName (asset ^. #name)
555-
let outCoin = Quantity . fromIntegral $ asset ^. #outputCoin
556-
mintCoin = Quantity . fromIntegral $ asset ^. #mintCoin
557-
pure (AssetId pId assetName, outCoin <> mintCoin)
565+
coin <- Quantity <$> asset ^. #quantity . to utxoRpcBigIntToInteger
566+
pure (AssetId pId assetName, coin)
558567
pure $
559568
TxOut
560569
address
@@ -563,3 +572,18 @@ utxoRpcTxOutputToTxOut txOutput = do
563572
)
564573
datum
565574
referenceScript
575+
576+
utxoRpcBigIntToInteger
577+
:: forall m
578+
. HasCallStack
579+
=> MonadThrow m
580+
=> Proto UtxoRpc.BigInt
581+
-> m Integer
582+
utxoRpcBigIntToInteger bigInt
583+
| Just int <- bigInt ^. #maybe'int = pure $ fromIntegral int
584+
| Just bytes <- bigInt ^. #maybe'bigNInt = do
585+
n <- fmap fromIntegral . liftEitherError $ deserialiseFromRawBytes AsNatural bytes
586+
pure $ -n - 1
587+
| Just bytes <- bigInt ^. #maybe'bigUInt =
588+
fmap fromIntegral . liftEitherError $ deserialiseFromRawBytes AsNatural bytes
589+
| otherwise = pure 0 -- assume default value

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

Lines changed: 45 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,45 @@
1+
{-# LANGUAGE RankNTypes #-}
2+
{-# LANGUAGE ScopedTypeVariables #-}
3+
{-# LANGUAGE TypeApplications #-}
4+
5+
module Test.Cardano.Rpc.Type where
6+
7+
import Cardano.Api.Experimental.Era
8+
import Cardano.Rpc.Server.Internal.UtxoRpc.Type
9+
10+
import RIO
11+
12+
import Test.Gen.Cardano.Api.Typed
13+
( genTxOutUTxOContext
14+
)
15+
16+
import Hedgehog as H
17+
import Hedgehog.Extras qualified as H
18+
import Hedgehog.Gen as H
19+
import Hedgehog.Range as H
20+
21+
-- | Test that @BigInt@ protobuf type conversion to/from Integer roundtrips
22+
hprop_roundtrip_bigint :: Property
23+
hprop_roundtrip_bigint = do
24+
int <- genLargeInteger
25+
let bigInt = inject int
26+
27+
int' <- utxoRpcBigIntToInteger bigInt
28+
H.note_ "Check that Integer -> BigInt -> Integer preserves the value"
29+
int === int'
30+
31+
let bigInt' = inject int'
32+
H.note_ "Check that BigInt -> Integer -> BigInt preserves the value"
33+
bitInt === bigInt'
34+
35+
-- generate integer for each of the BigInt proto type constructors
36+
genLargeInteger :: Gen Integer
37+
genLargeInteger =
38+
H.choice
39+
[ Gen.integral $ H.linearFrom 0 (maxI64 + 1) (2 ^ 128) -- large positive - bigUInt
40+
, Gen.integral $ H.linearFrom 0 - (2 ^ 128) (minI64 - 1) -- large negative - bigNInt
41+
, Gen.integral $ H.linearFrom 0 minI64 maxI64 -- within Int64 size - int
42+
]
43+
where
44+
minI64 = fromIntegral $ minBound @Int64 :: Integer
45+
maxI64 = fromIntegral $ maxBound @Int64 :: Integer

0 commit comments

Comments
 (0)