cardano-rpc | Add conversion Integer -> proto.BigInt

Author: carbolymer

cardano-api/src/Cardano/Api/HasTypeProxy.hs

@@ -13,10 +13,12 @@ module Cardano.Api.HasTypeProxy
 where
 
 import Data.ByteString qualified as BS
+import Data.ByteString.Lazy qualified as BSL
 import Data.Kind (Constraint, Type)
 import Data.Proxy (Proxy (..))
 import Data.Typeable (Typeable)
 import Data.Word (Word16, Word8)
+import Numeric.Natural (Natural)
 
 class Typeable t => HasTypeProxy t where
   -- | A family of singleton types used in this API to indicate which type to
@@ -35,10 +37,18 @@ instance HasTypeProxy Word16 where
   data AsType Word16 = AsWord16
   proxyToAsType _ = AsWord16
 
+instance HasTypeProxy Natural where
+  data AsType Natural = AsNatural
+  proxyToAsType _ = AsNatural
+
 instance HasTypeProxy BS.ByteString where
   data AsType BS.ByteString = AsByteString
   proxyToAsType _ = AsByteString
 
+instance HasTypeProxy BSL.ByteString where
+  data AsType BSL.ByteString = AsByteStringLazy
+  proxyToAsType _ = AsByteStringLazy
+
 data FromSomeType (c :: Type -> Constraint) b where
   FromSomeType :: c a => AsType a -> (a -> b) -> FromSomeType c b
 

cardano-api/src/Cardano/Api/Serialise/Raw.hs

@@ -26,13 +26,17 @@ import Data.Bits (Bits (..))
 import Data.ByteString qualified as BS
 import Data.ByteString.Base16 qualified as Base16
 import Data.ByteString.Builder qualified as BSB
-import Data.ByteString.Char8 as BSC
+import Data.ByteString.Char8 (ByteString)
+import Data.ByteString.Char8 qualified as BSC
+import Data.ByteString.Lazy qualified as BSL
 import Data.Data (typeRep)
+import Data.Foldable qualified as F
 import Data.Text (Text)
 import Data.Text qualified as Text
 import Data.Text.Encoding qualified as Text
 import Data.Typeable (TypeRep, Typeable)
 import Data.Word (Word16, Word8)
+import Numeric.Natural (Natural)
 
 class (HasTypeProxy a, Typeable a) => SerialiseAsRawBytes a where
   serialiseToRawBytes :: a -> ByteString
@@ -60,10 +64,23 @@ instance SerialiseAsRawBytes Word16 where
       throwError . SerialiseAsRawBytesError $
         "Cannot decode Word16 from (hex): " <> BSC.unpack (Base16.encode bs)
 
+instance SerialiseAsRawBytes Natural where
+  serialiseToRawBytes 0 = BS.singleton 0x00
+  serialiseToRawBytes n = BS.toStrict . BSB.toLazyByteString $ go n mempty
+   where
+    go 0 acc = acc
+    go x acc = go (x `shiftR` 8) (BSB.word8 (fromIntegral (x .&. 0xFF)) <> acc)
+  deserialiseFromRawBytes AsNatural "\x00" = pure 0
+  deserialiseFromRawBytes AsNatural input = pure . F.foldl' (\acc byte -> acc `shiftL` 8 .|. fromIntegral byte) 0 $ BS.unpack input
+
 instance SerialiseAsRawBytes BS.ByteString where
   serialiseToRawBytes = id
   deserialiseFromRawBytes AsByteString = pure
 
+instance SerialiseAsRawBytes BSL.ByteString where
+  serialiseToRawBytes = BSL.toStrict
+  deserialiseFromRawBytes AsByteStringLazy = pure . BSL.fromStrict
+
 serialiseToRawBytesHex :: SerialiseAsRawBytes a => a -> ByteString
 serialiseToRawBytesHex = Base16.encode . serialiseToRawBytes
 

cardano-api/src/Cardano/Api/Serialise/SerialiseUsing.hs

@@ -17,8 +17,10 @@ import Cardano.Api.Serialise.Json
 import Cardano.Api.Serialise.Raw
 
 import Data.Aeson.Types qualified as Aeson
+import Data.ByteString qualified as B
 import Data.Text.Encoding qualified as Text
 import Data.Typeable (tyConName, typeRep, typeRepTyCon)
+import Numeric (showBin)
 
 -- | For use with @deriving via@, to provide 'ToCBOR' and 'FromCBOR' instances,
 -- based on the 'SerialiseAsRawBytes' instance.
@@ -39,6 +41,10 @@ instance SerialiseAsRawBytes a => FromCBOR (UsingRawBytes a) where
     ttoken = proxyToAsType (Proxy :: Proxy a)
     tname = (tyConName . typeRepTyCon . typeRep) (Proxy :: Proxy a)
 
+-- | Prints the representation in binary format, quoted
+instance SerialiseAsRawBytes a => Show (UsingRawBytes a) where
+  showsPrec _ (UsingRawBytes x) = showChar '"' . mconcat (map showBin . B.unpack $ serialiseToRawBytes x) . showChar '"'
+
 -- | For use with @deriving via@, to provide instances for any\/all of 'Show',
 -- 'ToJSON', 'FromJSON', 'ToJSONKey', FromJSONKey' using a hex
 -- encoding, based on the 'SerialiseAsRawBytes' instance.

cardano-rpc/proto/utxorpc/v1alpha/cardano/cardano.proto

@@ -71,7 +71,7 @@ message Constr {
 // Represents a big integer for Plutus data in Cardano.
 message BigInt {
   oneof big_int {
-    int64 int = 1;
+    int64 int = 1 [jstype = JS_STRING];
     bytes big_u_int = 2;
     bytes big_n_int = 3;
   }

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

@@ -9,8 +9,9 @@
 {-# LANGUAGE TypeApplications #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 
-module Cardano.Rpc.Server.Internal.Orphans () where
+module Cardano.Rpc.Server.Internal.Orphans where
 
+import Cardano.Api (SerialiseAsCBOR (serialiseToCBOR), ToCBOR (..))
 import Cardano.Api.Address
 import Cardano.Api.Block (SlotNo (..))
 import Cardano.Api.Era
@@ -19,6 +20,7 @@ import Cardano.Api.Ledger qualified as L
 import Cardano.Api.Plutus
 import Cardano.Api.Pretty
 import Cardano.Api.Serialise.Raw
+import Cardano.Api.Serialise.SerialiseUsing
 import Cardano.Api.Tx
 import Cardano.Api.Value
 import Cardano.Rpc.Proto.Api.UtxoRpc.Query qualified as UtxoRpc
@@ -30,6 +32,7 @@ import Cardano.Ledger.Plutus qualified as L
 
 import RIO hiding (toList)
 
+import Data.ByteString qualified as B
 import Data.Default
 import Data.Map.Strict qualified as M
 import Data.ProtoLens (defMessage)
@@ -113,8 +116,15 @@ instance Inject ScriptData (Proto UtxoRpc.PlutusData) where
   inject = \case
     ScriptDataBytes bs ->
       defMessage & #boundedBytes .~ bs
-    ScriptDataNumber int ->
-      defMessage & #bigInt . #int .~ fromIntegral int
+    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