From 3a75dd9038358bce7e53d9e1fcd5f94d687b5f48 Mon Sep 17 00:00:00 2001 From: Samuel Evans-Powell Date: Mon, 25 Oct 2021 09:54:54 +0800 Subject: [PATCH] Add generators and coverage for TxOut --- lib/core/src/Cardano/Api/Gen.hs | 51 +++++- lib/core/test/unit/Cardano/Api/GenSpec.hs | 188 +++++++++++++++++++--- 2 files changed, 215 insertions(+), 24 deletions(-) diff --git a/lib/core/src/Cardano/Api/Gen.hs b/lib/core/src/Cardano/Api/Gen.hs index 18f2f25cdbb..7c59b014261 100644 --- a/lib/core/src/Cardano/Api/Gen.hs +++ b/lib/core/src/Cardano/Api/Gen.hs @@ -1,5 +1,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} module Cardano.Api.Gen ( genTxIn @@ -56,6 +57,11 @@ module Cardano.Api.Gen , genAddressByron , genAddressShelley , genAddressInEra + , genUnsignedQuantity + , genValueForTxOut + , genTxOutValue + , genTxOut + , genTxOutDatumHash ) where import Prelude @@ -63,11 +69,15 @@ import Prelude import Cardano.Api hiding ( txIns ) import Cardano.Api.Shelley - ( PlutusScript (..), StakeCredential (..) ) + ( Hash (..), PlutusScript (..), StakeCredential (..) ) import Cardano.Ledger.Credential ( Ix, Ptr (..) ) +import Cardano.Ledger.SafeHash + ( unsafeMakeSafeHash ) import Data.ByteString ( ByteString ) +import Data.Coerce + ( coerce ) import Data.Int ( Int64 ) import Data.Maybe @@ -99,7 +109,6 @@ import Test.QuickCheck import qualified Cardano.Binary as CBOR import qualified Cardano.Crypto.Hash as Crypto -import qualified Cardano.Crypto.Hash.Class as Crypto import qualified Cardano.Crypto.Seed as Crypto import qualified Data.ByteString as BS import qualified Data.ByteString.Short as SBS @@ -580,3 +589,41 @@ genAddressInEra era = , shelleyAddressInEra <$> genAddressShelley ] +genUnsignedQuantity :: Gen Quantity +genUnsignedQuantity = do + (Large (n :: Word64)) <- arbitrary + pure $ fromIntegral n + +-- | Generate a 'Value' suitable for usage in a transaction output, i.e. any +-- asset ID and a positive quantity. +genValueForTxOut :: Gen Value +genValueForTxOut = genValue genAssetId genUnsignedQuantity + +genTxOutValue :: CardanoEra era -> Gen (TxOutValue era) +genTxOutValue era = + case multiAssetSupportedInEra era of + Left adaOnlyInEra -> TxOutAdaOnly adaOnlyInEra <$> genLovelace + Right multiAssetInEra -> TxOutValue multiAssetInEra <$> genValueForTxOut + +genTxOut :: CardanoEra era -> Gen (TxOut era) +genTxOut era = + TxOut <$> genAddressInEra era + <*> genTxOutValue era + <*> genTxOutDatumHash era + +genTxOutDatumHash :: CardanoEra era -> Gen (TxOutDatumHash era) +genTxOutDatumHash era = + case scriptDataSupportedInEra era of + Nothing -> pure TxOutDatumHashNone + Just supported -> oneof + [ pure TxOutDatumHashNone + , TxOutDatumHash supported <$> genHashScriptData + ] + +mkDummyHash :: forall h a. Crypto.HashAlgorithm h => Int -> Crypto.Hash h a +mkDummyHash = coerce . Crypto.hashWithSerialiser @h CBOR.toCBOR + +genHashScriptData :: Gen (Cardano.Api.Hash ScriptData) +genHashScriptData = + ScriptDataHash . unsafeMakeSafeHash . mkDummyHash + <$> (scale (`mod` 10) arbitrary) diff --git a/lib/core/test/unit/Cardano/Api/GenSpec.hs b/lib/core/test/unit/Cardano/Api/GenSpec.hs index 0973a5cc4a0..ac04178d4a1 100644 --- a/lib/core/test/unit/Cardano/Api/GenSpec.hs +++ b/lib/core/test/unit/Cardano/Api/GenSpec.hs @@ -16,6 +16,7 @@ import Cardano.Api , AssetName (..) , BuildTx , CardanoEra (..) + , CardanoEraStyle (..) , ExecutionUnits (..) , KeyWitnessInCtx (..) , Lovelace @@ -39,6 +40,9 @@ import Cardano.Api , TxMetadataInEra (..) , TxMetadataValue (..) , TxMintValue (..) + , TxOut (..) + , TxOutDatumHash (..) + , TxOutValue (..) , TxScriptValidity (..) , TxValidityLowerBound (..) , TxValidityUpperBound (..) @@ -47,9 +51,11 @@ import Cardano.Api , WitCtxStake , Witness (..) , auxScriptsSupportedInEra + , cardanoEraStyle , collateralSupportedInEra , extraKeyWitnessesSupportedInEra , multiAssetSupportedInEra + , scriptDataSupportedInEra , scriptLanguageSupportedInEra , txFeesExplicitInEra , txMetadataSupportedInEra @@ -403,23 +409,92 @@ spec = describe "genAddressInEra" $ do it "genAddressInEra ByronEra" $ property $ forAll - (genAddressInEra ByronEra) genAddressInByronEraCoverage + (genAddressInEra ByronEra) + (genAddressInEraCoverage ByronEra) it "genAddressInEra ShelleyEra" $ property $ forAll (genAddressInEra ShelleyEra) - genAddressInShelleyBasedEraCoverage + (genAddressInEraCoverage ShelleyEra) it "genAddressInEra AllegraEra" $ property $ forAll (genAddressInEra AllegraEra) - genAddressInShelleyBasedEraCoverage + (genAddressInEraCoverage AllegraEra) it "genAddressInEra MaryEra" $ property $ forAll (genAddressInEra MaryEra) - genAddressInShelleyBasedEraCoverage + (genAddressInEraCoverage MaryEra) it "genAddressInEra AlonzoEra" $ property $ forAll (genAddressInEra AlonzoEra) - genAddressInShelleyBasedEraCoverage + (genAddressInEraCoverage AlonzoEra) + it "genUnsignedQuantity" $ + property $ + forAll genUnsignedQuantity genUnsignedQuantityCoverage + it "genValueForTxOutCoverage" $ + property $ forAll genValueForTxOut genValueForTxOutCoverage + describe "genTxOutDatumHash" $ do + it "genTxOutDatumHash ByronEra" $ + property $ forAll + (genTxOutDatumHash ByronEra) + (genTxOutDatumHashCoverage ByronEra) + it "genTxOutDatumHash ShelleyEra" $ + property $ forAll + (genTxOutDatumHash ShelleyEra) + (genTxOutDatumHashCoverage ShelleyEra) + it "genTxOutDatumHash AllegraEra" $ + property $ forAll + (genTxOutDatumHash AllegraEra) + (genTxOutDatumHashCoverage AllegraEra) + it "genTxOutDatumHash MaryEra" $ + property $ forAll + (genTxOutDatumHash MaryEra) + (genTxOutDatumHashCoverage MaryEra) + it "genTxOutDatumHash AlonzoEra" $ + property $ forAll + (genTxOutDatumHash AlonzoEra) + (genTxOutDatumHashCoverage AlonzoEra) + describe "genTxOutValue" $ do + it "genTxOutValue ByronEra" $ + property $ forAll + (genTxOutValue ByronEra) + (genTxOutValueCoverage ByronEra) + it "genTxOutValue ShelleyEra" $ + property $ forAll + (genTxOutValue ShelleyEra) + (genTxOutValueCoverage ShelleyEra) + it "genTxOutValue AllegraEra" $ + property $ forAll + (genTxOutValue AllegraEra) + (genTxOutValueCoverage AllegraEra) + it "genTxOutValue MaryEra" $ + property $ forAll + (genTxOutValue MaryEra) + (genTxOutValueCoverage MaryEra) + it "genTxOutValue AlonzoEra" $ + property $ forAll + (genTxOutValue AlonzoEra) + (genTxOutValueCoverage AlonzoEra) + describe "genTxOut" $ do + it "genTxOut ByronEra" $ + property $ forAll + (genTxOut ByronEra) + (genTxOutCoverage ByronEra) + it "genTxOut ShelleyEra" $ + property $ forAll + (genTxOut ShelleyEra) + (genTxOutCoverage ShelleyEra) + it "genTxOut AllegraEra" $ + property $ forAll + (genTxOut AllegraEra) + (genTxOutCoverage AllegraEra) + it "genTxOut MaryEra" $ + property $ forAll + (genTxOut MaryEra) + (genTxOutCoverage MaryEra) + it "genTxOut AlonzoEra" $ + property $ forAll + (genTxOut AlonzoEra) + (genTxOutCoverage AlonzoEra) genTxIxCoverage :: TxIx -> Property genTxIxCoverage (TxIx ix) = unsignedCoverage (Proxy @Word32) "txIx" ix @@ -1178,23 +1253,24 @@ genPaymentCredentialCoverage paymentCred = checkCoverage instance Arbitrary PaymentCredential where arbitrary = genPaymentCredential -genAddressInByronEraCoverage :: AddressInEra era -> Property -genAddressInByronEraCoverage addr = - label "in Byron era, always generate byron addresses" - $ case addr of - AddressInEra ByronAddressInAnyEra _addr -> - True - _ -> - False - & counterexample "Non-Byron address was generated in Byron era" - -genAddressInShelleyBasedEraCoverage :: AddressInEra era -> Property -genAddressInShelleyBasedEraCoverage addr = checkCoverage - $ cover 10 (isByronAddress addr) - "byron address" - $ cover 10 (isShelleyAddress addr) - "shelley address" - True +genAddressInEraCoverage + :: CardanoEra era + -> AddressInEra era + -> Property +genAddressInEraCoverage era addr = + case cardanoEraStyle era of + LegacyByronEra -> + if isByronAddress addr + then True + & label "in Byron era, always generate byron addresses" + else False + & counterexample "Non-Byron address was generated in Byron era" + ShelleyBasedEra _era -> checkCoverage + $ cover 10 (isByronAddress addr) + "byron address" + $ cover 10 (isShelleyAddress addr) + "shelley address" + True where isByronAddress = \case @@ -1204,6 +1280,74 @@ genAddressInShelleyBasedEraCoverage addr = checkCoverage AddressInEra (ShelleyAddressInEra _era) _addr -> True _ -> False +genUnsignedQuantityCoverage :: Quantity -> Property +genUnsignedQuantityCoverage = + unsignedCoverage (Proxy @Word32) "unsigned quantity" + +genValueForTxOutCoverage :: Value -> Property +genValueForTxOutCoverage val = + let + valList = valueToList val + in + checkCoverage + $ cover 1 (null valList) + "Value has no assets" + $ cover 10 (not $ null valList) + "Value has some assets" + $ cover 10 (length valList >= 3) + "Value has more assets" + True + +genTxOutDatumHashCoverage + :: CardanoEra era -> TxOutDatumHash era -> Property +genTxOutDatumHashCoverage era datum = + case scriptDataSupportedInEra era of + Nothing -> + (datum == TxOutDatumHashNone) + & label "tx out datums not generated in unsupported era" + & counterexample ( "tx out datums were generated in unsupported " + <> show era + ) + Just _ -> checkCoverage + $ cover 30 (hasNoDatumHash datum) + "no tx out datum hash" + $ cover 30 (hasDatumHash datum) + "tx out datum hash present" + True + where + hasNoDatumHash = (== TxOutDatumHashNone) + + hasDatumHash = \case + TxOutDatumHashNone -> False + (TxOutDatumHash _ _) -> True + +genTxOutValueCoverage :: CardanoEra era -> TxOutValue era -> Property +genTxOutValueCoverage era val = + case multiAssetSupportedInEra era of + Left _ -> + case val of + (TxOutAdaOnly _ l) -> + genLovelaceCoverage l + & label ("ADA only supported in " <> show era) + _ -> + property False + & counterexample (show era <> " should only support ADA") + Right _ -> + case val of + (TxOutValue _ value) -> + genValueForTxOutCoverage value + & label ("Multi-asset supported in " <> show era) + _ -> + property False + & counterexample (show era <> " should support multi-asset") + +genTxOutCoverage :: CardanoEra era -> TxOut era -> Property +genTxOutCoverage era (TxOut addr val datum) = conjoin + [ genAddressInEraCoverage era addr + , genTxOutValueCoverage era val + , genTxOutDatumHashCoverage era datum + ] + -- | Provide coverage for an unsigned number. unsignedCoverage :: ( Num a