Implement memory efficient and type safe BinaryData for inline datums

eras/alonzo/impl/src/Cardano/Ledger/Alonzo.hs

@@ -98,14 +98,8 @@ import qualified Data.Set as Set
 -- | The Alonzo era
 data AlonzoEra c
 
-instance
-  ( CC.Crypto c,
-    era ~ AlonzoEra c
-  ) =>
-  EraModule.Era (AlonzoEra c)
-  where
+instance CC.Crypto c => EraModule.Era (AlonzoEra c) where
   type Crypto (AlonzoEra c) = c
-
   getTxOutEitherAddr = getAlonzoTxOutEitherAddr
 
 instance API.ShelleyEraCrypto c => API.ApplyTx (AlonzoEra c) where

eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Data.hs

@@ -18,18 +18,34 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Cardano.Ledger.Alonzo.Data
-  ( Data (Data, ..),
+  ( Data (Data),
     DataHash,
     hashData,
     getPlutusData,
     dataHashSize,
+    BinaryData,
+    hashBinaryData,
+    makeBinaryData,
+    binaryDataToData,
+    dataToBinaryData,
+    decodeBinaryData,
     -- $
     AuxiliaryData (AuxiliaryData, AuxiliaryData', scripts, txMD),
     AuxiliaryDataHash (..),
   )
 where
 
-import Cardano.Binary (FromCBOR (..), ToCBOR (..), TokenType (..), peekTokenType, withSlice)
+import Cardano.Binary
+  ( DecoderError (..),
+    FromCBOR (..),
+    ToCBOR (..),
+    TokenType (..),
+    decodeAnnotator,
+    decodeTag,
+    encodeTag,
+    peekTokenType,
+    withSlice,
+  )
 import Cardano.Ledger.Alonzo.Language (Language (..))
 import Cardano.Ledger.Alonzo.Scripts (Script (..))
 import Cardano.Ledger.AuxiliaryData (AuxiliaryDataHash (..))
@@ -51,8 +67,8 @@ import Cardano.Ledger.Serialization (mapFromCBOR)
 import Cardano.Ledger.Shelley.Metadata (Metadatum)
 import Cardano.Prelude (HeapWords (..), heapWords0, heapWords1)
 import qualified Codec.Serialise as Cborg (Serialise (..))
-import Data.ByteString.Lazy (toStrict)
-import Data.ByteString.Short (toShort)
+import Data.ByteString.Lazy (fromStrict, toStrict)
+import Data.ByteString.Short (ShortByteString, fromShort, toShort)
 import Data.Coders
 import Data.Foldable (foldl')
 import Data.Map (Map)
@@ -109,6 +125,53 @@ pattern Data p <-
 getPlutusData :: Data era -> Plutus.Data
 getPlutusData (DataConstr (Memo d _)) = d
 
+-- | Inlined data must be stored in the most compact form because it contributes
+-- to the memory overhead of the ledger state. Constructor is intentionally not
+-- exported, in order to prevent invalid creation of data from arbitrary binary
+-- data. Use `makeBinaryData` for smart construction.
+newtype BinaryData era = BinaryData ShortByteString
+  deriving newtype (Eq, Ord, Show, SafeToHash)
+
+instance (Crypto era ~ c) => HashAnnotated (BinaryData era) EraIndependentData c
+
+instance Typeable era => ToCBOR (BinaryData era) where
+  toCBOR (BinaryData sbs) = encodeTag 42 <> toCBOR sbs
+
+instance Typeable era => FromCBOR (BinaryData era) where
+  fromCBOR = do
+    42 <- decodeTag
+    sbs <- fromCBOR
+    either fail pure $! makeBinaryData sbs
+
+makeBinaryData :: ShortByteString -> Either String (BinaryData era)
+makeBinaryData sbs = do
+  let binaryData = BinaryData sbs
+  -- We need to verify that binary data is indeed valid Plutus Data.
+  case decodeBinaryData binaryData of
+    Left e -> Left $ "Invalid CBOR for Data: " <> show e
+    Right _d -> Right binaryData
+
+decodeBinaryData :: BinaryData era -> Either DecoderError (Data era)
+decodeBinaryData (BinaryData sbs) = do
+  plutusData <- decodeAnnotator "Data" fromCBOR (fromStrict (fromShort sbs))
+  pure (DataConstr (Memo plutusData sbs))
+
+-- | It is safe to convert `BinaryData` to `Data` because the only way to
+-- construct `BinaryData` is thorugh smart constructor `makeBinaryData` that
+-- takes care of verification.
+binaryDataToData :: BinaryData era -> Data era
+binaryDataToData binaryData =
+  case decodeBinaryData binaryData of
+    Left errMsg ->
+      error $ "Impossible: incorrectly encoded data: " ++ show errMsg
+    Right d -> d
+
+dataToBinaryData :: Data era -> BinaryData era
+dataToBinaryData (DataConstr (Memo _ sbs)) = BinaryData sbs
+
+hashBinaryData :: Era era => BinaryData era -> DataHash (Crypto era)
+hashBinaryData = hashAnnotated
+
 -- =============================================================================
 
 type DataHash crypto = SafeHash crypto EraIndependentData
@@ -138,7 +201,10 @@ deriving instance Eq (Core.Script era) => Eq (AuxiliaryDataRaw era)
 
 deriving instance Show (Core.Script era) => Show (AuxiliaryDataRaw era)
 
-deriving via InspectHeapNamed "AuxiliaryDataRaw" (AuxiliaryDataRaw era) instance NoThunks (AuxiliaryDataRaw era)
+deriving via
+  InspectHeapNamed "AuxiliaryDataRaw" (AuxiliaryDataRaw era)
+  instance
+    NoThunks (AuxiliaryDataRaw era)
 
 instance
   ( Typeable era,

eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxBody.hs

@@ -154,7 +154,7 @@ data DataHash32
       {-# UNPACK #-} !Word64 -- DataHash
       {-# UNPACK #-} !Word64 -- DataHash
       {-# UNPACK #-} !Word64 -- DataHash
-  deriving Eq
+  deriving (Eq)
 
 data TxOut era
   = TxOutCompact'
@@ -215,8 +215,7 @@ decodeAddress28 stakeRef (Addr28Extra a b c d) = do
 
 encodeAddress28 ::
   forall crypto.
-  ( HashAlgorithm (CC.ADDRHASH crypto)
-  ) =>
+  HashAlgorithm (CC.ADDRHASH crypto) =>
   Network ->
   PaymentCredential crypto ->
   Maybe (SizeHash (CC.ADDRHASH crypto) :~: 28, Addr28Extra)
@@ -246,11 +245,12 @@ encodeAddress28 network paymentCred = do
 
 decodeDataHash32 ::
   forall crypto.
-  (SizeHash (CC.HASH crypto) ~ 32) =>
+  HashAlgorithm (CC.HASH crypto) =>
   DataHash32 ->
-  DataHash crypto
-decodeDataHash32 (DataHash32 a b c d) =
-  unsafeMakeSafeHash $ hashFromPackedBytes $ PackedBytes32 a b c d
+  Maybe (DataHash crypto)
+decodeDataHash32 (DataHash32 a b c d) = do
+  Refl <- sameNat (Proxy @(SizeHash (CC.HASH crypto))) (Proxy @32)
+  Just $! unsafeMakeSafeHash $ hashFromPackedBytes $ PackedBytes32 a b c d
 
 encodeDataHash32 ::
   forall crypto.
@@ -274,13 +274,12 @@ viewCompactTxOut txOut = case txOut of
   TxOut_AddrHash28_AdaOnly stakeRef addr28Extra adaVal
     | Just addr <- decodeAddress28 stakeRef addr28Extra ->
       (compactAddr addr, toCompactValue adaVal, SNothing)
-    | otherwise -> error "Impossible: Compacted an address of non-standard size"
+    | otherwise -> error addressErrorMsg
   TxOut_AddrHash28_AdaOnly_DataHash32 stakeRef addr28Extra adaVal dataHash32
     | Just addr <- decodeAddress28 stakeRef addr28Extra,
-      Just Refl <- sameNat (Proxy @(SizeHash (CC.HASH (Crypto era)))) (Proxy @32) ->
-      (compactAddr addr, toCompactValue adaVal, SJust (decodeDataHash32 dataHash32))
-    | otherwise ->
-      error "Impossible: Compacted an address or a hash of non-standard size"
+      Just dh <- decodeDataHash32 dataHash32 ->
+      (compactAddr addr, toCompactValue adaVal, SJust dh)
+    | otherwise -> error addressErrorMsg
   where
     toCompactValue :: CompactForm Coin -> CompactForm (Core.Value era)
     toCompactValue ada =
@@ -307,12 +306,10 @@ viewTxOut (TxOut_AddrHash28_AdaOnly stakeRef addr28Extra adaVal)
     (addr, inject (fromCompact adaVal), SNothing)
 viewTxOut (TxOut_AddrHash28_AdaOnly_DataHash32 stakeRef addr28Extra adaVal dataHash32)
   | Just addr <- decodeAddress28 stakeRef addr28Extra,
-    Just Refl <- sameNat (Proxy @(SizeHash (CC.HASH (Crypto era)))) (Proxy @32) =
-    (addr, inject (fromCompact adaVal), SJust (decodeDataHash32 dataHash32))
-viewTxOut TxOut_AddrHash28_AdaOnly {} =
-  error "Impossible: Compacted address or hash of non-standard size"
-viewTxOut TxOut_AddrHash28_AdaOnly_DataHash32 {} =
-  error "Impossible: Compacted address or hash of non-standard size"
+    Just dh <- decodeDataHash32 dataHash32 =
+    (addr, inject (fromCompact adaVal), SJust dh)
+viewTxOut TxOut_AddrHash28_AdaOnly {} = error addressErrorMsg
+viewTxOut TxOut_AddrHash28_AdaOnly_DataHash32 {} = error addressErrorMsg
 
 instance
   ( Era era,
@@ -895,6 +892,11 @@ getAlonzoTxOutEitherAddr = \case
   TxOutCompactDH' cAddr _ _ -> Right cAddr
   TxOut_AddrHash28_AdaOnly stakeRef addr28Extra _
     | Just addr <- decodeAddress28 stakeRef addr28Extra -> Left addr
+    | otherwise -> error addressErrorMsg
   TxOut_AddrHash28_AdaOnly_DataHash32 stakeRef addr28Extra _ _
     | Just addr <- decodeAddress28 stakeRef addr28Extra -> Left addr
-  _ -> error "Impossible: Compacted an address of non-standard size"
+  _ -> error addressErrorMsg
+
+addressErrorMsg :: String
+addressErrorMsg = "Impossible: Compacted an address of non-standard size"
+{-# NOINLINE addressErrorMsg #-}

eras/alonzo/test-suite/src/Test/Cardano/Ledger/Alonzo/Serialisation/Generators.hs

@@ -14,7 +14,7 @@
 module Test.Cardano.Ledger.Alonzo.Serialisation.Generators where
 
 import Cardano.Ledger.Alonzo (AlonzoEra)
-import Cardano.Ledger.Alonzo.Data (AuxiliaryData (..), Data (..))
+import Cardano.Ledger.Alonzo.Data (AuxiliaryData (..), BinaryData, Data (..), dataToBinaryData)
 import Cardano.Ledger.Alonzo.Language
 import Cardano.Ledger.Alonzo.PParams
 import Cardano.Ledger.Alonzo.Rules.Utxo (UtxoPredicateFailure (..))
@@ -55,6 +55,9 @@ import Test.QuickCheck
 instance Arbitrary (Data era) where
   arbitrary = Data <$> arbitrary
 
+instance Arbitrary (BinaryData era) where
+  arbitrary = dataToBinaryData <$> arbitrary
+
 genPair :: Gen a -> Gen b -> Gen (a, b)
 genPair x y = do a <- x; b <- y; pure (a, b)
 

eras/alonzo/test-suite/test/Test/Cardano/Ledger/Alonzo/Serialisation/Tripping.hs

@@ -7,7 +7,7 @@ module Test.Cardano.Ledger.Alonzo.Serialisation.Tripping where
 
 import Cardano.Binary
 import Cardano.Ledger.Alonzo (AlonzoEra)
-import Cardano.Ledger.Alonzo.Data (AuxiliaryData, Data (..))
+import Cardano.Ledger.Alonzo.Data (AuxiliaryData, BinaryData, Data (..))
 import Cardano.Ledger.Alonzo.Language (Language (..))
 import Cardano.Ledger.Alonzo.PParams (PParams, PParamsUpdate)
 import Cardano.Ledger.Alonzo.Rules.Utxo (UtxoPredicateFailure)
@@ -75,6 +75,8 @@ tests =
         trippingAnn @(Script (AlonzoEra C_Crypto)),
       testProperty "alonzo/Data" $
         trippingAnn @(Data (AlonzoEra C_Crypto)),
+      testProperty "alonzo/BinaryData" $
+        tripping @(BinaryData (AlonzoEra C_Crypto)),
       testProperty "alonzo/Metadata" $
         trippingAnn @(Metadata (AlonzoEra C_Crypto)),
       testProperty "alonzo/TxWitness" $

eras/babbage/impl/src/Cardano/Ledger/Babbage.hs

@@ -99,8 +99,7 @@ import qualified Data.Set as Set
 data BabbageEra c
 
 instance
-  ( CC.Crypto c,
-    era ~ BabbageEra c
+  ( CC.Crypto c
   ) =>
   EraModule.Era (BabbageEra c)
   where