From 7db6d8c1d71ad204ee3deb80422c5dd5c5a9bb47 Mon Sep 17 00:00:00 2001 From: Nicholas Clarke Date: Mon, 16 Nov 2020 14:56:59 +0100 Subject: [PATCH 1/4] Generalise Metadata for different eras. Introduce a 'ValidateMetadata' class which operates across eras. Currently tests are still failing, since it may be easier to operate this atop of the generalised test generation framework. --- .../src/Cardano/Ledger/Core.hs | 4 + .../src/Cardano/Ledger/Shelley.hs | 5 +- .../src/Shelley/Spec/Ledger/BlockChain.hs | 3 +- .../src/Shelley/Spec/Ledger/LedgerState.hs | 1 + .../src/Shelley/Spec/Ledger/MetaData.hs | 42 ++++++---- .../src/Shelley/Spec/Ledger/STS/Utxow.hs | 19 +++-- .../src/Shelley/Spec/Ledger/Tx.hs | 26 ++++--- .../src/Shelley/Spec/Ledger/TxBody.hs | 5 +- .../Shelley/Spec/Ledger/Generator/Core.hs | 3 + .../Shelley/Spec/Ledger/Generator/MetaData.hs | 77 +++++++++++-------- .../Serialisation/EraIndepGenerators.hs | 8 +- 11 files changed, 126 insertions(+), 67 deletions(-) diff --git a/shelley/chain-and-ledger/executable-spec/src/Cardano/Ledger/Core.hs b/shelley/chain-and-ledger/executable-spec/src/Cardano/Ledger/Core.hs index 078915956fc..4ee310bb501 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Cardano/Ledger/Core.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Cardano/Ledger/Core.hs @@ -18,6 +18,7 @@ module Cardano.Ledger.Core TxBody, Value, Script, + Metadata, -- * Constraint synonyms ChainData, @@ -40,6 +41,9 @@ type family TxBody era :: Type -- | Scripts which may lock transaction outputs in this era type family Script era :: Type +-- | Metadata which may be attached to a transaction +type family Metadata era :: Type + -- | Common constraints -- -- NOTE: 'Ord' is not included, as 'Ord' for a 'Block' or a 'NewEpochState' diff --git a/shelley/chain-and-ledger/executable-spec/src/Cardano/Ledger/Shelley.hs b/shelley/chain-and-ledger/executable-spec/src/Cardano/Ledger/Shelley.hs index e8d25d8b175..4c0870c024e 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Cardano/Ledger/Shelley.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Cardano/Ledger/Shelley.hs @@ -48,5 +48,8 @@ type ShelleyBased era = TxBodyConstraints era, -- Script constraints ChainData (Script era), - AnnotatedData (Script era) + AnnotatedData (Script era), + -- Metadata constraints + ChainData (Metadata era), + AnnotatedData (Metadata era) ) diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/BlockChain.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/BlockChain.hs index fd8a618854e..8c3905e5506 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/BlockChain.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/BlockChain.hs @@ -78,6 +78,7 @@ import qualified Cardano.Crypto.Hash.Class as Hash import qualified Cardano.Crypto.KES as KES import Cardano.Crypto.Util (SignableRepresentation (..)) import qualified Cardano.Crypto.VRF as VRF +import qualified Cardano.Ledger.Core as Core import qualified Cardano.Ledger.Crypto as CC import Cardano.Ledger.Era import Cardano.Ledger.Shelley (ShelleyBased) @@ -184,7 +185,7 @@ deriving stock instance Eq (TxSeq era) pattern TxSeq :: - (Era era, Shelley.TxBodyConstraints era) => + (Era era, Shelley.TxBodyConstraints era, ToCBOR (Core.Metadata era)) => StrictSeq (Tx era) -> TxSeq era pattern TxSeq xs <- diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs index 485ac847233..047a74446d1 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs @@ -918,6 +918,7 @@ witsVKeyNeeded utxo' tx@(Tx txbody _ _) genDelegs = verifiedWits :: ( Shelley.TxBodyConstraints era, Core.AnnotatedData (Core.Script era), + ToCBOR (Core.Metadata era), DSignable (Crypto era) (Hash (Crypto era) EraIndependentTxBody) ) => Tx era -> diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/MetaData.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/MetaData.hs index e20db9b6422..a1ce9264261 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/MetaData.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/MetaData.hs @@ -1,21 +1,24 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} module Shelley.Spec.Ledger.MetaData ( MetaDatum (..), MetaData (MetaData), MetaDataHash (..), - hashMetaData, - validMetaData, + ValidateMetadata (..), + validMetaDatum, ) where @@ -28,7 +31,10 @@ import Cardano.Binary serializeEncoding, withSlice, ) +import qualified Cardano.Ledger.Core as Core +import qualified Cardano.Ledger.Crypto as CC import Cardano.Ledger.Era (Crypto, Era) +import Cardano.Ledger.Shelley (ShelleyEra) import Cardano.Prelude (cborError) import Codec.CBOR.Decoding (Decoder) import qualified Codec.CBOR.Decoding as CBOR @@ -40,6 +46,7 @@ import qualified Data.ByteString.Lazy as LBS import Data.Map.Strict (Map) import qualified Data.Text as T import qualified Data.Text.Encoding as T +import Data.Typeable (Typeable) import Data.Word (Word64) import GHC.Generics (Generic) import NoThunks.Class (AllowThunksIn (..), NoThunks (..)) @@ -65,6 +72,8 @@ data MetaData = MetaData' deriving (Eq, Show, Generic) deriving (NoThunks) via AllowThunksIn '["mdBytes"] MetaData +type instance Core.Metadata (ShelleyEra c) = MetaData + pattern MetaData :: Map Word64 MetaDatum -> MetaData pattern MetaData m <- MetaData' m _ @@ -89,25 +98,22 @@ instance ToCBOR MetaDatum where instance FromCBOR MetaDatum where fromCBOR = decodeMetaDatum -newtype MetaDataHash era = MetaDataHash {unsafeMetaDataHash :: Hash (Crypto era) MetaData} +newtype MetaDataHash era = MetaDataHash + { unsafeMetaDataHash :: Hash (Crypto era) (Core.Metadata era) + } deriving (Show, Eq, Ord, NoThunks, NFData) -deriving instance Era era => ToCBOR (MetaDataHash era) - -deriving instance Era era => FromCBOR (MetaDataHash era) +deriving instance + (Era era, Typeable (Core.Metadata era)) => + ToCBOR (MetaDataHash era) -hashMetaData :: - Era era => - MetaData -> - MetaDataHash era -hashMetaData = MetaDataHash . hashWithSerialiser toCBOR +deriving instance + (Era era, Typeable (Core.Metadata era)) => + FromCBOR (MetaDataHash era) -------------------------------------------------------------------------------- -- Validation of sizes -validMetaData :: MetaData -> Bool -validMetaData (MetaData m) = all validMetaDatum m - validMetaDatum :: MetaDatum -> Bool -- The integer size/representation checks are enforced in the decoder. validMetaDatum (I _) = True @@ -122,6 +128,14 @@ validMetaDatum (Map kvs) = ) kvs +class ValidateMetadata era where + hashMetadata :: Core.Metadata era -> MetaDataHash era + validateMetadata :: Core.Metadata era -> Bool + +instance CC.Crypto c => ValidateMetadata (ShelleyEra c) where + hashMetadata = MetaDataHash . hashWithSerialiser toCBOR + validateMetadata (MetaData m) = all validMetaDatum m + -------------------------------------------------------------------------------- -- CBOR encoding and decoding diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Utxow.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Utxow.hs index b177b8014cc..9256483bfd9 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Utxow.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Utxow.hs @@ -88,7 +88,7 @@ import Shelley.Spec.Ledger.LedgerState witsFromWitnessSet, witsVKeyNeeded, ) -import Shelley.Spec.Ledger.MetaData (MetaDataHash, hashMetaData, validMetaData) +import Shelley.Spec.Ledger.MetaData (MetaDataHash, ValidateMetadata (..)) import Shelley.Spec.Ledger.PParams (Update) import Shelley.Spec.Ledger.STS.Utxo (UTXO, UtxoEnv (..)) import Shelley.Spec.Ledger.Scripts (ScriptHash) @@ -168,7 +168,11 @@ instance initialRules = [initialLedgerStateUTXOW] instance - (Era era, Typeable (Core.Script era), ToCBOR (PredicateFailure (UTXO era))) => + ( Era era, + Typeable (Core.Script era), + Typeable (Core.Metadata era), + ToCBOR (PredicateFailure (UTXO era)) + ) => ToCBOR (UtxowPredicateFailure era) where toCBOR = \case @@ -200,7 +204,8 @@ instance instance ( Era era, FromCBOR (PredicateFailure (UTXO era)), - Typeable (Core.Script era) + Typeable (Core.Script era), + Typeable (Core.Metadata era) ) => FromCBOR (UtxowPredicateFailure era) where @@ -254,6 +259,7 @@ utxoWitnessed :: forall era. ( ShelleyBased era, ValidateScript era, + ValidateMetadata era, STS (UTXOW era), BaseM (UTXOW era) ~ ShelleyBase, Embed (UTXO era) (UTXOW era), @@ -313,11 +319,12 @@ utxoWitnessed scriptsNeeded = (SJust mdh, SNothing) -> failBecause $ MissingTxMetaData mdh (SNothing, SJust md') -> failBecause $ - MissingTxBodyMetaDataHash (hashMetaData md') + MissingTxBodyMetaDataHash (hashMetadata md') (SJust mdh, SJust md') -> do - hashMetaData md' == mdh ?! ConflictingMetaDataHash mdh (hashMetaData md') + hashMetadata md' == mdh ?! ConflictingMetaDataHash mdh (hashMetadata md') -- check metadata value sizes - when (SoftForks.validMetaData pp) $ validMetaData md' ?! InvalidMetaData + when (SoftForks.validMetaData pp) $ + validateMetadata @era md' ?! InvalidMetaData -- check genesis keys signatures for instantaneous rewards certificates let genDelegates = diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Tx.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Tx.hs index 368826b9c4e..23415006f16 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Tx.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Tx.hs @@ -96,7 +96,6 @@ import Shelley.Spec.Ledger.BaseTypes import Shelley.Spec.Ledger.Credential (Credential (..)) import Shelley.Spec.Ledger.Hashing (EraIndependentTx, HashAnnotated (..)) import Shelley.Spec.Ledger.Keys -import Shelley.Spec.Ledger.MetaData (MetaData) import Shelley.Spec.Ledger.Scripts import Shelley.Spec.Ledger.Serialization ( decodeList, @@ -197,7 +196,7 @@ pattern WitnessSet {addrWits, scriptWits, bootWits} <- data Tx era = Tx' { _body' :: !(Core.TxBody era), _witnessSet' :: !(WitnessSet era), - _metadata' :: !(StrictMaybe MetaData), + _metadata' :: !(StrictMaybe (Core.Metadata era)), txFullBytes :: BSL.ByteString } deriving (Generic) @@ -219,10 +218,12 @@ deriving instance Eq (Tx era) pattern Tx :: - (Shelley.TxBodyConstraints era) => + ( Shelley.TxBodyConstraints era, + ToCBOR (Core.Metadata era) + ) => Core.TxBody era -> WitnessSet era -> - StrictMaybe MetaData -> + StrictMaybe (Core.Metadata era) -> Tx era pattern Tx {_body, _witnessSet, _metadata} <- Tx' _body _witnessSet _metadata _ @@ -250,10 +251,12 @@ instance ShelleyBased era => HashAnnotated (Tx era) era where type HashIndex (Tx era) = EraIndependentTx segwitTx :: - (Shelley.TxBodyConstraints era) => + ( Shelley.TxBodyConstraints era, + ToCBOR (Core.Metadata era) + ) => Annotator (Core.TxBody era) -> Annotator (WitnessSet era) -> - Maybe (Annotator MetaData) -> + Maybe (Annotator (Core.Metadata era)) -> Annotator (Tx era) segwitTx bodyAnn @@ -332,7 +335,10 @@ instance decodeRecordNamed "Tx" (const 3) $ do body <- fromCBOR wits <- decodeWits - meta <- (decodeNullMaybe fromCBOR :: Decoder s (Maybe (Annotator MetaData))) + meta <- + ( decodeNullMaybe fromCBOR :: + Decoder s (Maybe (Annotator (Core.Metadata era))) + ) pure $ Annotator $ \fullBytes bytes -> Tx' @@ -376,7 +382,9 @@ evalNativeMultiSigScript (RequireMOf m msigs) vhks = -- | Script validator for native multi-signature scheme. validateNativeMultiSigScript :: - (Shelley.TxBodyConstraints era) => + ( Shelley.TxBodyConstraints era, + ToCBOR (Core.Metadata era) + ) => MultiSig era -> Tx era -> Bool @@ -388,7 +396,7 @@ validateNativeMultiSigScript msig tx = -- | Multi-signature script witness accessor function for Transactions txwitsScript :: - (Shelley.TxBodyConstraints era) => + (Shelley.TxBodyConstraints era, ToCBOR (Core.Metadata era)) => Tx era -> Map (ScriptHash era) (Core.Script era) txwitsScript = scriptWits' . _witnessSet diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/TxBody.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/TxBody.hs index 745194c82cd..0dbc7dee2ca 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/TxBody.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/TxBody.hs @@ -600,8 +600,10 @@ type ProperFrom era = Typeable era, FromCBOR (Core.Value era), Typeable (Core.Script era), + Typeable (Core.Metadata era), FromCBOR (CompactForm (Core.Value era)), - FromCBOR (Annotator (Core.Script era)) + FromCBOR (Annotator (Core.Script era)), + FromCBOR (Annotator (Core.Metadata era)) ) -- | Needed for ToCBOR instances @@ -609,6 +611,7 @@ type ProperTo era = ( Era era, ToCBOR (Core.Value era), ToCBOR (Core.Script era), + ToCBOR (Core.Metadata era), ToCBOR (CompactForm (Core.Value era)) ) diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Core.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Core.hs index ebf7ac9790f..fcb278a815e 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Core.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Core.hs @@ -198,6 +198,7 @@ import Test.Shelley.Spec.Ledger.Utils runShelleyBase, unsafeMkUnitInterval, ) +import Cardano.Binary (ToCBOR) class ( ShelleyBased era, @@ -559,6 +560,7 @@ mkBlockHeader prev pkeys s blockNo enonce kesPeriod c0 oCert bodySize bodyHash = mkBlock :: ( Shelley.TxBodyConstraints era, + ToCBOR (Core.Metadata era), Mock (Crypto era) ) => -- | Hash of previous block @@ -589,6 +591,7 @@ mkBlock prev pkeys txns s blockNo enonce kesPeriod c0 oCert = -- | Create a block with a faked VRF result. mkBlockFakeVRF :: ( Shelley.TxBodyConstraints era, + ToCBOR (Core.Metadata era), ExMock (Crypto era) ) => -- | Hash of previous block diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/MetaData.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/MetaData.hs index f74492c4ed8..aa3a97e5d31 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/MetaData.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/MetaData.hs @@ -5,18 +5,23 @@ module Test.Shelley.Spec.Ledger.Generator.MetaData ) where -import qualified Data.ByteString.Char8 as BS (pack, length) +import Cardano.Ledger.Crypto (Crypto) +import Cardano.Ledger.Shelley (ShelleyEra) +import Control.Exception (assert) +import qualified Data.ByteString.Char8 as BS (length, pack) import qualified Data.Map.Strict as Map import qualified Data.Text as T (pack) import qualified Data.Text.Encoding as T import Data.Word (Word64) -import Control.Exception (assert) import Shelley.Spec.Ledger.BaseTypes ( StrictMaybe (..), ) - -import Cardano.Ledger.Era (Era) -import Shelley.Spec.Ledger.MetaData (MetaData (..), MetaDataHash, MetaDatum (..), hashMetaData) +import Shelley.Spec.Ledger.MetaData + ( MetaData (..), + MetaDataHash, + MetaDatum (..), + ValidateMetadata (..), + ) import Test.QuickCheck (Gen) import qualified Test.QuickCheck as QC import Test.Shelley.Spec.Ledger.Generator.Constants (Constants (..)) @@ -31,9 +36,9 @@ metadataMaxSize = 3 -- | Generate Metadata (and compute hash) with frequency 'frequencyTxWithMetaData' genMetaData :: - Era era => + Crypto c => Constants -> - Gen (StrictMaybe MetaData, StrictMaybe (MetaDataHash era)) + Gen (StrictMaybe MetaData, StrictMaybe (MetaDataHash (ShelleyEra c))) genMetaData (Constants {frequencyTxWithMetaData}) = QC.frequency [ (frequencyTxWithMetaData, genMetaData'), @@ -42,14 +47,14 @@ genMetaData (Constants {frequencyTxWithMetaData}) = -- | Generate Metadata (and compute hash) of size up to 'metadataMaxSize' genMetaData' :: - Era era => - Gen (StrictMaybe MetaData, StrictMaybe (MetaDataHash era)) + Crypto c => + Gen (StrictMaybe MetaData, StrictMaybe (MetaDataHash (ShelleyEra c))) genMetaData' = do n <- QC.choose (1, metadataMaxSize) md <- SJust . MetaData . Map.fromList <$> QC.vectorOf n genMetaDatum - pure (md, hashMetaData <$> md) + pure (md, hashMetadata <$> md) -- | Generate one of the MetaDatum genMetaDatum :: Gen (Word64, MetaDatum) @@ -65,22 +70,26 @@ genMetaDatum = do ) genDatumInt :: Gen MetaDatum -genDatumInt = I <$> QC.frequency [ (8, QC.choose (minVal, maxVal)) - , (1, pure minVal) - , (1, pure maxVal) ] +genDatumInt = + I + <$> QC.frequency + [ (8, QC.choose (minVal, maxVal)), + (1, pure minVal), + (1, pure maxVal) + ] where minVal, maxVal :: Integer - minVal = -maxVal + minVal = - maxVal maxVal = fromIntegral (maxBound :: Word64) genDatumString :: Gen MetaDatum genDatumString = - QC.sized $ \sz -> do - n <- QC.choose (0, min sz 64) - cs <- genUtf8StringOfSize n - let s = T.pack cs - assert (BS.length (T.encodeUtf8 s) == n) $ - return (S s) + QC.sized $ \sz -> do + n <- QC.choose (0, min sz 64) + cs <- genUtf8StringOfSize n + let s = T.pack cs + assert (BS.length (T.encodeUtf8 s) == n) $ + return (S s) -- | Produce an arbitrary Unicode string such that it's UTF8 encoding size in -- bytes is exactly the given length. @@ -88,22 +97,24 @@ genUtf8StringOfSize :: Int -> Gen [Char] genUtf8StringOfSize 0 = return [] genUtf8StringOfSize n = do cz <- QC.choose (1, min n 4) - c <- case cz of - 1 -> QC.choose ('\x00000', '\x00007f') - 2 -> QC.choose ('\x00080', '\x0007ff') - 3 -> QC.oneof - [ QC.choose ('\x00800', '\x00d7ff') - -- skipping UTF-16 surrogates d800--dfff - , QC.choose ('\x0e000', '\x00ffff') ] - _ -> QC.choose ('\x10000', '\x10ffff') - cs <- genUtf8StringOfSize (n-cz) - return (c:cs) + c <- case cz of + 1 -> QC.choose ('\x00000', '\x00007f') + 2 -> QC.choose ('\x00080', '\x0007ff') + 3 -> + QC.oneof + [ QC.choose ('\x00800', '\x00d7ff'), + -- skipping UTF-16 surrogates d800--dfff + QC.choose ('\x0e000', '\x00ffff') + ] + _ -> QC.choose ('\x10000', '\x10ffff') + cs <- genUtf8StringOfSize (n - cz) + return (c : cs) genDatumBytestring :: Gen MetaDatum genDatumBytestring = - QC.sized $ \sz -> do - n <- QC.choose (0, min sz 64) - B . BS.pack <$> QC.vectorOf n QC.arbitrary + QC.sized $ \sz -> do + n <- QC.choose (0, min sz 64) + B . BS.pack <$> QC.vectorOf n QC.arbitrary -- | Generate a 'MD.List [MetaDatum]' -- diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Serialisation/EraIndepGenerators.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Serialisation/EraIndepGenerators.hs index 22fcb7abefb..4808dd60e0c 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Serialisation/EraIndepGenerators.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Serialisation/EraIndepGenerators.hs @@ -709,7 +709,8 @@ instance genTx :: ( ShelleyBased era, Arbitrary (WitnessSet era), - Arbitrary (Core.TxBody era) + Arbitrary (Core.TxBody era), + Arbitrary (Core.Metadata era) ) => Gen (Tx era) genTx = @@ -724,7 +725,8 @@ genBlock :: EraGen era, Mock (Crypto era), Arbitrary (WitnessSet era), - Arbitrary (Core.TxBody era) + Arbitrary (Core.TxBody era), + Arbitrary (Core.Metadata era) ) => Gen (Block era) genBlock = do @@ -759,6 +761,7 @@ instance ValidateScript era, Arbitrary (Core.TxBody era), Arbitrary (Core.Value era), + Arbitrary (Core.Metadata era), Arbitrary (Core.Script era) ) => Arbitrary (Tx era) @@ -772,6 +775,7 @@ instance ValidateScript era, Arbitrary (Core.TxBody era), Arbitrary (Core.Value era), + Arbitrary (Core.Metadata era), Arbitrary (Core.Script era) ) => Arbitrary (Block era) From 503122ac89336e6bdd0a6d063d8f14e3a4313f81 Mon Sep 17 00:00:00 2001 From: Nicholas Clarke Date: Mon, 16 Nov 2020 18:39:09 +0100 Subject: [PATCH 2/4] Drop unneeded shelley-ma dependency in tests. --- .../shelley-ma-test/cardano-ledger-shelley-ma-test.cabal | 1 + .../shelley-ma-test/test/Test/Cardano/Ledger/Mary/Value.hs | 2 +- shelley-ma/shelley-ma-test/test/Tests.hs | 4 +++- .../shelley-spec-ledger-test.cabal | 3 --- .../shelley-spec-ledger-test/test/Tests.hs | 7 ++----- 5 files changed, 7 insertions(+), 10 deletions(-) rename shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/ValProp.hs => shelley-ma/shelley-ma-test/test/Test/Cardano/Ledger/Mary/Value.hs (99%) diff --git a/shelley-ma/shelley-ma-test/cardano-ledger-shelley-ma-test.cabal b/shelley-ma/shelley-ma-test/cardano-ledger-shelley-ma-test.cabal index 416398b89d3..ffc2aec3702 100644 --- a/shelley-ma/shelley-ma-test/cardano-ledger-shelley-ma-test.cabal +++ b/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 diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/ValProp.hs b/shelley-ma/shelley-ma-test/test/Test/Cardano/Ledger/Mary/Value.hs similarity index 99% rename from shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/ValProp.hs rename to shelley-ma/shelley-ma-test/test/Test/Cardano/Ledger/Mary/Value.hs index b8babf8ba08..3abb18ec57e 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/ValProp.hs +++ b/shelley-ma/shelley-ma-test/test/Test/Cardano/Ledger/Mary/Value.hs @@ -6,7 +6,7 @@ -- surpresses orphan warnings on Arbitray (Value era), Arbitrary AssetName, Arbitrary (PolicyID C) -module Test.Shelley.Spec.Ledger.ValProp (valTests, ass, pol) where +module Test.Cardano.Ledger.Mary.Value (valTests, ass, pol) where import Cardano.Ledger.Era import Cardano.Ledger.Mary.Value diff --git a/shelley-ma/shelley-ma-test/test/Tests.hs b/shelley-ma/shelley-ma-test/test/Tests.hs index c9b02e98cae..c38d26fc9be 100644 --- a/shelley-ma/shelley-ma-test/test/Tests.hs +++ b/shelley-ma/shelley-ma-test/test/Tests.hs @@ -1,6 +1,7 @@ module Main where import Test.Cardano.Ledger.Mary.Examples.MultiAssets (multiAssetsExample) +import Test.Cardano.Ledger.Mary.Value (valTests) import Test.Cardano.Ledger.ShelleyMA.Serialisation.Timelocks (timelockTests) import Test.Cardano.Ledger.ShelleyMA.TxBody (txBodyTest) import Test.Cardano.Ledger.ShelleyMA.Serialisation.Coders (codersTest) @@ -23,7 +24,8 @@ tests = txBodyTest, timelockTests, cddlTests 10, - maryChainExamples + maryChainExamples, + valTests ] -- main entry point diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/shelley-spec-ledger-test.cabal b/shelley/chain-and-ledger/shelley-spec-ledger-test/shelley-spec-ledger-test.cabal index 576a7b40d16..25cdce1323e 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/shelley-spec-ledger-test.cabal +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/shelley-spec-ledger-test.cabal @@ -70,7 +70,6 @@ library cardano-crypto-test, cardano-crypto-wrapper, cardano-crypto, - cardano-ledger-shelley-ma, cardano-ledger-test, cardano-ledger, cardano-prelude-test, @@ -140,7 +139,6 @@ test-suite shelley-spec-ledger-test Test.Shelley.Spec.Ledger.ShelleyTranslation Test.Shelley.Spec.Ledger.STSTests Test.Shelley.Spec.Ledger.UnitTests - Test.Shelley.Spec.Ledger.ValProp Test.TestScenario hs-source-dirs: test @@ -176,7 +174,6 @@ test-suite shelley-spec-ledger-test cardano-crypto-test, cardano-crypto-wrapper, cardano-crypto, - cardano-ledger-shelley-ma, cardano-ledger-test, cardano-ledger, cardano-prelude-test, diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Tests.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Tests.hs index 8d1df2c6c0f..26039d273c3 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Tests.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Tests.hs @@ -11,7 +11,6 @@ import Test.Shelley.Spec.Ledger.Rewards (rewardTests) import Test.Shelley.Spec.Ledger.STSTests (chainExamples) import qualified Test.Shelley.Spec.Ledger.Serialisation as Serialisation import Test.Shelley.Spec.Ledger.UnitTests (unitTests) -import Test.Shelley.Spec.Ledger.ValProp (valTests) import Test.Tasty import Test.TestScenario (TestScenario (..), mainWithTestScenario) @@ -31,8 +30,7 @@ mainTests = chainExamples, --multisigExamples, - TODO re-enable after the script embargo has been lifted unitTests, - setAlgTest, - valTests + setAlgTest ] nightlyTests :: TestTree @@ -51,8 +49,7 @@ fastTests = chainExamples, --multisigExamples, - TODO re-enable after the script embargo has been lifted unitTests, - setAlgTest, - valTests + setAlgTest ] -- main entry point From 5a78877d8934ff9848fa2edbcd7e10f4aa407897 Mon Sep 17 00:00:00 2001 From: Nicholas Clarke Date: Tue, 17 Nov 2020 10:26:40 +0100 Subject: [PATCH 3/4] Implement Metadata for Shelley MA. This covers CAD-2147, and adds support for adding additional scripts to the metadata in a structured way. --- .../impl/cardano-ledger-shelley-ma.cabal | 8 +- shelley-ma/impl/src/Cardano/Ledger/Allegra.hs | 1 + .../src/Cardano/Ledger/Allegra/Translation.hs | 6 +- shelley-ma/impl/src/Cardano/Ledger/Mary.hs | 1 + .../src/Cardano/Ledger/Mary/Translation.hs | 12 +- .../src/Cardano/Ledger/ShelleyMA/Metadata.hs | 156 ++++++++++++++++++ .../Cardano/Ledger/ShelleyMA/Rules/Utxow.hs | 1 + .../src/Cardano/Ledger/ShelleyMA/Scripts.hs | 1 + .../src/Cardano/Ledger/ShelleyMA/Timelocks.hs | 21 ++- .../src/Cardano/Ledger/ShelleyMA/TxBody.hs | 19 ++- .../ShelleyMA/Serialisation/Generators.hs | 40 ++++- .../bench/BenchValidation.hs | 4 + .../bench/Shelley/Spec/Ledger/Bench/Gen.hs | 3 + .../Shelley/Spec/Ledger/Generator/Block.hs | 2 + .../Shelley/Spec/Ledger/Generator/Core.hs | 2 + .../Shelley/Spec/Ledger/Generator/EraGen.hs | 2 + .../Shelley/Spec/Ledger/Generator/MetaData.hs | 24 +-- .../Spec/Ledger/Generator/Trace/Chain.hs | 2 + .../Spec/Ledger/Generator/Trace/Ledger.hs | 3 + .../Shelley/Spec/Ledger/Generator/Utxo.hs | 7 +- .../Spec/Ledger/Examples/EmptyBlock.hs | 8 +- .../test/Test/Shelley/Spec/Ledger/Fees.hs | 2 +- .../Test/Shelley/Spec/Ledger/PropertyTests.hs | 4 +- .../Spec/Ledger/Rules/ClassifyTraces.hs | 14 +- .../Shelley/Spec/Ledger/Rules/TestChain.hs | 7 + .../Ledger/Serialisation/Golden/Encoding.hs | 5 +- 26 files changed, 303 insertions(+), 52 deletions(-) create mode 100644 shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/Metadata.hs diff --git a/shelley-ma/impl/cardano-ledger-shelley-ma.cabal b/shelley-ma/impl/cardano-ledger-shelley-ma.cabal index 31e86651b16..274773c72ad 100644 --- a/shelley-ma/impl/cardano-ledger-shelley-ma.cabal +++ b/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: diff --git a/shelley-ma/impl/src/Cardano/Ledger/Allegra.hs b/shelley-ma/impl/src/Cardano/Ledger/Allegra.hs index dc74372697c..6f5a85978a2 100644 --- a/shelley-ma/impl/src/Cardano/Ledger/Allegra.hs +++ b/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 () diff --git a/shelley-ma/impl/src/Cardano/Ledger/Allegra/Translation.hs b/shelley-ma/impl/src/Cardano/Ledger/Allegra/Translation.hs index 48215468afb..decf34f2aed 100644 --- a/shelley-ma/impl/src/Cardano/Ledger/Allegra/Translation.hs +++ b/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) diff --git a/shelley-ma/impl/src/Cardano/Ledger/Mary.hs b/shelley-ma/impl/src/Cardano/Ledger/Mary.hs index 0bac603753c..fddc90a334d 100644 --- a/shelley-ma/impl/src/Cardano/Ledger/Mary.hs +++ b/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 () diff --git a/shelley-ma/impl/src/Cardano/Ledger/Mary/Translation.hs b/shelley-ma/impl/src/Cardano/Ledger/Mary/Translation.hs index ccc6bf79b19..d4175ceb424 100644 --- a/shelley-ma/impl/src/Cardano/Ledger/Mary/Translation.hs +++ b/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 diff --git a/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/Metadata.hs b/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/Metadata.hs new file mode 100644 index 00000000000..c00e3b62ce9 --- /dev/null +++ b/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/Metadata.hs @@ -0,0 +1,156 @@ +{-# 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, + ) + +-- | 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 + !> To 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 From + <*! Ann (Emit StrictSeq.empty) + ) + TypeListLen -> + decode + ( Ann (RecD MetadataRaw) + <*! Ann From + <*! 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)) diff --git a/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/Rules/Utxow.hs b/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/Rules/Utxow.hs index 8a8c92db5db..abc72c05c94 100644 --- a/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/Rules/Utxow.hs +++ b/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 () diff --git a/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/Scripts.hs b/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/Scripts.hs index 372be19b9bc..e099424a743 100644 --- a/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/Scripts.hs +++ b/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) diff --git a/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/Timelocks.hs b/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/Timelocks.hs index e6f538fb5c3..0e8e5b6fca4 100644 --- a/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/Timelocks.hs +++ b/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 ++ ")" -- =============================================================== diff --git a/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/TxBody.hs b/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/TxBody.hs index 7118cf7b0c3..fffeea2157e 100644 --- a/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/TxBody.hs +++ b/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) diff --git a/shelley-ma/shelley-ma-test/src/Test/Cardano/Ledger/ShelleyMA/Serialisation/Generators.hs b/shelley-ma/shelley-ma-test/src/Test/Cardano/Ledger/ShelleyMA/Serialisation/Generators.hs index 69e7fe63385..a5c72a48836 100644 --- a/shelley-ma/shelley-ma-test/src/Test/Cardano/Ledger/ShelleyMA/Serialisation/Generators.hs +++ b/shelley-ma/shelley-ma-test/src/Test/Cardano/Ledger/ShelleyMA/Serialisation/Generators.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ConstraintKinds #-} @@ -22,19 +23,24 @@ module Test.Cardano.Ledger.ShelleyMA.Serialisation.Generators ) where -import Cardano.Binary(toCBOR) -import Cardano.Ledger.Era(Era(..)) -import Cardano.Ledger.ShelleyMA.Timelocks(Timelock(..), ValidityInterval(..)) +import Cardano.Binary (toCBOR) import Cardano.Crypto.Hash (HashAlgorithm, hashWithSerialiser) import qualified Cardano.Crypto.Hash as Hash import Cardano.Ledger.Allegra (AllegraEra) +import Cardano.Ledger.Era (Era (..)) import Cardano.Ledger.Mary (MaryEra) +import qualified Cardano.Ledger.Mary.Value as ConcreteValue import qualified Cardano.Ledger.Mary.Value as Mary (AssetName (..), PolicyID (..), Value (..)) +import Cardano.Ledger.ShelleyMA (ShelleyMAEra) +import qualified Cardano.Ledger.ShelleyMA.Metadata as MA import qualified Cardano.Ledger.ShelleyMA.Rules.Utxo as MA.STS import qualified Cardano.Ledger.ShelleyMA.Scripts as MA (Timelock (..)) +import Cardano.Ledger.ShelleyMA.Timelocks (Timelock (..), ValidityInterval (..)) import qualified Cardano.Ledger.ShelleyMA.TxBody as MA (TxBody (..)) import Data.Coerce (coerce) import Data.Sequence.Strict (fromList) +import qualified Data.Sequence.Strict as StrictSeq +import Data.Typeable (Typeable) import Generic.Random (genericArbitraryU) import Shelley.Spec.Ledger.API hiding (SignedDSIGN, TxBody (..)) import Test.QuickCheck @@ -48,10 +54,10 @@ import Test.QuickCheck shrink, ) import Test.Shelley.Spec.Ledger.ConcreteCryptoTypes (Mock) +import Test.Shelley.Spec.Ledger.Generator.MetaData (genMetaData') import Test.Shelley.Spec.Ledger.Serialisation.EraIndepGenerators () +import Test.Shelley.Spec.Ledger.Serialisation.Generators () import Test.Tasty.QuickCheck (Gen) -import qualified Cardano.Ledger.Mary.Value as ConcreteValue -import Test.Shelley.Spec.Ledger.Serialisation.Generators() -- imports arbitray instance for MultiSig {------------------------------------------------------------------------------- ShelleyMAEra Generators @@ -86,6 +92,25 @@ sizedTimelock n = RequireTimeExpire <$> arbitrary ] +-- TODO Generate metadata with script preimages +instance + (Mock c, Typeable ma) => + Arbitrary (MA.Metadata (ShelleyMAEra ma c)) + where + -- Why do we do this rather than: + -- $$$ + -- arbitrary = do + -- MetaData m <- genMetaData' + -- pure $ MA.Metadata m StrictSeq.empty + -- $$$ + -- + -- The above leads to an error about a failable + -- pattern, despite the pattern being COMPLETE, resulting + -- in an unsatisfied `MonadFail` constraint. + arbitrary = genMetaData' >>= \case + MetaData m -> + pure $ MA.Metadata m StrictSeq.empty + {------------------------------------------------------------------------------- MaryEra Generators -------------------------------------------------------------------------------} @@ -106,7 +131,6 @@ instance Mock c => Arbitrary (MA.TxBody (MaryEra c)) where instance Mock c => Arbitrary (Timelock (MaryEra c)) where arbitrary = sizedTimelock maxTimelockDepth - instance Mock c => Arbitrary (Mary.PolicyID (MaryEra c)) where arbitrary = Mary.PolicyID <$> arbitrary @@ -150,8 +174,8 @@ instance Arbitrary ValidityInterval where instance Mock c => Arbitrary (MA.STS.UtxoPredicateFailure (AllegraEra c)) where arbitrary = genericArbitraryU -instance Mock c => Arbitrary (ConcreteValue.PolicyID (AllegraEra c)) where +instance Mock c => Arbitrary (ConcreteValue.PolicyID (AllegraEra c)) where arbitrary = ConcreteValue.PolicyID <$> arbitrary -instance Mock c => Arbitrary (ConcreteValue.Value (AllegraEra c)) where +instance Mock c => Arbitrary (ConcreteValue.Value (AllegraEra c)) where arbitrary = ConcreteValue.Value <$> arbitrary <*> arbitrary diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/bench/BenchValidation.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/bench/BenchValidation.hs index 8236a976bf7..a1cd7b91173 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/bench/BenchValidation.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/bench/BenchValidation.hs @@ -65,6 +65,7 @@ import Test.Shelley.Spec.Ledger.Generator.Core (EraGen) import Test.Shelley.Spec.Ledger.Generator.Presets (genEnv) import Test.Shelley.Spec.Ledger.Serialisation.Generators () import Test.Shelley.Spec.Ledger.Utils (ShelleyLedgerSTS, ShelleyLedgersSTS, ShelleyTest, testGlobals) +import Shelley.Spec.Ledger.MetaData (ValidateMetadata) -- ============================================================== @@ -80,6 +81,7 @@ validateInput :: ( EraGen era, ShelleyTest era, Mock (Crypto era), + ValidateMetadata era, API.GetLedgerView era, API.ApplyBlock era, ShelleyLedgerSTS era, @@ -94,6 +96,7 @@ genValidateInput :: ( EraGen era, ShelleyTest era, Mock (Crypto era), + ValidateMetadata era, API.GetLedgerView era, API.ApplyBlock era, ShelleyLedgerSTS era, @@ -176,6 +179,7 @@ genUpdateInputs :: ( EraGen era, ShelleyTest era, Mock (Crypto era), + ValidateMetadata era, API.GetLedgerView era, API.ApplyBlock era, ShelleyLedgerSTS era, diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/bench/Shelley/Spec/Ledger/Bench/Gen.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/bench/Shelley/Spec/Ledger/Bench/Gen.hs index 4f2618e74de..92dacbf41b8 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/bench/Shelley/Spec/Ledger/Bench/Gen.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/bench/Shelley/Spec/Ledger/Bench/Gen.hs @@ -44,6 +44,7 @@ import Test.Shelley.Spec.Ledger.Generator.Trace.Chain (mkGenesisChainState) import Test.Shelley.Spec.Ledger.Generator.Utxo (genTx) import Test.Shelley.Spec.Ledger.Serialisation.Generators () import Test.Shelley.Spec.Ledger.Utils (ShelleyLedgerSTS, ShelleyLedgersSTS, ShelleyTest) +import Shelley.Spec.Ledger.MetaData (ValidateMetadata) -- ============================================================================= @@ -77,6 +78,7 @@ genBlock :: ShelleyLedgerSTS era, ShelleyLedgersSTS era, GetLedgerView era, + ValidateMetadata era, ApplyBlock era ) => GenEnv era -> @@ -95,6 +97,7 @@ genBlock ge cs = generate $ GenBlock.genBlock ge cs genTriple :: ( EraGen era, Mock (Crypto era), + ValidateMetadata era, ShelleyTest era ) => Gen (Core.Value era) -> diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Block.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Block.hs index d98d1ab80a9..dd43f352a17 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Block.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Block.hs @@ -66,6 +66,7 @@ import Test.Shelley.Spec.Ledger.Utils slotFromEpoch, testGlobals, ) +import Shelley.Spec.Ledger.MetaData (ValidateMetadata) -- | Type alias for a transaction generator type TxGen era = @@ -82,6 +83,7 @@ genBlock :: Mock (Crypto era), ApplyBlock era, GetLedgerView era, + ValidateMetadata era, ShelleyLedgerSTS era, ShelleyLedgersSTS era, HasField "inputs" (Core.TxBody era) (Set (TxIn era)), diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Core.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Core.hs index fcb278a815e..9980f86afc5 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Core.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Core.hs @@ -221,6 +221,8 @@ class StrictMaybe (MetaDataHash era) -> Gen (Core.TxBody era) + genMetadata :: Constants -> Gen (StrictMaybe (Core.Metadata era)) + eraScriptWitnesses :: Core.Script era -> [[KeyHash 'Witness (Crypto era)]] eraKeySpaceScripts :: Constants -> [(Core.Script era, Core.Script era)] diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/EraGen.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/EraGen.hs index a809d19844e..56782a709ad 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/EraGen.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/EraGen.hs @@ -58,11 +58,13 @@ import Test.Shelley.Spec.Ledger.Generator.Core genTxOut, genesisCoins, ) +import Test.Shelley.Spec.Ledger.Generator.MetaData (genMetaData) import Test.Shelley.Spec.Ledger.Generator.Presets (keyPairs, someKeyPairs) instance CC.Crypto c => EraGen (ShelleyEra c) where genEraUtxo0 = genUtxo0 genEraTxBody = genTxBody + genMetadata = genMetaData eraScriptWitnesses = getKeyCombinations diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/MetaData.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/MetaData.hs index aa3a97e5d31..6d45969bd0b 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/MetaData.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/MetaData.hs @@ -2,11 +2,10 @@ module Test.Shelley.Spec.Ledger.Generator.MetaData ( genMetaData, + genMetaData' ) where -import Cardano.Ledger.Crypto (Crypto) -import Cardano.Ledger.Shelley (ShelleyEra) import Control.Exception (assert) import qualified Data.ByteString.Char8 as BS (length, pack) import qualified Data.Map.Strict as Map @@ -18,9 +17,7 @@ import Shelley.Spec.Ledger.BaseTypes ) import Shelley.Spec.Ledger.MetaData ( MetaData (..), - MetaDataHash, MetaDatum (..), - ValidateMetadata (..), ) import Test.QuickCheck (Gen) import qualified Test.QuickCheck as QC @@ -35,26 +32,19 @@ metadataMaxSize :: Int metadataMaxSize = 3 -- | Generate Metadata (and compute hash) with frequency 'frequencyTxWithMetaData' -genMetaData :: - Crypto c => - Constants -> - Gen (StrictMaybe MetaData, StrictMaybe (MetaDataHash (ShelleyEra c))) +genMetaData :: Constants -> Gen (StrictMaybe MetaData) genMetaData (Constants {frequencyTxWithMetaData}) = QC.frequency - [ (frequencyTxWithMetaData, genMetaData'), - (100 - frequencyTxWithMetaData, pure (SNothing, SNothing)) + [ (frequencyTxWithMetaData, SJust <$> genMetaData'), + (100 - frequencyTxWithMetaData, pure SNothing) ] -- | Generate Metadata (and compute hash) of size up to 'metadataMaxSize' -genMetaData' :: - Crypto c => - Gen (StrictMaybe MetaData, StrictMaybe (MetaDataHash (ShelleyEra c))) +genMetaData' :: Gen MetaData genMetaData' = do n <- QC.choose (1, metadataMaxSize) - md <- - SJust . MetaData . Map.fromList - <$> QC.vectorOf n genMetaDatum - pure (md, hashMetadata <$> md) + MetaData . Map.fromList + <$> QC.vectorOf n genMetaDatum -- | Generate one of the MetaDatum genMetaDatum :: Gen (Word64, MetaDatum) diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Trace/Chain.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Trace/Chain.hs index d13b39c2cc1..754061ddc2b 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Trace/Chain.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Trace/Chain.hs @@ -47,6 +47,7 @@ import Shelley.Spec.Ledger.BlockChain hashHeaderToNonce, ) import Shelley.Spec.Ledger.LedgerState (stakeDistr) +import Shelley.Spec.Ledger.MetaData (ValidateMetadata) import qualified Shelley.Spec.Ledger.STS.Chain as STS (ChainState (ChainState)) import Shelley.Spec.Ledger.Slot (BlockNo (..), EpochNo (..), SlotNo (..)) import Test.QuickCheck (Gen) @@ -78,6 +79,7 @@ instance ShelleyLedgerSTS era, ShelleyLedgersSTS era, ShelleyChainSTS era, + ValidateMetadata era, HasField "inputs" (Core.TxBody era) (Set (TxIn era)), HasField "outputs" (Core.TxBody era) (StrictSeq (TxOut era)) ) => diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Trace/Ledger.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Trace/Ledger.hs index 3feb7ed40f2..e12444b7090 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Trace/Ledger.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Trace/Ledger.hs @@ -53,6 +53,7 @@ import Test.Shelley.Spec.Ledger.Utils applySTSTest, runShelleyBase, ) +import Shelley.Spec.Ledger.MetaData (ValidateMetadata) genAccountState :: Constants -> Gen AccountState genAccountState (Constants {minTreasury, maxTreasury, minReserves, maxReserves}) = @@ -65,6 +66,7 @@ genAccountState (Constants {minTreasury, maxTreasury, minReserves, maxReserves}) instance ( EraGen era, Mock (Crypto era), + ValidateMetadata era, ShelleyLedgerSTS era, HasField "inputs" (Core.TxBody era) (Set (TxIn era)), HasField "outputs" (Core.TxBody era) (StrictSeq (TxOut era)) @@ -89,6 +91,7 @@ instance forall era. ( EraGen era, Mock (Crypto era), + ValidateMetadata era, ShelleyLedgerSTS era, ShelleyLedgersSTS era, HasField "inputs" (Core.TxBody era) (Set (TxIn era)), diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Utxo.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Utxo.hs index 973529f84f6..b5823b5a504 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Utxo.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Utxo.hs @@ -102,10 +102,10 @@ import Test.Shelley.Spec.Ledger.Generator.Core findPayScriptFromAddr, findStakeScriptFromCred, ) -import Test.Shelley.Spec.Ledger.Generator.MetaData (genMetaData) import Test.Shelley.Spec.Ledger.Generator.Trace.DCert (genDCerts) import Test.Shelley.Spec.Ledger.Generator.Update (genUpdate) import Test.Shelley.Spec.Ledger.Utils (ShelleyTest, Split (..)) +import Shelley.Spec.Ledger.MetaData (ValidateMetadata(hashMetadata)) showBalance :: ( ShelleyTest era, @@ -152,6 +152,7 @@ genTx :: forall era. ( HasCallStack, EraGen era, + ValidateMetadata era, Mock (Crypto era), HasField "inputs" (Core.TxBody era) (Set (TxIn era)), HasField "outputs" (Core.TxBody era) (StrictSeq (TxOut era)) @@ -203,7 +204,7 @@ genTx (utxoSt, dpState) (certs, deposits, refunds, dpState', (certWits, certScripts)) <- genDCerts ge pparams dpState slot txIx reserves - (metadata, metadataHash) <- genMetaData constants + metadata <- genMetadata @era constants ------------------------------------------------------------------------- -- Gather Key Witnesses and Scripts, prepare a constructor for Tx Wits ------------------------------------------------------------------------- @@ -249,7 +250,7 @@ genTx (Wdrl (Map.fromList wdrls)) draftFee (maybeToStrictMaybe update) - metadataHash + (hashMetadata <$> metadata) let draftTx = Tx draftTxBody (mkTxWits' draftTxBody) metadata -- We add now repeatedly add inputs until the process converges. converge remainderCoin wits scripts ksKeyPairs ksMSigScripts utxo pparams keySpace draftTx diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Examples/EmptyBlock.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Examples/EmptyBlock.hs index dac36a25560..e7dfbc204b2 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Examples/EmptyBlock.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Examples/EmptyBlock.hs @@ -9,7 +9,9 @@ module Test.Shelley.Spec.Ledger.Examples.EmptyBlock ) where +import Cardano.Binary (ToCBOR) import Cardano.Ledger.Era (Crypto (..)) +import qualified Cardano.Ledger.Core as Core import qualified Cardano.Ledger.Shelley as Shelley import qualified Data.Map.Strict as Map import GHC.Stack (HasCallStack) @@ -50,7 +52,8 @@ blockEx1 :: forall era. ( HasCallStack, ExMock (Crypto era), - Shelley.TxBodyConstraints era + Shelley.TxBodyConstraints era, + ToCBOR (Core.Metadata era) ) => Block era blockEx1 = @@ -71,7 +74,8 @@ blockNonce :: forall era. ( HasCallStack, ExMock (Crypto era), - Shelley.TxBodyConstraints era + Shelley.TxBodyConstraints era, + ToCBOR (Core.Metadata era) ) => Nonce blockNonce = getBlockNonce (blockEx1 @era) diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Fees.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Fees.hs index 70fc21fc800..56af0eb69e7 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Fees.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Fees.hs @@ -402,7 +402,7 @@ txbWithMD = _txfee = Coin 94, _ttl = SlotNo 10, _txUpdate = SNothing, - _mdHash = SJust $ MD.hashMetaData md + _mdHash = SJust $ MD.hashMetadata md } txWithMD :: forall c. (Cr.Crypto c, BodySignable (ShelleyEra c)) => Tx (ShelleyEra c) diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/PropertyTests.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/PropertyTests.hs index e1605d1e716..cc22cad802c 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/PropertyTests.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/PropertyTests.hs @@ -24,7 +24,7 @@ import Shelley.Spec.Ledger.BaseTypes ) import Shelley.Spec.Ledger.Coin (Coin (..)) import Shelley.Spec.Ledger.Delegation.Certificates (DCert) -import Shelley.Spec.Ledger.MetaData (MetaDataHash) +import Shelley.Spec.Ledger.MetaData (ValidateMetadata, MetaDataHash) import Shelley.Spec.Ledger.PParams (Update (..)) import Shelley.Spec.Ledger.TxBody (TxIn, TxOut, Wdrl) import Test.Shelley.Spec.Ledger.Address.Bootstrap @@ -60,6 +60,7 @@ minimalPropertyTests :: forall era. ( EraGen era, ChainProperty era, + ValidateMetadata era, HasField "inputs" (Core.TxBody era) (Set (TxIn era)), HasField "outputs" (Core.TxBody era) (StrictSeq (TxOut era)), HasField "txfee" (Core.TxBody era) Coin, @@ -94,6 +95,7 @@ propertyTests :: forall era. ( EraGen era, ChainProperty era, + ValidateMetadata era, HasField "inputs" (Core.TxBody era) (Set (TxIn era)), HasField "outputs" (Core.TxBody era) (StrictSeq (TxOut era)), HasField "txfee" (Core.TxBody era) Coin, diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Rules/ClassifyTraces.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Rules/ClassifyTraces.hs index 35d34837946..0a452b3dd05 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Rules/ClassifyTraces.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Rules/ClassifyTraces.hs @@ -19,8 +19,8 @@ module Test.Shelley.Spec.Ledger.Rules.ClassifyTraces ) where -import Cardano.Binary (serialize') -import qualified Cardano.Ledger.Core as Core (TxBody) +import Cardano.Binary (ToCBOR, serialize') +import qualified Cardano.Ledger.Core as Core (Metadata, TxBody) import Cardano.Ledger.Era (Era) import Cardano.Ledger.Shelley (ShelleyBased, TxBodyConstraints) import Cardano.Slotting.Slot (EpochSize (..)) @@ -71,7 +71,7 @@ import Shelley.Spec.Ledger.Delegation.Certificates import Shelley.Spec.Ledger.LedgerState ( txsizeBound, ) -import Shelley.Spec.Ledger.MetaData (MetaDataHash) +import Shelley.Spec.Ledger.MetaData (ValidateMetadata, MetaDataHash) import Shelley.Spec.Ledger.PParams ( Update (..), pattern ProposedPPUpdates, @@ -104,6 +104,7 @@ relevantCasesAreCovered :: forall era. ( EraGen era, ChainProperty era, + ValidateMetadata era, HasField "inputs" (Core.TxBody era) (Set (TxIn era)), HasField "outputs" (Core.TxBody era) (StrictSeq (TxOut era)), HasField "certs" (Core.TxBody era) (StrictSeq (DCert era)), @@ -240,6 +241,7 @@ scriptCredentialCertsRatio certs = certsByTx :: forall era. ( TxBodyConstraints era, + ToCBOR (Core.Metadata era), HasField "certs" (Core.TxBody era) (StrictSeq (DCert era)) ) => [Tx era] -> @@ -271,6 +273,7 @@ txScriptOutputsRatio txoutsList = hasWithdrawal :: ( TxBodyConstraints era, + ToCBOR (Core.Metadata era), HasField "wdrls" (Core.TxBody era) (Wdrl era) ) => Tx era -> @@ -291,6 +294,7 @@ hasPParamUpdate tx = hasMetaData :: ( TxBodyConstraints era, + ToCBOR (Core.Metadata era), HasField "mdHash" (Core.TxBody era) (StrictMaybe (MetaDataHash era)) ) => Tx era -> @@ -305,6 +309,7 @@ onlyValidLedgerSignalsAreGenerated :: forall era. ( EraGen era, ChainProperty era, + ValidateMetadata era, HasField "inputs" (Core.TxBody era) (Set (TxIn era)), HasField "outputs" (Core.TxBody era) (StrictSeq (TxOut era)), HasField "certs" (Core.TxBody era) (StrictSeq (DCert era)), @@ -326,6 +331,7 @@ propAbstractSizeBoundsBytes :: forall era. ( EraGen era, ChainProperty era, + ValidateMetadata era, HasField "inputs" (Core.TxBody era) (Set (TxIn era)), HasField "outputs" (Core.TxBody era) (StrictSeq (TxOut era)), HasField "certs" (Core.TxBody era) (StrictSeq (DCert era)), @@ -350,6 +356,7 @@ propAbstractSizeNotTooBig :: forall era. ( EraGen era, ChainProperty era, + ValidateMetadata era, HasField "inputs" (Core.TxBody era) (Set (TxIn era)), HasField "outputs" (Core.TxBody era) (StrictSeq (TxOut era)), HasField "certs" (Core.TxBody era) (StrictSeq (DCert era)), @@ -379,6 +386,7 @@ onlyValidChainSignalsAreGenerated :: forall era. ( EraGen era, ChainProperty era, + ValidateMetadata era, HasField "inputs" (Core.TxBody era) (Set (TxIn era)), HasField "outputs" (Core.TxBody era) (StrictSeq (TxOut era)), HasField "certs" (Core.TxBody era) (StrictSeq (DCert era)), diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Rules/TestChain.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Rules/TestChain.hs index d03c4afcd24..ff2f4eed0ba 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Rules/TestChain.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Rules/TestChain.hs @@ -89,6 +89,7 @@ import qualified Test.Shelley.Spec.Ledger.Rules.TestPool as TestPool ) import qualified Test.Shelley.Spec.Ledger.Rules.TestPoolreap as TestPoolreap import Test.Shelley.Spec.Ledger.Utils (ChainProperty, epochFromSlotNo, runShelleyBase, testGlobals) +import Shelley.Spec.Ledger.MetaData (ValidateMetadata) ------------------------------ -- Constants for Properties -- @@ -112,6 +113,7 @@ collisionFreeComplete :: forall era. ( EraGen era, ChainProperty era, + ValidateMetadata era, HasField "inputs" (Core.TxBody era) (Set (TxIn era)), HasField "outputs" (Core.TxBody era) (StrictSeq (TxOut era)), HasField "certs" (Core.TxBody era) (StrictSeq (DCert era)), @@ -136,6 +138,7 @@ adaPreservationChain :: forall era. ( EraGen era, ChainProperty era, + ValidateMetadata era, HasField "inputs" (Core.TxBody era) (Set (TxIn era)), HasField "outputs" (Core.TxBody era) (StrictSeq (TxOut era)), HasField "certs" (Core.TxBody era) (StrictSeq (DCert era)), @@ -602,6 +605,7 @@ poolProperties :: forall era. ( EraGen era, ChainProperty era, + ValidateMetadata era, HasField "inputs" (Core.TxBody era) (Set (TxIn era)), HasField "outputs" (Core.TxBody era) (StrictSeq (TxOut era)), HasField "certs" (Core.TxBody era) (StrictSeq (DCert era)), @@ -672,6 +676,7 @@ delegProperties :: forall era. ( EraGen era, ChainProperty era, + ValidateMetadata era, HasField "inputs" (Core.TxBody era) (Set (TxIn era)), HasField "outputs" (Core.TxBody era) (StrictSeq (TxOut era)), HasField "certs" (Core.TxBody era) (StrictSeq (DCert era)), @@ -839,6 +844,7 @@ removedAfterPoolreap :: forall era. ( ChainProperty era, EraGen era, + ValidateMetadata era, HasField "inputs" (Core.TxBody era) (Set (TxIn era)), HasField "outputs" (Core.TxBody era) (StrictSeq (TxOut era)), HasField "certs" (Core.TxBody era) (StrictSeq (DCert era)), @@ -867,6 +873,7 @@ forAllChainTrace :: ( Testable prop, EraGen era, ChainProperty era, + ValidateMetadata era, HasField "inputs" (Core.TxBody era) (Set (TxIn era)), HasField "outputs" (Core.TxBody era) (StrictSeq (TxOut era)), HasField "wdrls" (Core.TxBody era) (Wdrl era), diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Serialisation/Golden/Encoding.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Serialisation/Golden/Encoding.hs index 08bac2251ab..3fe95e0f1a6 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Serialisation/Golden/Encoding.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Serialisation/Golden/Encoding.hs @@ -194,6 +194,7 @@ import Test.Shelley.Spec.Ledger.Generator.EraGen (genesisId) import Test.Shelley.Spec.Ledger.Utils import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (Assertion, assertEqual, assertFailure, testCase, (@?=)) +import qualified Cardano.Ledger.Core as Core roundTrip :: (Show a, Eq a) => @@ -410,6 +411,7 @@ testBHB :: forall era crypto. ( Era era, Shelley.TxBodyConstraints era, + ToCBOR (Core.Metadata era), ExMock crypto, crypto ~ Crypto era ) => @@ -453,6 +455,7 @@ testBHBSigTokens :: forall era. ( Era era, ExMock (Crypto era), + ToCBOR (Core.Metadata era), Shelley.TxBodyConstraints era ) => Tokens -> @@ -961,7 +964,7 @@ tests = ) ) (EpochNo 0) - mdh = MD.hashMetaData $ MD.MetaData $ Map.singleton 13 (MD.I 17) + mdh = MD.hashMetadata $ MD.MetaData $ Map.singleton 13 (MD.I 17) in checkEncodingCBORAnnotated "txbody_full" ( TxBody -- transaction body with all components From ac28c87ea73a6b190233b36c551940487b2e20bd Mon Sep 17 00:00:00 2001 From: Nicholas Clarke Date: Thu, 19 Nov 2020 13:26:48 +0100 Subject: [PATCH 4/4] Add tests for Metadata serialisation. - Round-tripping of MA-era Metadata - Check that Shelley-era metadata deserialises as MA-era. --- .../src/Cardano/Ledger/ShelleyMA/Metadata.hs | 9 ++--- .../cddl-files/shelley-ma.cddl | 6 ++-- .../Ledger/ShelleyMA/Serialisation/CDDL.hs | 35 +++++++++---------- 3 files changed, 25 insertions(+), 25 deletions(-) diff --git a/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/Metadata.hs b/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/Metadata.hs index c00e3b62ce9..ddd6e1e56da 100644 --- a/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/Metadata.hs +++ b/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/Metadata.hs @@ -44,6 +44,7 @@ import Shelley.Spec.Ledger.MetaData ValidateMetadata (..), validMetaDatum, ) +import Shelley.Spec.Ledger.Serialization (mapFromCBOR, mapToCBOR) -- | Raw, un-memoised metadata type data MetadataRaw era = MetadataRaw @@ -121,10 +122,10 @@ instance encMetadataRaw :: (Core.AnnotatedData (Core.Script era)) => MetadataRaw era -> - Encode ('Closed 'Dense) (MetadataRaw era) + Encode ( 'Closed 'Dense) (MetadataRaw era) encMetadataRaw (MetadataRaw blob sp) = Rec MetadataRaw - !> To blob + !> E mapToCBOR blob !> E encodeFoldable sp instance @@ -136,13 +137,13 @@ instance TypeMapLen -> decode ( Ann (Emit MetadataRaw) - <*! Ann From + <*! Ann (D mapFromCBOR) <*! Ann (Emit StrictSeq.empty) ) TypeListLen -> decode ( Ann (RecD MetadataRaw) - <*! Ann From + <*! Ann (D mapFromCBOR) <*! D (sequence <$> decodeStrictSeq fromCBOR) ) _ -> error "Failed to decode Metadata" diff --git a/shelley-ma/shelley-ma-test/cddl-files/shelley-ma.cddl b/shelley-ma/shelley-ma-test/cddl-files/shelley-ma.cddl index 09d4bec2444..cc52dbdf72f 100644 --- a/shelley-ma/shelley-ma-test/cddl-files/shelley-ma.cddl +++ b/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 ] diff --git a/shelley-ma/shelley-ma-test/src/Test/Cardano/Ledger/ShelleyMA/Serialisation/CDDL.hs b/shelley-ma/shelley-ma-test/src/Test/Cardano/Ledger/ShelleyMA/Serialisation/CDDL.hs index c1e7851077f..fc7323dc28c 100644 --- a/shelley-ma/shelley-ma-test/src/Test/Cardano/Ledger/ShelleyMA/Serialisation/CDDL.hs +++ b/shelley-ma/shelley-ma-test/src/Test/Cardano/Ledger/ShelleyMA/Serialisation/CDDL.hs @@ -1,38 +1,37 @@ -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} -module Test.Cardano.Ledger.ShelleyMA.Serialisation.CDDL +module Test.Cardano.Ledger.ShelleyMA.Serialisation.CDDL ( cddlTests, ) where - +import Cardano.Ledger.Allegra (AllegraEra) +import qualified Cardano.Ledger.Core as Core +import Cardano.Ledger.Mary (MaryEra) +import qualified Data.ByteString.Lazy as BSL +import Test.Shelley.Spec.Ledger.ConcreteCryptoTypes (C_Crypto) import Test.Shelley.Spec.Ledger.Serialisation.CDDLUtils ( cddlTest, cddlTest', ) - - -import qualified Cardano.Ledger.Core as Core -import Test.Shelley.Spec.Ledger.ConcreteCryptoTypes (C_Crypto) -import Cardano.Ledger.Mary (MaryEra) -import Cardano.Ledger.Allegra (AllegraEra) - -import Test.Tasty (TestTree, withResource, testGroup) -import qualified Data.ByteString.Lazy as BSL +import Test.Tasty (TestTree, testGroup, withResource) type A = AllegraEra C_Crypto + type M = MaryEra C_Crypto cddlTests :: Int -> TestTree cddlTests n = withResource combinedCDDL (const (pure ())) $ \cddl -> testGroup "CDDL roundtrip tests" $ - [ cddlTest @(Core.Value A) n "coin" - --, cddlTest @(Core.Value M) n "value" - -- , cddlTest' @(Core.TxBody M) n "transaction_body" - -- , cddlTest' @(Core.TxBody A) n "transaction_body" - , cddlTest' @(Core.Script M) n "native_script" - , cddlTest' @(Core.Script A) n "native_script" + [ cddlTest @(Core.Value A) n "coin", + -- cddlTest @(Core.Value M) n "value", + -- cddlTest' @(Core.TxBody M) n "transaction_body", + -- cddlTest' @(Core.TxBody A) n "transaction_body", + cddlTest' @(Core.Script M) n "native_script", + cddlTest' @(Core.Script A) n "native_script", + cddlTest' @(Core.Metadata M) n "transaction_metadata", + cddlTest' @(Core.Metadata A) n "transaction_metadata" ] <*> pure cddl