Merge pull request #1993 from input-output-hk/nc/cad-2147

CAD-2147: Support additional scripts in structured metadata.

shelley-ma/impl/cardano-ledger-shelley-ma.cabal

@@ -25,13 +25,13 @@ library
     Cardano.Ledger.Mary
     Cardano.Ledger.Mary.Translation
     Cardano.Ledger.Mary.Value
+    Cardano.Ledger.ShelleyMA
+    Cardano.Ledger.ShelleyMA.Metadata
+    Cardano.Ledger.ShelleyMA.Rules.Utxo
+    Cardano.Ledger.ShelleyMA.Rules.Utxow
     Cardano.Ledger.ShelleyMA.Scripts
     Cardano.Ledger.ShelleyMA.Timelocks
     Cardano.Ledger.ShelleyMA.TxBody
-    Cardano.Ledger.ShelleyMA.Rules.Utxo
-    Cardano.Ledger.ShelleyMA.Rules.Utxow
-  other-modules:
-    Cardano.Ledger.ShelleyMA
 
   -- other-extensions:
   build-depends:

shelley-ma/impl/src/Cardano/Ledger/Allegra.hs

@@ -6,6 +6,7 @@
 module Cardano.Ledger.Allegra where
 
 import Cardano.Ledger.ShelleyMA
+import Cardano.Ledger.ShelleyMA.Metadata ()
 import Cardano.Ledger.ShelleyMA.Rules.Utxo ()
 import Cardano.Ledger.ShelleyMA.Rules.Utxow ()
 import Cardano.Ledger.ShelleyMA.Scripts ()

shelley-ma/impl/src/Cardano/Ledger/Allegra/Translation.hs

@@ -21,12 +21,14 @@ import Cardano.Ledger.Allegra (AllegraEra)
 import Cardano.Ledger.Crypto (Crypto)
 import Cardano.Ledger.Era hiding (Crypto)
 import Cardano.Ledger.Shelley (ShelleyEra)
+import qualified Cardano.Ledger.ShelleyMA.Metadata as Allegra
 import Cardano.Ledger.ShelleyMA.Timelocks (ValidityInterval (ValidityInterval), translate)
 import qualified Cardano.Ledger.ShelleyMA.TxBody as Allegra
 import Control.Iterate.SetAlgebra (biMapFromList, lifo)
 import Data.Coerce (coerce)
 import Data.Foldable (toList)
 import qualified Data.Map.Strict as Map
+import qualified Data.Sequence.Strict as StrictSeq
 import qualified Data.Set as Set
 import Data.Typeable (Typeable)
 import Shelley.Spec.Ledger.API
@@ -80,9 +82,11 @@ instance forall c. Crypto c => TranslateEra (AllegraEra c) Tx where
       Tx
         { _body = translateBody body,
           _witnessSet = translateEra' ctx witness,
-          _metadata = md
+          _metadata = translateMetadata <$> md
         }
     where
+      translateMetadata :: MetaData -> Allegra.Metadata (AllegraEra c)
+      translateMetadata (MetaData md) = Allegra.Metadata md StrictSeq.empty
       translateBody ::
         ( TxBody (ShelleyEra c) ->
           Allegra.TxBody (AllegraEra c)

shelley-ma/impl/src/Cardano/Ledger/Mary.hs

@@ -6,6 +6,7 @@
 module Cardano.Ledger.Mary where
 
 import Cardano.Ledger.ShelleyMA
+import Cardano.Ledger.ShelleyMA.Metadata ()
 import Cardano.Ledger.ShelleyMA.Rules.Utxo ()
 import Cardano.Ledger.ShelleyMA.Rules.Utxow ()
 import Cardano.Ledger.ShelleyMA.Scripts ()

shelley-ma/impl/src/Cardano/Ledger/Mary/Translation.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
@@ -20,6 +21,8 @@ import Cardano.Ledger.Crypto (Crypto)
 import Cardano.Ledger.Era hiding (Crypto)
 import Cardano.Ledger.Mary (MaryEra)
 import Cardano.Ledger.Mary.Value
+import Cardano.Ledger.ShelleyMA.Metadata (Metadata (..), pattern Metadata)
+import Cardano.Ledger.ShelleyMA.Scripts (Timelock)
 import Cardano.Ledger.ShelleyMA.TxBody
 import qualified Cardano.Ledger.Val as Val
 import Control.Iterate.SetAlgebra (biMapFromList, lifo)
@@ -77,7 +80,7 @@ instance Crypto c => TranslateEra (MaryEra c) Tx where
       Tx
         { _body = translateEra' ctx body,
           _witnessSet = translateEra' ctx witness,
-          _metadata = md
+          _metadata = translateEra' ctx <$> md
         }
 
 -- TODO when a genesis has been introduced for Mary, this instance can be
@@ -348,6 +351,13 @@ instance Crypto c => TranslateEra (MaryEra c) TxBody where
         (coerce m)
         (translateValue forge)
 
+instance Crypto c => TranslateEra (MaryEra c) Metadata where
+  translateEra ctx (Metadata blob sp) =
+    pure $
+      Metadata blob (translateEra' ctx <$> sp)
+
+instance Crypto c => TranslateEra (MaryEra c) Timelock
+
 translateValue :: Era era => Coin -> Value era
 translateValue = Val.inject
 

shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/Metadata.hs

@@ -0,0 +1,157 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Cardano.Ledger.ShelleyMA.Metadata
+  ( Metadata (..),
+    pattern Metadata,
+  )
+where
+
+import Cardano.Binary (FromCBOR (..), ToCBOR (..), peekTokenType)
+import Cardano.Crypto.Hash (hashWithSerialiser)
+import qualified Cardano.Ledger.Core as Core
+import Cardano.Ledger.Crypto (Crypto)
+import Cardano.Ledger.Era (Era)
+import Cardano.Ledger.ShelleyMA (MaryOrAllegra, ShelleyMAEra)
+import Cardano.Ledger.ShelleyMA.Scripts ()
+import Codec.CBOR.Decoding (TokenType (TypeListLen, TypeMapLen))
+import Control.DeepSeq (deepseq)
+import Data.Coders
+import Data.Map.Strict (Map)
+import Data.MemoBytes
+import Data.Sequence.Strict (StrictSeq)
+import qualified Data.Sequence.Strict as StrictSeq
+import Data.Typeable (Typeable)
+import Data.Word (Word64)
+import GHC.Generics (Generic)
+import NoThunks.Class
+import Shelley.Spec.Ledger.MetaData
+  ( MetaDataHash (..),
+    MetaDatum,
+    ValidateMetadata (..),
+    validMetaDatum,
+  )
+import Shelley.Spec.Ledger.Serialization (mapFromCBOR, mapToCBOR)
+
+-- | Raw, un-memoised metadata type
+data MetadataRaw era = MetadataRaw
+  { -- | Unstructured metadata "blob"
+    mdBlob :: !(Map Word64 MetaDatum),
+    -- | Pre-images of script hashes found within the TxBody, but which are not
+    -- required as witnesses. Examples include:
+    -- - Token policy IDs appearing in transaction outputs
+    -- - Pool reward account registrations
+    mdScriptPreimages :: !(StrictSeq (Core.Script era))
+  }
+  deriving (Generic)
+
+deriving instance (Core.ChainData (Core.Script era)) => Eq (MetadataRaw era)
+
+deriving instance (Core.ChainData (Core.Script era)) => Show (MetadataRaw era)
+
+deriving instance
+  (Core.ChainData (Core.Script era)) =>
+  NoThunks (MetadataRaw era)
+
+newtype Metadata era = MetadataWithBytes (MemoBytes (MetadataRaw era))
+  deriving (Generic, Typeable)
+  deriving newtype (ToCBOR)
+
+deriving newtype instance
+  (Era era, Core.ChainData (Core.Script era)) =>
+  Eq (Metadata era)
+
+deriving newtype instance
+  (Era era, Core.ChainData (Core.Script era)) =>
+  Show (Metadata era)
+
+deriving newtype instance
+  (Era era, Core.ChainData (Core.Script era)) =>
+  NoThunks (Metadata era)
+
+pattern Metadata ::
+  ( Core.AnnotatedData (Core.Script era),
+    Ord (Core.Script era)
+  ) =>
+  Map Word64 MetaDatum ->
+  StrictSeq (Core.Script era) ->
+  Metadata era
+pattern Metadata blob sp <-
+  MetadataWithBytes (Memo (MetadataRaw blob sp) _)
+  where
+    Metadata blob sp =
+      MetadataWithBytes $
+        memoBytes
+          (encMetadataRaw $ MetadataRaw blob sp)
+
+{-# COMPLETE Metadata #-}
+
+type instance
+  Core.Metadata (ShelleyMAEra (ma :: MaryOrAllegra) c) =
+    Metadata (ShelleyMAEra (ma :: MaryOrAllegra) c)
+
+instance
+  ( Crypto c,
+    Typeable ma,
+    Core.AnnotatedData (Core.Script (ShelleyMAEra ma c))
+  ) =>
+  ValidateMetadata (ShelleyMAEra (ma :: MaryOrAllegra) c)
+  where
+  hashMetadata = MetaDataHash . hashWithSerialiser toCBOR
+
+  validateMetadata (Metadata blob sp) = deepseq sp $ all validMetaDatum blob
+
+--------------------------------------------------------------------------------
+-- Serialisation
+--------------------------------------------------------------------------------
+
+-- | Encode Metadata
+encMetadataRaw ::
+  (Core.AnnotatedData (Core.Script era)) =>
+  MetadataRaw era ->
+  Encode ( 'Closed 'Dense) (MetadataRaw era)
+encMetadataRaw (MetadataRaw blob sp) =
+  Rec MetadataRaw
+    !> E mapToCBOR blob
+    !> E encodeFoldable sp
+
+instance
+  (Era era, Core.AnnotatedData (Core.Script era)) =>
+  FromCBOR (Annotator (MetadataRaw era))
+  where
+  fromCBOR =
+    peekTokenType >>= \case
+      TypeMapLen ->
+        decode
+          ( Ann (Emit MetadataRaw)
+              <*! Ann (D mapFromCBOR)
+              <*! Ann (Emit StrictSeq.empty)
+          )
+      TypeListLen ->
+        decode
+          ( Ann (RecD MetadataRaw)
+              <*! Ann (D mapFromCBOR)
+              <*! D (sequence <$> decodeStrictSeq fromCBOR)
+          )
+      _ -> error "Failed to decode Metadata"
+
+deriving via
+  (Mem (MetadataRaw era))
+  instance
+    ( Era era,
+      Core.AnnotatedData (Core.Script era)
+    ) =>
+    FromCBOR (Annotator (Metadata era))

shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/Rules/Utxow.hs

@@ -17,6 +17,7 @@ import qualified Cardano.Ledger.Crypto as CryptoClass
 import Cardano.Ledger.Mary.Value (PolicyID, Value, policies, policyID)
 import Cardano.Ledger.Shelley (ShelleyBased)
 import Cardano.Ledger.ShelleyMA (MaryOrAllegra, ShelleyMAEra)
+import Cardano.Ledger.ShelleyMA.Metadata ()
 import Cardano.Ledger.ShelleyMA.Rules.Utxo ()
 import Cardano.Ledger.ShelleyMA.Scripts ()
 import Cardano.Ledger.ShelleyMA.TxBody ()

shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/Scripts.hs

@@ -36,6 +36,7 @@ instance
   ( CryptoClass.Crypto c,
     Typeable ma,
     Shelley.TxBodyConstraints (ShelleyMAEra ma c),
+    Core.AnnotatedData (Core.Metadata (ShelleyMAEra ma c)),
     (HasField "vldt" (Core.TxBody (ShelleyMAEra ma c)) ValidityInterval)
   ) =>
   ValidateScript (ShelleyMAEra ma c)

shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/Timelocks.hs

@@ -136,7 +136,7 @@ data TimelockRaw era
   | MOfN !Int !(StrictSeq (Timelock era)) -- Note that the Int may be negative in which case (MOfN -2 [..]) is always True
   | TimeStart !SlotNo -- The start time
   | TimeExpire !SlotNo -- The time it expires
-  deriving (Eq, Show, Ord, Generic)
+  deriving (Eq, Show, Ord, Generic, NFData)
 
 deriving instance Typeable era => NoThunks (TimelockRaw era)
 
@@ -174,7 +174,7 @@ instance Era era => FromCBOR (Annotator (TimelockRaw era)) where
 
 newtype Timelock era = TimelockConstr (MemoBytes (TimelockRaw era))
   deriving (Eq, Ord, Show, Generic)
-  deriving newtype (ToCBOR, NoThunks)
+  deriving newtype (ToCBOR, NoThunks, NFData)
 
 deriving via
   (Mem (TimelockRaw era))
@@ -285,7 +285,10 @@ evalFPS ::
 evalFPS timelock vhks txb = evalTimelock vhks (getField @"vldt" txb) timelock
 
 validateTimelock ::
-  (Shelley.TxBodyConstraints era, HasField "vldt" (Core.TxBody era) ValidityInterval) =>
+  ( Shelley.TxBodyConstraints era,
+    HasField "vldt" (Core.TxBody era) ValidityInterval,
+    ToCBOR (Core.Metadata era)
+  ) =>
   Timelock era ->
   Tx era ->
   Bool
@@ -314,9 +317,15 @@ hashTimelockScript =
 showTimelock :: Era era => Timelock era -> String
 showTimelock (RequireTimeStart (SlotNo i)) = "(Start >= " ++ show i ++ ")"
 showTimelock (RequireTimeExpire (SlotNo i)) = "(Expire < " ++ show i ++ ")"
-showTimelock (RequireAllOf xs) = "(AllOf " ++ foldl accum ")" xs where accum ans x = showTimelock x ++ " " ++ ans
-showTimelock (RequireAnyOf xs) = "(AnyOf " ++ foldl accum ")" xs where accum ans x = showTimelock x ++ " " ++ ans
-showTimelock (RequireMOf m xs) = "(MOf " ++ show m ++ " " ++ foldl accum ")" xs where accum ans x = showTimelock x ++ " " ++ ans
+showTimelock (RequireAllOf xs) = "(AllOf " ++ foldl accum ")" xs
+  where
+    accum ans x = showTimelock x ++ " " ++ ans
+showTimelock (RequireAnyOf xs) = "(AnyOf " ++ foldl accum ")" xs
+  where
+    accum ans x = showTimelock x ++ " " ++ ans
+showTimelock (RequireMOf m xs) = "(MOf " ++ show m ++ " " ++ foldl accum ")" xs
+  where
+    accum ans x = showTimelock x ++ " " ++ ans
 showTimelock (RequireSignature hash) = "(Signature " ++ show hash ++ ")"
 
 -- ===============================================================

shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/TxBody.hs

@@ -87,6 +87,7 @@ type FamsFrom era =
   ( Era era,
     Typeable era,
     Typeable (Script era),
+    Typeable (Core.Metadata era),
     FromCBOR (CompactForm (Value era)), -- Arises because TxOut uses Compact form
     FromCBOR (Value era),
     FromCBOR (Annotator (Script era)) -- Arises becaause DCert memoizes its bytes
@@ -96,7 +97,8 @@ type FamsTo era =
   ( Era era,
     ToCBOR (Value era),
     ToCBOR (CompactForm (Value era)), -- Arises because TxOut uses Compact form
-    ToCBOR (Script era)
+    ToCBOR (Script era),
+    Typeable (Core.Metadata era)
   )
 
 -- =======================================================
@@ -145,14 +147,21 @@ fromSJust :: StrictMaybe a -> a
 fromSJust (SJust x) = x
 fromSJust SNothing = error "SNothing in fromSJust"
 
-encodeKeyedStrictMaybe :: ToCBOR a => Word -> StrictMaybe a -> Encode ( 'Closed 'Sparse) (StrictMaybe a)
+encodeKeyedStrictMaybe ::
+  ToCBOR a =>
+  Word ->
+  StrictMaybe a ->
+  Encode ( 'Closed 'Sparse) (StrictMaybe a)
 encodeKeyedStrictMaybe key x = Omit isSNothing (Key key (E (toCBOR . fromSJust) x))
 
 -- Sparse encodings of TxBodyRaw, the key values are fixed by backwarad compatibility
 -- concerns as we want the Shelley era TxBody to deserialise as a Shelley-ma TxBody.
 -- txXparse and bodyFields should be Duals, visual inspection helps ensure this.
 
-txSparse :: (Val (Value era), FamsTo era) => TxBodyRaw era -> Encode ( 'Closed 'Sparse) (TxBodyRaw era)
+txSparse ::
+  (Val (Value era), FamsTo era) =>
+  TxBodyRaw era ->
+  Encode ( 'Closed 'Sparse) (TxBodyRaw era)
 txSparse (TxBodyRaw inp out cert wdrl fee (ValidityInterval bot top) up hash frge) =
   Keyed (\i o f topx c w u h botx forg -> TxBodyRaw i o c w f (ValidityInterval botx topx) u h forg)
     !> Key 0 (E encodeFoldable inp) -- We don't have to send these in TxBodyX order
@@ -204,7 +213,9 @@ type instance
 
 deriving instance (Compactible (Value era), Eq (Value era)) => Eq (TxBody era)
 
-deriving instance (Era era, Compactible (Value era), Show (Value era)) => Show (TxBody era)
+deriving instance
+  (Era era, Compactible (Value era), Show (Value era)) =>
+  Show (TxBody era)
 
 deriving instance Generic (TxBody era)
 

shelley-ma/shelley-ma-test/cardano-ledger-shelley-ma-test.cabal

@@ -81,6 +81,7 @@ test-suite cardano-ledger-shelley-ma-test
       Test.Cardano.Ledger.Mary.Examples
       Test.Cardano.Ledger.Mary.Examples.Cast
       Test.Cardano.Ledger.Mary.Examples.MultiAssets
+      Test.Cardano.Ledger.Mary.Value
     default-language:    Haskell2010
     ghc-options:
       -threaded

shelley-ma/shelley-ma-test/cddl-files/shelley-ma.cddl

@@ -211,10 +211,10 @@ transaction_metadatum_label = uint
 
 transaction_metadata =
   { * transaction_metadatum_label => transaction_metadatum }
-  / [{ ? 0: { * transaction_metadatum_label => transaction_metadatum }
-     , ? 1: [ * native_script ]
+  / [ 0: { * transaction_metadatum_label => transaction_metadatum }
+     , 1: [ * native_script ]
      ; other types of metadata...
-    }]
+    ]
 
 vkeywitness = [ $vkey, $signature ]