Merge pull request #4811 from IntersectMBO/lehins/use-mempack-newest

Integration of MemPack

Author: lehins

.github/workflows/haskell.yml

@@ -87,7 +87,7 @@ jobs:
       uses: input-output-hk/actions/haskell@latest
       with:
         ghc-version: ${{ matrix.ghc }}
-        cabal-version: 3.12.1.0
+        cabal-version: 3.14
 
     - name: Configure to use libsodium
       run: |
@@ -266,7 +266,7 @@ jobs:
       uses: input-output-hk/actions/haskell@latest
       with:
         ghc-version: ${{ matrix.ghc }}
-        cabal-version: 3.12.1.0
+        cabal-version: 3.14
 
     - name: Set up Ruby 2.7
       if: contains(fromJson(env.packages-with-ruby-cddl-tests), matrix.package)
@@ -432,7 +432,7 @@ jobs:
       uses: input-output-hk/actions/haskell@latest
       with:
         ghc-version: 9.10.1
-        cabal-version: 3.12.1.0
+        cabal-version: 3.14
 
     - name: Install gen-hie if not cached
       if: steps.cache-gen-hie.outputs.cache-hit != 'true'

eras/allegra/impl/CHANGELOG.md

@@ -2,6 +2,7 @@
 
 ## 1.7.0.0
 
+* Add `MemPack` instance for `Timelock`
 * Remove deprecated `AuxiliaryData` type synonym
 * Deprecate `Allegra` type synonym
 * Remove crypto parametrization from `AllegraEra`

eras/allegra/impl/cardano-ledger-allegra.cabal

@@ -74,6 +74,7 @@ library
     cborg,
     containers,
     deepseq,
+    mempack,
     microlens,
     nothunks,
     small-steps >=1.1,

eras/allegra/impl/src/Cardano/Ledger/Allegra/Scripts.hs

@@ -87,6 +87,7 @@ import Cardano.Ledger.Shelley.Scripts (
   pattern RequireMOf,
   pattern RequireSignature,
  )
+import Data.MemPack
 
 import Cardano.Slotting.Slot (SlotNo (..))
 import Control.DeepSeq (NFData (..))
@@ -209,7 +210,7 @@ instance Era era => DecCBOR (Annotator (TimelockRaw era)) where
 
 newtype Timelock era = TimelockConstr (MemoBytes TimelockRaw era)
   deriving (Eq, Generic)
-  deriving newtype (ToCBOR, NoThunks, NFData, SafeToHash)
+  deriving newtype (ToCBOR, NoThunks, NFData, SafeToHash, MemPack)
 
 instance Era era => EncCBOR (Timelock era)
 

eras/alonzo/impl/CHANGELOG.md

@@ -2,6 +2,7 @@
 
 ## 1.13.0.0
 
+* Add `MemPack` instance for `Addr28Extra`, `DataHash32`, `AlonzoTxOut` and `PlutusScript AlonzoEra`
 * Deprecate `hashAlonzoTxAuxData`
 * Stop re-exporting deprecated `AuxiliaryDataHash` from `Cardano.Ledger.Alonzo.TxAuxData`
 * Deprecate `Alonzo` type synonym

eras/alonzo/impl/cardano-ledger-alonzo.cabal

@@ -89,6 +89,7 @@ library
     containers,
     data-default,
     deepseq,
+    mempack,
     microlens,
     mtl,
     nothunks,

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

@@ -114,6 +114,7 @@ import qualified Data.ByteString as BS
 import Data.Kind (Type)
 import qualified Data.Map.Strict as Map
 import Data.Maybe (fromJust, isJust)
+import Data.MemPack
 import Data.Typeable
 import Data.Word (Word16, Word32, Word8)
 import GHC.Generics (Generic)
@@ -417,6 +418,21 @@ data AlonzoScript era
   | PlutusScript !(PlutusScript era)
   deriving (Generic)
 
+instance (Era era, MemPack (PlutusScript era)) => MemPack (AlonzoScript era) where
+  packedByteCount = \case
+    TimelockScript script -> packedTagByteCount + packedByteCount script
+    PlutusScript script -> packedTagByteCount + packedByteCount script
+  packM = \case
+    TimelockScript script -> packTagM 0 >> packM script
+    PlutusScript script -> packTagM 1 >> packM script
+  {-# INLINE packM #-}
+  unpackM =
+    unpackTagM >>= \case
+      0 -> TimelockScript <$> unpackM
+      1 -> PlutusScript <$> unpackM
+      n -> unknownTagM @(AlonzoScript era) n
+  {-# INLINE unpackM #-}
+
 deriving instance Eq (PlutusScript era) => Eq (AlonzoScript era)
 
 instance (Era era, NoThunks (PlutusScript era)) => NoThunks (AlonzoScript era)
@@ -531,6 +547,23 @@ instance Eq (PlutusScript era) => EqRaw (AlonzoScript era) where
 instance AlonzoEraScript era => ToJSON (AlonzoScript era) where
   toJSON = String . serializeAsHexText
 
+-- | It might seem that this instance unnecessarily utilizes a zero Tag, but it is needed for
+-- forward compatibility with plutus scripts from future eras.
+--
+-- That being said, currently this instance is not used at all, since reference scripts where
+-- introduced in Babbage era and `MemPack` for now is only used for `TxOut`s
+instance MemPack (PlutusScript AlonzoEra) where
+  packedByteCount = \case
+    AlonzoPlutusV1 script -> packedTagByteCount + packedByteCount script
+  packM = \case
+    AlonzoPlutusV1 script -> packTagM 0 >> packM script
+  {-# INLINE packM #-}
+  unpackM =
+    unpackTagM >>= \case
+      0 -> AlonzoPlutusV1 <$> unpackM
+      n -> unknownTagM @(PlutusScript AlonzoEra) n
+  {-# INLINE unpackM #-}
+
 --------------------------------------------------------------------------------
 -- Serialisation
 --------------------------------------------------------------------------------

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

@@ -62,11 +62,14 @@ import Cardano.Ledger.Binary (
   FromCBOR (..),
   Interns,
   ToCBOR (..),
+  TokenType (..),
   cborError,
   decodeBreakOr,
   decodeListLenOrIndef,
+  decodeMemPack,
   encodeListLen,
   interns,
+  peekTokenType,
  )
 import Cardano.Ledger.Coin (Coin (..))
 import Cardano.Ledger.Compactible
@@ -77,11 +80,12 @@ import Cardano.Ledger.Shelley.Core
 import qualified Cardano.Ledger.Shelley.TxOut as Shelley
 import Cardano.Ledger.Val (Val (..))
 import Control.DeepSeq (NFData (..), rwhnf)
-import Control.Monad (guard, (<$!>))
+import Control.Monad (guard)
 import Data.Aeson (ToJSON (..), object, (.=))
 import qualified Data.Aeson as Aeson (Value (Null, String))
 import Data.Bits
 import Data.Maybe (fromMaybe)
+import Data.MemPack
 import Data.Typeable (Proxy (..), (:~:) (Refl))
 import Data.Word
 import GHC.Generics (Generic)
@@ -103,6 +107,13 @@ data Addr28Extra
       {-# UNPACK #-} !Word64 -- Payment Addr (32bits) + ... +  0/1 for Testnet/Mainnet + 0/1 Script/Pubkey
   deriving (Eq, Show, Generic, NoThunks)
 
+instance MemPack Addr28Extra where
+  packedByteCount _ = 32
+  packM (Addr28Extra w0 w1 w2 w3) = packM w0 >> packM w1 >> packM w2 >> packM w3
+  {-# INLINE packM #-}
+  unpackM = Addr28Extra <$> unpackM <*> unpackM <*> unpackM <*> unpackM
+  {-# INLINE unpackM #-}
+
 data DataHash32
   = DataHash32
       {-# UNPACK #-} !Word64 -- DataHash
@@ -111,6 +122,13 @@ data DataHash32
       {-# UNPACK #-} !Word64 -- DataHash
   deriving (Eq, Show, Generic, NoThunks)
 
+instance MemPack DataHash32 where
+  packedByteCount _ = 32
+  packM (DataHash32 w0 w1 w2 w3) = packM w0 >> packM w1 >> packM w2 >> packM w3
+  {-# INLINE packM #-}
+  unpackM = DataHash32 <$> unpackM <*> unpackM <*> unpackM <*> unpackM
+  {-# INLINE unpackM #-}
+
 decodeAddress28 ::
   Credential 'Staking ->
   Addr28Extra ->
@@ -147,6 +165,42 @@ data AlonzoTxOut era
       {-# UNPACK #-} !(CompactForm Coin) -- Ada value
       {-# UNPACK #-} !DataHash32
 
+-- | This instance is backwards compatible in binary representation with TxOut instances for all
+-- previous era
+instance (Era era, MemPack (CompactForm (Value era))) => MemPack (AlonzoTxOut era) where
+  packedByteCount = \case
+    TxOutCompact' cAddr cValue ->
+      packedTagByteCount + packedByteCount cAddr + packedByteCount cValue
+    TxOutCompactDH' cAddr cValue dataHash ->
+      packedTagByteCount + packedByteCount cAddr + packedByteCount cValue + packedByteCount dataHash
+    TxOut_AddrHash28_AdaOnly cred addr28 cCoin ->
+      packedTagByteCount + packedByteCount cred + packedByteCount addr28 + packedByteCount cCoin
+    TxOut_AddrHash28_AdaOnly_DataHash32 cred addr28 cCoin dataHash32 ->
+      packedTagByteCount
+        + packedByteCount cred
+        + packedByteCount addr28
+        + packedByteCount cCoin
+        + packedByteCount dataHash32
+  {-# INLINE packedByteCount #-}
+  packM = \case
+    TxOutCompact' cAddr cValue ->
+      packTagM 0 >> packM cAddr >> packM cValue
+    TxOutCompactDH' cAddr cValue dataHash ->
+      packTagM 1 >> packM cAddr >> packM cValue >> packM dataHash
+    TxOut_AddrHash28_AdaOnly cred addr28 cCoin ->
+      packTagM 2 >> packM cred >> packM addr28 >> packM cCoin
+    TxOut_AddrHash28_AdaOnly_DataHash32 cred addr28 cCoin dataHash32 ->
+      packTagM 3 >> packM cred >> packM addr28 >> packM cCoin >> packM dataHash32
+  {-# INLINE packM #-}
+  unpackM =
+    unpackTagM >>= \case
+      0 -> TxOutCompact' <$> unpackM <*> unpackM
+      1 -> TxOutCompactDH' <$> unpackM <*> unpackM <*> unpackM
+      2 -> TxOut_AddrHash28_AdaOnly <$> unpackM <*> unpackM <*> unpackM
+      3 -> TxOut_AddrHash28_AdaOnly_DataHash32 <$> unpackM <*> unpackM <*> unpackM <*> unpackM
+      n -> unknownTagM @(AlonzoTxOut era) n
+  {-# INLINE unpackM #-}
+
 deriving stock instance (Eq (Value era), Compactible (Value era)) => Eq (AlonzoTxOut era)
 
 deriving instance Generic (AlonzoTxOut era)
@@ -365,10 +419,15 @@ instance (Era era, Val (Value era)) => DecCBOR (AlonzoTxOut era) where
       Just _ -> cborError $ DecoderErrorCustom "txout" "wrong number of terms in txout"
   {-# INLINEABLE decCBOR #-}
 
-instance (Era era, Val (Value era)) => DecShareCBOR (AlonzoTxOut era) where
+instance (Era era, Val (Value era), MemPack (CompactForm (Value era))) => DecShareCBOR (AlonzoTxOut era) where
   type Share (AlonzoTxOut era) = Interns (Credential 'Staking)
   decShareCBOR credsInterns = do
-    internAlonzoTxOut (interns credsInterns) <$!> decCBOR
+    txOut <-
+      peekTokenType >>= \case
+        TypeBytes -> decodeMemPack
+        TypeBytesIndef -> decodeMemPack
+        _ -> decCBOR
+    pure $! internAlonzoTxOut (interns credsInterns) txOut
   {-# INLINEABLE decShareCBOR #-}
 
 internAlonzoTxOut ::

eras/babbage/impl/CHANGELOG.md

@@ -2,6 +2,7 @@
 
 ## 1.11.0.0
 
+* Add `MemPack` instance for `BabbageTxOut` and `PlutusScript BabbageEra`
 * Deprecate `Babbage` type synonym
 * Remove crypto parametrization from `BabbageEra`
 

eras/babbage/impl/cardano-ledger-babbage.cabal

@@ -84,6 +84,7 @@ library
     cardano-strict-containers,
     containers,
     deepseq,
+    mempack,
     microlens,
     nothunks,
     plutus-ledger-api >=1.33,