cardano-rpc: Refactoring in preparation for FetchBlock transaction bodies

.changes/20260709_cardano_rpc_fetchblock_refactor.yml

@@ -0,0 +1,7 @@
+project: cardano-rpc
+pr: 1253
+kind:
+  - bugfix
+  - refactoring
+description: |
+  Approximate out-of-range rationals in RationalNumber conversions instead of wrapping. Preparatory refactoring for FetchBlock transaction bodies: split UtxoRpc.Type into Type.* modules, use Proto-wrapped messages in conversion functions, generalise txOutToUtxoRpcTxOutput over eras, expose request helpers, and return the parsed block from fetchBlock.

.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

@@ -65,6 +65,14 @@ library
     Cardano.Rpc.Server.Internal.UtxoRpc.Submit
     Cardano.Rpc.Server.Internal.UtxoRpc.Sync
     Cardano.Rpc.Server.Internal.UtxoRpc.Type
+    Cardano.Rpc.Server.Internal.UtxoRpc.Type.BigInt
+    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.Server.NodeKernelAccess
     Cardano.Rpc.Server.NodeKernelAccess.Type
 

cardano-rpc/src/Cardano/Rpc/Proto/Api/UtxoRpc/Sync.hs

@@ -5,15 +5,20 @@ module Cardano.Rpc.Proto.Api.UtxoRpc.Sync
   ( module Proto.Utxorpc.V1beta.Sync.Sync
   , module Proto.Utxorpc.V1beta.Sync.Sync_Fields
   , module Proto.Utxorpc.V1beta.Cardano.Cardano
-  , header
+  , module Proto.Utxorpc.V1beta.Cardano.Cardano_Fields
   )
 where
 
 import Network.GRPC.Common
 import Network.GRPC.Common.Protobuf
 
 import Proto.Utxorpc.V1beta.Cardano.Cardano
-import Proto.Utxorpc.V1beta.Cardano.Cardano_Fields (header)
+import Proto.Utxorpc.V1beta.Cardano.Cardano_Fields hiding
+  ( hash
+  , height
+  , slot
+  , timestamp
+  )
 import Proto.Utxorpc.V1beta.Sync.Sync
 import Proto.Utxorpc.V1beta.Sync.Sync_Fields
 

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

@@ -31,15 +31,73 @@ 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
-
--- NB. this clips value in Integer -> Int64/Word64 conversion here
+-- | Convert a 'Rational' into a protobuf 'U5c.RationalNumber'.
+--
+-- The UTxO RPC spec fixes the field widths to an @int32@ numerator and a
+-- @uint32@ denominator, while on-chain rationals (e.g. bounded ratios backed
+-- by 'Word64') can exceed both. When the numerator and the denominator fit
+-- their fields, the conversion is exact. Otherwise the result is the best
+-- representable approximation of the value: magnitudes beyond
+-- @maxBound \@Int32@ are clamped to it, so out-of-range negative values
+-- clamp to @-maxBound \@Int32@ (one above @minBound \@Int32@), and other
+-- values are approximated using continued fractions, keeping both
+-- components within their field bounds.
+-- The conversion is therefore lossy for such out-of-range values, and values
+-- close enough to zero may approximate to zero.
 instance Inject Rational (Proto U5c.RationalNumber) where
   inject r =
     defMessage
-      & U5c.numerator .~ fromIntegral (numerator r)
-      & U5c.denominator .~ fromIntegral (denominator r)
+      & U5c.numerator .~ fromInteger num
+      & U5c.denominator .~ fromInteger den
+   where
+    (num, den)
+      | numerator r >= fromIntegral (minBound @Int32)
+      , numerator r <= maxNum
+      , denominator r <= maxDen =
+          (numerator r, denominator r)
+      | otherwise = do
+          let approximation = bestApproximation $ abs r
+          (signum (numerator r) * numerator approximation, denominator approximation)
+
+    maxNum = fromIntegral (maxBound @Int32) :: Integer
+
+    maxDen = fromIntegral (maxBound @Word32) :: Integer
+
+    -- Best approximation of a non-negative rational keeping the numerator and
+    -- the denominator within 'maxNum' and 'maxDen' respectively: walk the
+    -- continued fraction convergents of the value until a bound is exceeded,
+    -- then pick the closer of the last in-bounds convergent and the largest
+    -- in-bounds semiconvergent.
+    bestApproximation :: Rational -> Rational
+    bestApproximation x
+      | x > fromIntegral maxNum = maxNum % 1
+      | otherwise = go 0 1 1 0 x
+     where
+      -- (hPrev, kPrev) and (hCur, kCur) are the components of the two most
+      -- recent convergents, y is the current complete quotient. The first
+      -- convergent (floor x % 1) is always in bounds because x <= maxNum, so
+      -- the out-of-bounds branch never divides by kCur = 0.
+      go :: Integer -> Integer -> Integer -> Integer -> Rational -> Rational
+      go hPrev kPrev hCur kCur y = do
+        let a = floor y
+            hNew = a * hCur + hPrev
+            kNew = a * kCur + kPrev
+            rest = y - fromIntegral a
+        if hNew > maxNum || kNew > maxDen
+          then do
+            -- the largest coefficient for which the semiconvergent still fits
+            -- both bounds
+            let aFromNum = if hCur > 0 then (maxNum - hPrev) `div` hCur else a
+                aMax = a `min` aFromNum `min` ((maxDen - kPrev) `div` kCur)
+                semiconvergent = (aMax * hCur + hPrev) % (aMax * kCur + kPrev)
+                convergent = hCur % kCur
+            if aMax >= 1 && abs (x - semiconvergent) <= abs (x - convergent)
+              then semiconvergent
+              else convergent
+          else
+            if rest == 0
+              then hNew % kNew
+              else go hCur kCur hNew kNew (recip rest)
 
 instance Inject (Proto U5c.ExUnits) L.ExUnits where
   inject r =

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

@@ -114,8 +114,7 @@ evalTxMethod request = do
                     .~ "Transaction is not balanced. Remaining balance (consumed - produced): "
                       <> tshow balance
               ]
-        finalTxEval =
-          Proto $ getProto txEval & Proto.errors %~ (<> balanceErrors)
+        finalTxEval = txEval & Proto.errors %~ (<> balanceErrors)
 
     pure $ def & U5c.report . U5c.cardano .~ finalTxEval
  where

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

@@ -4,6 +4,7 @@
 
 module Cardano.Rpc.Server.Internal.UtxoRpc.Predicate
   ( matchesUtxoPredicate
+  , exactAddressPredicate
   , extractAddressesFromPredicate
   , matchesAddressPattern
   , matchesAssetPattern
@@ -24,14 +25,16 @@ import Cardano.Rpc.Proto.Api.UtxoRpc.Query qualified as UtxoRpc
 import RIO hiding (toList)
 
 import Data.ByteString qualified as BS
+import Data.ProtoLens (defMessage)
 import Data.Set qualified as Set
 import GHC.IsList
+import Network.GRPC.Spec (Proto)
 
 -- | Check if a UTxO entry matches a 'UtxoPredicate'.
 -- All present fields are combined with AND logic.
 matchesUtxoPredicate
   :: IsCardanoEra era
-  => UtxoRpc.UtxoPredicate
+  => Proto UtxoRpc.UtxoPredicate
   -> TxOut CtxUTxO era
   -> Bool
 matchesUtxoPredicate p txOut =
@@ -44,7 +47,7 @@ matchesUtxoPredicate p txOut =
 -- Delegates to the Cardano-specific 'TxOutputPattern' if present.
 matchesAnyUtxoPattern
   :: IsCardanoEra era
-  => UtxoRpc.AnyUtxoPattern
+  => Proto UtxoRpc.AnyUtxoPattern
   -> TxOut CtxUTxO era
   -> Bool
 matchesAnyUtxoPattern pat txOut =
@@ -54,7 +57,7 @@ matchesAnyUtxoPattern pat txOut =
 -- Address and asset filters are combined with AND; absent fields are vacuously true.
 matchesTxOutputPattern
   :: IsCardanoEra era
-  => UtxoRpc.TxOutputPattern
+  => Proto UtxoRpc.TxOutputPattern
   -> TxOut CtxUTxO era
   -> Bool
 matchesTxOutputPattern pat (TxOut addrInEra txOutValue _datum _script) =
@@ -66,7 +69,7 @@ matchesTxOutputPattern pat (TxOut addrInEra txOutValue _datum _script) =
 -- Byron addresses only support exact matching; payment\/delegation filters reject them.
 matchesAddressPattern
   :: IsCardanoEra era
-  => UtxoRpc.AddressPattern
+  => Proto UtxoRpc.AddressPattern
   -> AddressInEra era
   -> Bool
 matchesAddressPattern pat addr =
@@ -89,6 +92,19 @@ matchesAddressPattern pat addr =
         _ -> BS.null $ pat ^. UtxoRpc.delegationPart
     _ -> BS.null $ pat ^. UtxoRpc.delegationPart
 
+-- | A 'UtxoPredicate' matching UTxOs at the exact address.
+exactAddressPredicate
+  :: IsCardanoEra era
+  => AddressInEra era
+  -> Proto UtxoRpc.UtxoPredicate
+exactAddressPredicate address =
+  defMessage
+    & UtxoRpc.match
+      .~ ( defMessage
+             & UtxoRpc.cardano
+               .~ (defMessage & UtxoRpc.address .~ (defMessage & UtxoRpc.exactAddress .~ serialiseToRawBytes address))
+         )
+
 -- | Serialise a 'PaymentCredential' to raw bytes (the key or script hash).
 serialisePaymentCredential :: PaymentCredential -> ByteString
 serialisePaymentCredential (PaymentCredentialByKey h) = serialiseToRawBytes h
@@ -102,7 +118,7 @@ serialiseStakeCredential (StakeCredentialByScript h) = serialiseToRawBytes h
 -- | Check if a 'Value' contains a native asset matching an 'AssetPattern'.
 -- Ada entries are always skipped; zero-quantity entries do not match.
 matchesAssetPattern
-  :: UtxoRpc.AssetPattern
+  :: Proto UtxoRpc.AssetPattern
   -> Value
   -> Bool
 matchesAssetPattern pat value =
@@ -118,15 +134,15 @@ matchesAssetPattern pat value =
 
 -- | Try to extract a set of exact addresses from the predicate for use with 'QueryUTxOByAddress'.
 -- Returns 'Just' if the optimization is applicable, 'Nothing' otherwise.
-extractAddressesFromPredicate :: UtxoRpc.UtxoPredicate -> Maybe (Set AddressAny)
+extractAddressesFromPredicate :: Proto UtxoRpc.UtxoPredicate -> Maybe (Set AddressAny)
 extractAddressesFromPredicate p =
   case (p ^. UtxoRpc.maybe'match, p ^. UtxoRpc.not, p ^. UtxoRpc.allOf, p ^. UtxoRpc.anyOf) of
     (Just pat, [], [], []) -> extractAddressFromPattern pat
     (Nothing, [], [], anyPreds@(_ : _)) ->
       Set.unions <$> traverse extractAddressesFromPredicate anyPreds
     _ -> Nothing
  where
-  extractAddressFromPattern :: UtxoRpc.AnyUtxoPattern -> Maybe (Set AddressAny)
+  extractAddressFromPattern :: Proto UtxoRpc.AnyUtxoPattern -> Maybe (Set AddressAny)
   extractAddressFromPattern pat = do
     txoPat <- pat ^. UtxoRpc.maybe'cardano
     addrPat <- txoPat ^. UtxoRpc.maybe'address

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

@@ -120,7 +120,7 @@ searchUtxosMethod
   -> m (Proto UtxoRpc.SearchUtxosResponse)
 searchUtxosMethod req = do
   -- TODO: field masks are ignored for now (same as readParamsMethod)
-  let mPredicate = fmap getProto $ req ^. U5c.maybe'predicate
+  let mPredicate = req ^. U5c.maybe'predicate
       maxItems = req ^. U5c.maxItems
       startToken = req ^. U5c.maybe'startToken
 

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

@@ -54,13 +54,14 @@ fetchBlockMethod request = do
   headerHash <-
     deserialiseFromRawBytes (proxyToAsType (Proxy @(Hash BlockHeader))) hashBytes
       & either (const throwInvalidHash) pure
-  (rawBytes, BlockNo height) <-
+  (rawBytes, BlockInMode _ block) <-
     fetchBlock nodeKernelAccess slot headerHash >>= maybe throwNotFound pure
   eraHistory <- readEraHistory
   timestampMs <-
     slotToUTCTime systemStart eraHistory slot
       & either (const throwPastHorizon) (pure . round . (* 1000) . utcTimeToPOSIXSeconds)
-  let blockHeader =
+  let BlockHeader _ _ (BlockNo height) = getBlockHeader block
+      blockHeader =
         defMessage
           & U5c.slot .~ unSlotNo slot
           & U5c.hash .~ hashBytes