Preserve the CBOR representation of scripts

bench/tx-generator/src/Cardano/Benchmarking/Compiler.hs

@@ -38,7 +38,7 @@ type DstWallet = WalletName
 compileOptions :: NixServiceOptions -> Either CompileError [Action]
 compileOptions opts = runCompiler opts compileToScript
 
-runCompiler ::NixServiceOptions -> Compiler () -> Either CompileError [Action]
+runCompiler :: NixServiceOptions -> Compiler () -> Either CompileError [Action]
 runCompiler o c = case runExcept $ runRWST c o 0 of
   Left err -> Left err
   Right ((), _ , l) -> Right $ DL.toList l
@@ -139,8 +139,8 @@ splittingPhase srcWallet = do
         executionUnits <- ExecutionUnits <$> askNixOption _nix_executionMemory <*> askNixOption _nix_executionSteps
         debugMode <- askNixOption _nix_debugMode
         budget <- (if debugMode then CheckScriptBudget else StaticScriptBudget)
-                    <$> (ScriptDataNumber <$> askNixOption _nix_plutusData)
-                    <*> (ScriptDataNumber <$> askNixOption _nix_plutusRedeemer)
+                    <$> (unsafeScriptDataToHashable . ScriptDataNumber <$> askNixOption _nix_plutusData)
+                    <*> (unsafeScriptDataToHashable . ScriptDataNumber <$> askNixOption _nix_plutusRedeemer)
                     <*> pure executionUnits
         ScriptSpec <$> askNixOption _nix_plutusScript <*> pure budget
     return $ PayToScript scriptSpec dst

bench/tx-generator/src/Cardano/Benchmarking/PlutusExample.hs

@@ -39,8 +39,8 @@ toScriptHash str =
 preExecuteScript ::
      ProtocolParameters
   -> Script PlutusScriptV1
-  -> ScriptData
-  -> ScriptData
+  -> HashableScriptData
+  -> HashableScriptData
   -> Either String ExecutionUnits
 preExecuteScript protocolParameters (PlutusScript _ (PlutusScriptSerialised script)) datum redeemer = do
   costModel <- case Map.lookup (AnyPlutusScriptVersion PlutusScriptV1) (protocolParamCostModels protocolParameters) of

bench/tx-generator/src/Cardano/Benchmarking/Script/Aeson.hs

@@ -19,8 +19,8 @@ import           Data.Aeson.Encode.Pretty
 import qualified Data.Attoparsec.ByteString as Atto
 
 import qualified Ouroboros.Network.Magic as Ouroboros (NetworkMagic(..))
-import           Cardano.Api (ScriptData, ScriptDataJsonSchema(..), NetworkId(..)
-                              , scriptDataFromJson, scriptDataToJson)
+import           Cardano.Api (ScriptData, ScriptDataJsonSchema(..), NetworkId(..), SerialiseAsCBOR
+                              , scriptDataFromJson, scriptDataToJson, WithCBOR, withoutCBOR, withCBORViaRoundtrip)
 import           Cardano.Api.Shelley (ProtocolParameters)
 import           Cardano.CLI.Types (SigningKeyFile(..))
 
@@ -54,11 +54,16 @@ instance FromJSON ProtocolParametersSource where
   parseJSON = genericParseJSON jsonOptionsUnTaggedSum
 
 -- Orphan instance used in the tx-generator
+instance ToJSON a => ToJSON (WithCBOR a) where
+  toJSON = toJSON . withoutCBOR
+instance (SerialiseAsCBOR a, FromJSON a) => FromJSON (WithCBOR a) where
+  parseJSON = fmap withCBORViaRoundtrip . parseJSON
+
 instance ToJSON ScriptData where
   toJSON = scriptDataToJson ScriptDataJsonNoSchema
 instance FromJSON ScriptData where
   parseJSON v = case scriptDataFromJson ScriptDataJsonNoSchema v of
-    Right r -> return r
+    Right r -> return $ withoutCBOR r
     Left err -> fail $ show err
 
 instance ToJSON Generator where

bench/tx-generator/src/Cardano/Benchmarking/Script/Core.hs

@@ -392,7 +392,7 @@ spendAutoScript relies on a particular calling convention of the loop script.
 spendAutoScript ::
      ProtocolParameters
   -> Script PlutusScriptV1
-  -> ActionM (ScriptData, ScriptRedeemer)
+  -> ActionM (HashableScriptData, ScriptRedeemer)
 spendAutoScript protocolParameters script = do
   perTxBudget <- case protocolParamMaxTxExUnits protocolParameters of
     Nothing -> throwE $ ApiError "Cannot determine protocolParamMaxTxExUnits"
@@ -407,18 +407,18 @@ spendAutoScript protocolParameters script = do
 
   let
     isInLimits :: Integer -> Either String Bool
-    isInLimits n = case preExecuteScript protocolParameters script (ScriptDataNumber 0) (toLoopArgument n) of
+    isInLimits n = case preExecuteScript protocolParameters script (unsafeScriptDataToHashable $ ScriptDataNumber 0) (toLoopArgument n) of
       Left err -> Left err
       Right use -> Right $ (executionSteps use <= executionSteps budget) && (executionMemory use <= executionMemory budget)
     searchUpperBound = 100000 -- The highest loop count that is tried. (This is about 50 times the current mainnet limit.)
   redeemer <- case startSearch isInLimits 0 searchUpperBound of
     Left err -> throwE $ ApiError $ "cannot find fitting redeemer :" ++ err
     Right n -> return $ toLoopArgument n
-  return (ScriptDataNumber 0, redeemer)
+  return (unsafeScriptDataToHashable (ScriptDataNumber 0), redeemer)
   where
     -- This is the hardcoded calling convention of the loop.plutus script.
     -- To loop n times one has to pass n + 1_000_000 as redeemer.
-    toLoopArgument n = ScriptDataNumber $ n + 1000000
+    toLoopArgument n = unsafeScriptDataToHashable $ ScriptDataNumber $ n + 1000000
     startSearch f a b = do
       l <- f a
       h <- f b
@@ -433,7 +433,7 @@ spendAutoScript protocolParameters script = do
 
 makePlutusContext :: forall era. IsShelleyBasedEra era
   => ScriptSpec
-  -> ActionM (Witness WitCtxTxIn era, Script PlutusScriptV1, ScriptData, Lovelace)
+  -> ActionM (Witness WitCtxTxIn era, Script PlutusScriptV1, HashableScriptData, Lovelace)
 makePlutusContext scriptSpec = do
   protocolParameters <- getProtocolParameters
   script <- liftIO $ PlutusExample.readScript $ scriptSpecFile scriptSpec
@@ -498,8 +498,8 @@ makePlutusContext scriptSpec = do
 preExecuteScriptAction ::
      ProtocolParameters
   -> Script PlutusScriptV1
-  -> ScriptData
-  -> ScriptData
+  -> HashableScriptData
+  -> HashableScriptData
   -> ActionM ExecutionUnits
 preExecuteScriptAction protocolParameters script scriptData redeemer
   = case preExecuteScript protocolParameters script scriptData redeemer of

bench/tx-generator/src/Cardano/Benchmarking/Script/Types.hs

@@ -17,8 +17,8 @@ import           Prelude
 import           Data.List.NonEmpty
 import           Data.Text (Text)
 
-import           Cardano.Api (AnyCardanoEra, ExecutionUnits, Lovelace, ScriptData, ScriptRedeemer,
-                   TextEnvelope, TxIn)
+import           Cardano.Api (AnyCardanoEra, ExecutionUnits, HashableScriptData, Lovelace,
+                   ScriptRedeemer, TextEnvelope, TxIn)
 import           Cardano.Benchmarking.OuroborosImports (SigningKeyFile)
 import           Cardano.Node.Configuration.NodeAddress (NodeIPv4Address)
 
@@ -85,8 +85,8 @@ data PayMode where
 deriving instance Generic PayMode
 
 data ScriptBudget where
-  StaticScriptBudget :: !ScriptData -> !ScriptRedeemer -> !ExecutionUnits -> ScriptBudget
-  CheckScriptBudget  :: !ScriptData -> !ScriptRedeemer -> !ExecutionUnits -> ScriptBudget
+  StaticScriptBudget :: !HashableScriptData -> !ScriptRedeemer -> !ExecutionUnits -> ScriptBudget
+  CheckScriptBudget  :: !HashableScriptData -> !ScriptRedeemer -> !ExecutionUnits -> ScriptBudget
   AutoScript :: ScriptBudget --todo: add fraction of total available budget to use (==2 with 2 inputs !)
   deriving (Show, Eq)
 deriving instance Generic ScriptBudget

bench/tx-generator/src/Cardano/TxGenerator/UTxO.hs

@@ -49,7 +49,7 @@ mkUTxOVariant networkId key value
 mkUTxOScript :: forall era.
      IsShelleyBasedEra era
   => NetworkId
-  -> (Script PlutusScriptV1, ScriptData)
+  -> (Script PlutusScriptV1, HashableScriptData)
   -> Witness WitCtxTxIn era
   -> ToUTxO era
 mkUTxOScript networkId (script, txOutDatum) witness value

cardano-api/cardano-api.cabal

@@ -53,6 +53,7 @@ library
                         -- Splitting up the big Typed module:
                         Cardano.Api.Address
                         Cardano.Api.Block
+                        Cardano.Api.CBOR
                         Cardano.Api.Certificate
                         Cardano.Api.Convenience.Constraints
                         Cardano.Api.Convenience.Construction

cardano-api/gen/Gen/Cardano/Api/Typed.hs

@@ -174,20 +174,22 @@ genPlutusScript _ =
     -- We make no attempt to create a valid script
     PlutusScriptSerialised . SBS.toShort <$> Gen.bytes (Range.linear 0 32)
 
-genScriptData :: Gen ScriptData
-genScriptData =
-    Gen.recursive
-      Gen.choice
-        [ ScriptDataNumber <$> genInteger
-        , ScriptDataBytes  <$> genByteString
-        ]
-        -- The Gen.recursive combinator calls these with the size halved
-        [ ScriptDataConstructor <$> genInteger
-                                <*> genScriptDataList
-        , ScriptDataList <$> genScriptDataList
-        , ScriptDataMap  <$> genScriptDataMap
-        ]
+genScriptData :: Gen HashableScriptData
+genScriptData = unsafeScriptDataToHashable <$> genScriptData'
   where
+    genScriptData' :: Gen ScriptData
+    genScriptData' =
+      Gen.recursive
+        Gen.choice
+          [ ScriptDataNumber <$> genInteger
+          , ScriptDataBytes  <$> genByteString
+          ]
+          -- The Gen.recursive combinator calls these with the size halved
+          [ ScriptDataConstructor <$> genInteger
+                                  <*> genScriptDataList
+          , ScriptDataList <$> genScriptDataList
+          , ScriptDataMap  <$> genScriptDataMap
+          ]
     genInteger :: Gen Integer
     genInteger = Gen.integral
                   (Range.linear
@@ -202,13 +204,13 @@ genScriptData =
     genScriptDataList :: Gen [ScriptData]
     genScriptDataList =
       Gen.sized $ \sz ->
-        Gen.list (Range.linear 0 (fromIntegral sz)) genScriptData
+        Gen.list (Range.linear 0 (fromIntegral sz)) genScriptData'
 
     genScriptDataMap  :: Gen [(ScriptData, ScriptData)]
     genScriptDataMap =
       Gen.sized $ \sz ->
         Gen.list (Range.linear 0 (fromIntegral sz)) $
-          (,) <$> genScriptData <*> genScriptData
+          (,) <$> genScriptData' <*> genScriptData'
 
 
 -- ----------------------------------------------------------------------------

cardano-api/src/Cardano/Api.hs

@@ -395,6 +395,11 @@ module Cardano.Api (
 
     -- ** Script data
     ScriptData(..),
+    IsScriptData,
+    toScriptData,
+    HashableScriptData,
+    asHashableScriptData,
+    unsafeScriptDataToHashable,
     hashScriptData,
 
     -- ** Validation
@@ -428,6 +433,11 @@ module Cardano.Api (
     FromCBOR,
     serialiseToCBOR,
     deserialiseFromCBOR,
+    WithCBOR,
+    getCBOR,
+    getCBORShort,
+    withoutCBOR,
+    withCBORViaRoundtrip,
 
     -- ** JSON
     ToJSON,
@@ -706,6 +716,7 @@ module Cardano.Api (
 
 import           Cardano.Api.Address
 import           Cardano.Api.Block
+import           Cardano.Api.CBOR
 import           Cardano.Api.Certificate
 import           Cardano.Api.Convenience.Constraints
 import           Cardano.Api.Convenience.Construction

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

@@ -0,0 +1,72 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+
+-- | Helpers for retaining user supplied CBOR
+module Cardano.Api.CBOR
+  ( AsType(..)
+  , WithCBOR
+  , getCBOR
+  , getCBORShort
+  , withoutCBOR
+  , withCBORViaRoundtrip
+  ) where
+
+import           Prelude
+
+import           Data.ByteString (ByteString)
+import           Data.ByteString.Short (ShortByteString, toShort)
+
+import           Cardano.Ledger.Crypto (StandardCrypto)
+import           Cardano.Ledger.SafeHash (HashAnnotated, SafeToHash, originalBytes)
+
+import           Cardano.Api.HasTypeProxy
+import           Cardano.Api.SerialiseCBOR
+
+-- | A value, paired with its representation. To generate something of
+-- type 'WithCBOR', either call 'deserialiseFromCBOR' if you already have
+-- CBOR, or call 'withCBORViaRoundtrip' if you need to pair a value with the
+-- CBOR from serialising it.
+data WithCBOR a = WithCBOR !ByteString !a
+    deriving (Eq, Show)
+
+instance Ord a => Ord (WithCBOR a) where
+    compare (WithCBOR bx x) (WithCBOR by y) = case compare x y of
+      EQ -> compare bx by -- We need to match the derived Eq
+      res -> res
+
+-- | Extract the CBOR from a 'WithCBOR'
+getCBOR :: WithCBOR a -> ByteString
+getCBOR (WithCBOR bs _ ) = bs
+
+-- | Extract the CBOR as a short bytestring
+getCBORShort :: WithCBOR a -> ShortByteString
+getCBORShort = toShort . getCBOR
+
+-- | Extract the value from a 'WithCBOR'
+withoutCBOR :: WithCBOR a -> a
+withoutCBOR (WithCBOR _ x) = x
+
+instance HasTypeProxy a => HasTypeProxy (WithCBOR a) where
+    data AsType (WithCBOR a) = AsWithCBOR (AsType a)
+    proxyToAsType _ = AsWithCBOR (proxyToAsType (Proxy @a))
+
+instance SerialiseAsCBOR a => SerialiseAsCBOR (WithCBOR a) where
+    serialiseToCBOR (WithCBOR bs _) = bs
+    deserialiseFromCBOR (AsWithCBOR p) bs = WithCBOR bs <$> deserialiseFromCBOR p bs
+
+instance SafeToHash (WithCBOR a) where
+    originalBytes = getCBOR
+
+instance HashAnnotated (WithCBOR a) a StandardCrypto
+
+-- | Create a value of type 'WithCBOR' by first serialising it and then deserialising it.
+-- Note that the value stored here may not be the original value of serialisation doesn't
+-- roundtrip, and this will throw an error if we can't deserialise from the generated
+-- CBOR.
+withCBORViaRoundtrip :: forall a . SerialiseAsCBOR a => a -> WithCBOR a
+withCBORViaRoundtrip x = case deserialiseFromCBOR (AsWithCBOR (proxyToAsType $ Proxy @a)) (serialiseToCBOR x) of
+    Left err -> error $ "withCBORViaRoundtrip: Does not round trip " <> show err
+    Right x' -> x'

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

@@ -154,6 +154,7 @@ import qualified Cardano.Ledger.Alonzo.Scripts as Alonzo
 
 import qualified Plutus.V1.Ledger.Examples as Plutus
 
+import           Cardano.Api.CBOR
 import           Cardano.Api.EraCast
 import           Cardano.Api.Eras
 import           Cardano.Api.Error
@@ -793,13 +794,13 @@ instance Eq (ScriptWitness witctx era) where
 
     (==)  _ _ = False
 
-type ScriptRedeemer = ScriptData
+type ScriptRedeemer = HashableScriptData
 
 data ScriptDatum witctx where
-     ScriptDatumForTxIn    :: ScriptData -> ScriptDatum WitCtxTxIn
-     InlineScriptDatum     ::               ScriptDatum WitCtxTxIn
-     NoScriptDatumForMint  ::               ScriptDatum WitCtxMint
-     NoScriptDatumForStake ::               ScriptDatum WitCtxStake
+     ScriptDatumForTxIn    :: HashableScriptData -> ScriptDatum WitCtxTxIn
+     InlineScriptDatum     :: ScriptDatum WitCtxTxIn
+     NoScriptDatumForMint  :: ScriptDatum WitCtxMint
+     NoScriptDatumForStake :: ScriptDatum WitCtxStake
 
 deriving instance Eq   (ScriptDatum witctx)
 deriving instance Show (ScriptDatum witctx)