cardano-rpc: Reject zero denominator in RationalNumber conversion

Author: carbolymer

.changes/20260711_cardano_rpc_rational_zero_denominator.yml

@@ -0,0 +1,6 @@
+project: cardano-rpc
+pr: 1253
+kind:
+  - bugfix
+description: |
+  Fix server crash when a client-supplied RationalNumber has a zero denominator (the protobuf field default): the value is now rejected as invalid instead of throwing.

cardano-rpc/cardano-rpc.cabal

@@ -69,6 +69,7 @@ library
     Cardano.Rpc.Server.Internal.UtxoRpc.Type.ChainPoint
     Cardano.Rpc.Server.Internal.UtxoRpc.Type.PlutusData
     Cardano.Rpc.Server.Internal.UtxoRpc.Type.ProtocolParameters
+    Cardano.Rpc.Server.Internal.UtxoRpc.Type.Rational
     Cardano.Rpc.Server.Internal.UtxoRpc.Type.Script
     Cardano.Rpc.Server.Internal.UtxoRpc.Type.TxEval
     Cardano.Rpc.Server.Internal.UtxoRpc.Type.TxOutput

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

@@ -31,9 +31,6 @@ import Network.GRPC.Spec
 
 -- It's easier to use 'Proto a' wrappers for RPC types, because it makes lens automatically available.
 
-instance Inject (Proto U5c.RationalNumber) Rational where
-  inject r = r ^. U5c.numerator . to fromIntegral % r ^. U5c.denominator . to fromIntegral
-
 -- | Convert a 'Rational' into a protobuf 'U5c.RationalNumber'.
 --
 -- The UTxO RPC spec fixes the field widths to an @int32@ numerator and a

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

@@ -13,6 +13,7 @@ module Cardano.Rpc.Server.Internal.UtxoRpc.Type
   , protocolParamsToUtxoRpcPParams
   , simpleScriptToUtxoRpcNativeScript
   , utxoRpcBigIntToInteger
+  , utxoRpcRationalNumberToRational
   , mkChainPointMsg
   , utxoRpcChainPointMsgToChainPoint
   , scriptDataToUtxoRpcPlutusData
@@ -28,6 +29,7 @@ import Cardano.Rpc.Server.Internal.UtxoRpc.Type.BigInt
 import Cardano.Rpc.Server.Internal.UtxoRpc.Type.ChainPoint
 import Cardano.Rpc.Server.Internal.UtxoRpc.Type.PlutusData
 import Cardano.Rpc.Server.Internal.UtxoRpc.Type.ProtocolParameters
+import Cardano.Rpc.Server.Internal.UtxoRpc.Type.Rational
 import Cardano.Rpc.Server.Internal.UtxoRpc.Type.Script
 import Cardano.Rpc.Server.Internal.UtxoRpc.Type.TxEval
 import Cardano.Rpc.Server.Internal.UtxoRpc.Type.TxOutput

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

@@ -17,6 +17,7 @@ import Cardano.Rpc.Proto.Api.UtxoRpc.Query qualified as U5c
 import Cardano.Rpc.Proto.Api.UtxoRpc.Query qualified as UtxoRpc
 import Cardano.Rpc.Server.Internal.Orphans ()
 import Cardano.Rpc.Server.Internal.UtxoRpc.Type.BigInt
+import Cardano.Rpc.Server.Internal.UtxoRpc.Type.Rational
 
 import Cardano.Ledger.Api qualified as L
 import Cardano.Ledger.BaseTypes qualified as L
@@ -149,15 +150,25 @@ utxoRpcPParamsToProtocolParams era pp = conwayEraOnwardsConstraints (convert era
       , pure . (L.ppEMaxL .~ pp ^. U5c.poolRetirementEpochBound . to fromIntegral . to L.EpochInterval)
       , pure . (L.ppNOptL .~ pp ^. U5c.desiredNumberOfPools . to fromIntegral)
       , \r -> do
-          poolInfluence <- pp ^. U5c.poolInfluence . to inject . to L.boundRational ?! "Invalid poolInfluence"
+          poolInfluence <-
+            pp
+              ^. U5c.poolInfluence
+                . to (L.boundRational <=< utxoRpcRationalNumberToRational)
+                ?! "Invalid poolInfluence"
           pure $ set L.ppA0L poolInfluence r
       , \r -> do
           monetaryExpansion <-
-            pp ^. U5c.monetaryExpansion . to inject . to L.boundRational ?! "Invalid monetaryExpansion"
+            pp
+              ^. U5c.monetaryExpansion
+                . to (L.boundRational <=< utxoRpcRationalNumberToRational)
+                ?! "Invalid monetaryExpansion"
           pure $ set L.ppRhoL monetaryExpansion r
       , \r -> do
           treasuryExpansion <-
-            pp ^. U5c.treasuryExpansion . to inject . to L.boundRational ?! "Invalid treasuryExpansion"
+            pp
+              ^. U5c.treasuryExpansion
+                . to (L.boundRational <=< utxoRpcRationalNumberToRational)
+                ?! "Invalid treasuryExpansion"
           pure $ set L.ppTauL treasuryExpansion r
       , \r -> do
           minPoolCost <- pp ^. U5c.minPoolCost . to utxoRpcBigIntToInteger ?! "Invalid minPoolCost"
@@ -183,8 +194,18 @@ utxoRpcPParamsToProtocolParams era pp = conwayEraOnwardsConstraints (convert era
           pure $
             r & L.ppCostModelsL .~ L.mkCostModels nonEmptyCostModels
       , \r -> do
-          steps <- pp ^. U5c.prices . U5c.steps . to inject . to L.boundRational ?! "Invalid prices.steps"
-          mem <- pp ^. U5c.prices . U5c.memory . to inject . to L.boundRational ?! "Invalid prices.mem"
+          steps <-
+            pp
+              ^. U5c.prices
+                . U5c.steps
+                . to (L.boundRational <=< utxoRpcRationalNumberToRational)
+                ?! "Invalid prices.steps"
+          mem <-
+            pp
+              ^. U5c.prices
+                . U5c.memory
+                . to (L.boundRational <=< utxoRpcRationalNumberToRational)
+                ?! "Invalid prices.mem"
           pure $
             r
               & L.ppPricesL . prStepsL .~ steps
@@ -195,8 +216,7 @@ utxoRpcPParamsToProtocolParams era pp = conwayEraOnwardsConstraints (convert era
           minFeeScriptRefCostPerByte <-
             pp
               ^. U5c.minFeeScriptRefCostPerByte
-                . to inject
-                . to L.boundRational
+                . to (L.boundRational <=< utxoRpcRationalNumberToRational)
                 ?! "Invalid minFeeScriptRefCostPerByte"
           pure $ set L.ppMinFeeRefScriptCostPerByteL minFeeScriptRefCostPerByte r
       , \r -> do
@@ -218,7 +238,7 @@ utxoRpcPParamsToProtocolParams era pp = conwayEraOnwardsConstraints (convert era
                 , (?! "Invalid value in poolVotingThresholds: hardForkInitiation")
                 , (?! "Invalid value in poolVotingThresholds: ppSecurityGroup")
                 ]
-              $ map (L.boundRational . inject) thresholds
+              $ map (L.boundRational <=< utxoRpcRationalNumberToRational) thresholds
           pure $
             r
               & L.ppPoolVotingThresholdsL . L.pvtMotionNoConfidenceL .~ motionNoConfidence
@@ -255,7 +275,7 @@ utxoRpcPParamsToProtocolParams era pp = conwayEraOnwardsConstraints (convert era
                 , (?! "Invalid value in drepVotingThresholds: ppGovGroup")
                 , (?! "Invalid value in drepVotingThresholds: treasuryWithdrawal")
                 ]
-              $ map (L.boundRational . inject) thresholds
+              $ map (L.boundRational <=< utxoRpcRationalNumberToRational) thresholds
           pure $
             r
               & L.ppDRepVotingThresholdsL . L.dvtMotionNoConfidenceL .~ motionNoConfidence

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

@@ -0,0 +1,21 @@
+module Cardano.Rpc.Server.Internal.UtxoRpc.Type.Rational
+  ( utxoRpcRationalNumberToRational
+  )
+where
+
+import Cardano.Rpc.Proto.Api.UtxoRpc.Query qualified as U5c
+
+import RIO
+
+import Data.Ratio ((%))
+import Network.GRPC.Spec
+
+-- | Convert a protobuf 'U5c.RationalNumber' into a 'Rational'.
+--
+-- Fails with 'Nothing' when the denominator is zero, which is also the
+-- default value of the protobuf field when it is omitted.
+utxoRpcRationalNumberToRational :: Proto U5c.RationalNumber -> Maybe Rational
+utxoRpcRationalNumberToRational r =
+  case r ^. U5c.denominator of
+    0 -> Nothing
+    den -> Just $ r ^. U5c.numerator . to fromIntegral % fromIntegral den

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

@@ -48,42 +48,44 @@ hprop_roundtrip_rational_in_range = H.property $ do
   den <- forAll . H.integral $ H.linear 1 (fromIntegral $ maxBound @Word32)
   let r = num % den :: Rational
       msg = inject r :: Proto U5c.RationalNumber
-  inject msg === r
+  utxoRpcRationalNumberToRational msg === Just r
 
 -- | Rationals with components exceeding the fixed proto field widths convert
 -- to the best representable approximation.
 hprop_rational_conversion_approximates_out_of_range :: Property
 hprop_rational_conversion_approximates_out_of_range = H.propertyOnce $ do
   H.note_ "In-range values convert exactly"
-  throughProto (3 % 4) === 3 % 4
-  throughProto (-(3 % 7)) === (-3) % 7
+  throughProto (3 % 4) === Just (3 % 4)
+  throughProto (-(3 % 7)) === Just ((-3) % 7)
   throughProto (fromIntegral (maxBound @Int32) % fromIntegral (maxBound @Word32))
-    === fromIntegral (maxBound @Int32) % fromIntegral (maxBound @Word32)
+    === Just (fromIntegral (maxBound @Int32) % fromIntegral (maxBound @Word32))
 
   H.note_ "The approximation of 1 % 2^33 carries a valid, non-zero denominator"
   let smallRational = 1 % 2 ^ (33 :: Int) :: Rational
       smallMsg = inject smallRational :: Proto U5c.RationalNumber
   H.assertWith (smallMsg ^. U5c.denominator) (/= 0)
+  smallValue <- H.nothingFail $ utxoRpcRationalNumberToRational smallMsg
   H.note_ "The approximation stays within 1 % 2^33 of the original value"
-  H.assertWith (abs (inject smallMsg - smallRational)) (<= 1 % 2 ^ (33 :: Int))
+  H.assertWith (abs (smallValue - smallRational)) (<= 1 % 2 ^ (33 :: Int))
   H.note_ "0 is the best approximation: it is closer to 1 % 2^33 than 1 % maxBound @Word32 is"
-  inject smallMsg === (0 :: Rational)
+  smallValue === (0 :: Rational)
 
   H.note_ "1 % 2^32 approximates to the largest representable denominator"
-  throughProto (1 % 2 ^ (32 :: Int)) === 1 % (2 ^ (32 :: Int) - 1)
+  throughProto (1 % 2 ^ (32 :: Int)) === Just (1 % (2 ^ (32 :: Int) - 1))
 
   H.note_ "Values beyond the numerator bounds are clamped to them"
-  throughProto (2 ^ (40 :: Int) % 3) === fromIntegral (maxBound @Int32) % 1
-  throughProto (-((2 ^ (40 :: Int)) % 3)) === (-(fromIntegral $ maxBound @Int32)) % 1
+  throughProto (2 ^ (40 :: Int) % 3) === Just (fromIntegral (maxBound @Int32) % 1)
+  throughProto (-((2 ^ (40 :: Int)) % 3)) === Just ((-(fromIntegral $ maxBound @Int32)) % 1)
 
   H.note_ "Unit-interval-scale values keep sub-2^-32 precision"
   let unitScale = 1234567890123456789 % 9876543210987654321 :: Rational
       unitScaleMsg = inject unitScale :: Proto U5c.RationalNumber
   H.assertWith (unitScaleMsg ^. U5c.denominator) (/= 0)
-  H.assertWith (abs (inject unitScaleMsg - unitScale)) (<= 1 % 2 ^ (32 :: Int))
+  unitScaleValue <- H.nothingFail $ utxoRpcRationalNumberToRational unitScaleMsg
+  H.assertWith (abs (unitScaleValue - unitScale)) (<= 1 % 2 ^ (32 :: Int))
  where
-  throughProto :: Rational -> Rational
-  throughProto r = inject (inject r :: Proto U5c.RationalNumber)
+  throughProto :: Rational -> Maybe Rational
+  throughProto r = utxoRpcRationalNumberToRational (inject r :: Proto U5c.RationalNumber)
 
 -- | For arbitrary rationals in the unit interval with components up to
 -- 'Word64' scale (like ledger @UnitInterval@ values), the proto approximation
@@ -95,7 +97,8 @@ hprop_rational_approximation_error_bound = H.property $ do
   let r = num % den :: Rational
       msg = inject r :: Proto U5c.RationalNumber
   H.assertWith (msg ^. U5c.denominator) (/= 0)
-  H.assertWith (abs (inject msg - r)) (<= 1 % 2 ^ (32 :: Int))
+  converted <- H.nothingFail $ utxoRpcRationalNumberToRational msg
+  H.assertWith (abs (converted - r)) (<= 1 % 2 ^ (32 :: Int))
 
 -- | Test that ChainPoint protobuf message roundtrips, including the timestamp field.
 -- Note: @At (BlockNo 0)@ is excluded because it encodes identically to @Origin@.