diff --git a/shelley-ma/shelley-ma-test/src/Test/Cardano/Ledger/Allegra.hs b/shelley-ma/shelley-ma-test/src/Test/Cardano/Ledger/Allegra.hs index 6963c9d8d17..d5e25d38d0d 100644 --- a/shelley-ma/shelley-ma-test/src/Test/Cardano/Ledger/Allegra.hs +++ b/shelley-ma/shelley-ma-test/src/Test/Cardano/Ledger/Allegra.hs @@ -95,21 +95,23 @@ genTxBody :: Coin -> StrictMaybe (Update era) -> StrictMaybe (AuxiliaryDataHash (Crypto era)) -> - Gen (TxBody era) + Gen (TxBody era, [Timelock (Crypto era)]) genTxBody slot ins outs cert wdrl fee upd ad = do validityInterval <- genValidityInterval slot let mint = zero -- the mint field is always empty for an Allegra TxBody pure $ - TxBody - ins - outs - cert - wdrl - fee - validityInterval - upd - ad - mint + ( TxBody + ins + outs + cert + wdrl + fee + validityInterval + upd + ad + mint, + [] -- Allegra does not need any additional script witnesses + ) {------------------------------------------------------------------------------ ShelleyMA helpers, shared by Allegra and Mary diff --git a/shelley-ma/shelley-ma-test/src/Test/Cardano/Ledger/Mary.hs b/shelley-ma/shelley-ma-test/src/Test/Cardano/Ledger/Mary.hs index b4cbc7f57b6..9cdffbc9f4e 100644 --- a/shelley-ma/shelley-ma-test/src/Test/Cardano/Ledger/Mary.hs +++ b/shelley-ma/shelley-ma-test/src/Test/Cardano/Ledger/Mary.hs @@ -12,20 +12,30 @@ module Test.Cardano.Ledger.Mary () where -- export the EraGen instance for MaryEra import Cardano.Ledger.AuxiliaryData (AuxiliaryDataHash) +import qualified Cardano.Ledger.Core as Core (AuxiliaryData, Value) import qualified Cardano.Ledger.Crypto as CryptoClass import Cardano.Ledger.Era (Crypto) -import Cardano.Ledger.Mary.Value (Value (..)) +import Cardano.Ledger.Mary.Value + ( AssetName (..), + PolicyID (..), + Value (..), + policies, + ) import Cardano.Ledger.Shelley.Constraints (UsesAuxiliary, UsesValue) import Cardano.Ledger.ShelleyMA.Timelocks (Timelock (..)) import Cardano.Ledger.ShelleyMA.TxBody (StrictMaybe, TxBody (..)) import qualified Cardano.Ledger.Val as Val import Cardano.Slotting.Slot (SlotNo) +import qualified Data.ByteString.Char8 as BS +import Data.Map (Map) import qualified Data.Map as Map -import Data.Sequence.Strict (StrictSeq) +import Data.Sequence.Strict (StrictSeq (..), (<|)) +import qualified Data.Sequence.Strict as StrictSeq import qualified Data.Set as Set +import Shelley.Spec.Ledger.BaseTypes (StrictMaybe (..)) import Shelley.Spec.Ledger.Coin (Coin (..)) import Shelley.Spec.Ledger.PParams (Update) -import Shelley.Spec.Ledger.Tx (TxIn, TxOut) +import Shelley.Spec.Ledger.Tx (TxIn, TxOut (..), hashScript) import Shelley.Spec.Ledger.TxBody (DCert, Wdrl) import Test.Cardano.Ledger.Allegra ( genValidityInterval, @@ -34,10 +44,11 @@ import Test.Cardano.Ledger.Allegra unQuantifyTL, ) import Test.Cardano.Ledger.EraBuffet (MaryEra) -import Test.QuickCheck (Gen) +import Test.QuickCheck (Gen, arbitrary, frequency) +import qualified Test.QuickCheck as QC import Test.Shelley.Spec.Ledger.ConcreteCryptoTypes (Mock) import Test.Shelley.Spec.Ledger.Generator.Constants (Constants (..)) -import Test.Shelley.Spec.Ledger.Generator.Core (GenEnv (..)) +import Test.Shelley.Spec.Ledger.Generator.Core (GenEnv (..), genInteger) import Test.Shelley.Spec.Ledger.Generator.EraGen (EraGen (..)) import Test.Shelley.Spec.Ledger.Generator.ScriptClass ( ScriptClass (..), @@ -67,13 +78,167 @@ instance (CryptoClass.Crypto c, Mock c) => EraGen (MaryEra c) where genGenesisValue (GenEnv _ Constants {minGenesisOutputVal, maxGenesisOutputVal}) = Val.inject . Coin <$> exponential minGenesisOutputVal maxGenesisOutputVal genEraTxBody _ge = genTxBody - genEraAuxiliaryData = error "TODO @uroboros - implement genAuxiliaryData for Mary" - updateEraTxBody (TxBody _in _out cert wdrl _txfee vi upd meta forge) fee ins outs = - TxBody ins outs cert wdrl fee vi upd meta forge + genEraAuxiliaryData = genAuxiliaryData + updateEraTxBody (TxBody _in _out cert wdrl _txfee vi upd meta mint) fee ins outs = + TxBody ins outs cert wdrl fee vi upd meta mint + +genAuxiliaryData :: + Mock crypto => + Constants -> + Gen (StrictMaybe (Core.AuxiliaryData (MaryEra crypto))) +genAuxiliaryData Constants {frequencyTxWithMetadata} = + frequency + [ (frequencyTxWithMetadata, SJust <$> arbitrary), + (100 - frequencyTxWithMetadata, pure SNothing) + ] + +-------------------------------------------------------- +-- Permissionless Tokens -- +-- -- +-- We introduce three token bundles, each which has a -- +-- permissionless minting policy and each which has a -- +-- different minting behavior (use of asset names). -- +-------------------------------------------------------- + +-- | An infinite indexed collection of trivial policies. +-- They are trivial in the sense that they require no +-- signature and can be submitted at any time. +trivialPolicy :: CryptoClass.Crypto c => Int -> Timelock c +trivialPolicy i | i == 0 = RequireAllOf (StrictSeq.fromList []) +trivialPolicy i | otherwise = RequireAllOf (StrictSeq.fromList [trivialPolicy (i -1)]) + +-------------------------------------------------------- +-- Red Coins -- +-- -- +-- These tokens are always minted with the same asset -- +-- name, "red". -- +-------------------------------------------------------- + +redCoins :: CryptoClass.Crypto c => Timelock c +redCoins = trivialPolicy 0 + +redCoinId :: forall c. CryptoClass.Crypto c => PolicyID c +redCoinId = PolicyID $ hashScript @(MaryEra c) redCoins + +red :: AssetName +red = AssetName $ BS.pack "redCoin" + +genRed :: CryptoClass.Crypto c => Gen (Value c) +genRed = do + n <- genInteger 1 1000000 + pure $ Value 0 (Map.singleton redCoinId (Map.singleton red n)) + +-------------------------------------------------------- +-- Blue Coins -- +-- -- +-- These tokens are (nearly) always minted with a new -- +-- asset name. +-------------------------------------------------------- + +blueCoins :: CryptoClass.Crypto c => Timelock c +blueCoins = trivialPolicy 1 + +blueCoinId :: forall c. CryptoClass.Crypto c => PolicyID c +blueCoinId = PolicyID $ hashScript @(MaryEra c) blueCoins + +maxBlueMint :: Int +maxBlueMint = 10 + +genBlue :: CryptoClass.Crypto c => Gen (Value c) +genBlue = do + as <- QC.resize maxBlueMint $ QC.listOf genSingleBlue + -- the transaction size gets too big if we mint too many assets + pure $ Value 0 (Map.singleton blueCoinId (Map.fromList as)) + where + genSingleBlue = do + n <- genInteger 1 1000000 + a <- arbitrary + pure $ (AssetName a, n) + +-------------------------------------------------------- +-- Yellow Coins -- +-- -- +-- These tokens are minted with a small variety of -- +-- asset names. -- +-------------------------------------------------------- + +yellowCoins :: CryptoClass.Crypto c => Timelock c +yellowCoins = trivialPolicy 2 + +yellowCoinId :: forall c. CryptoClass.Crypto c => PolicyID c +yellowCoinId = PolicyID $ hashScript @(MaryEra c) yellowCoins + +yellowNumAssets :: Int +yellowNumAssets = 5 + +genYellow :: CryptoClass.Crypto c => Gen (Value c) +genYellow = do + xs <- QC.sublistOf [0 .. yellowNumAssets] + as <- mapM genSingleYellow xs + pure $ Value 0 (Map.singleton yellowCoinId (Map.fromList as)) + where + genSingleYellow x = do + y <- genInteger 1 1000000 + let an = AssetName . BS.pack $ "yellow" <> show x + pure $ (an, y) + +-- | This map allows us to lookup a minting policy by the policy ID. +policyIndex :: CryptoClass.Crypto c => Map (PolicyID c) (Timelock c) +policyIndex = + Map.fromList + [ (redCoinId, redCoins), + (blueCoinId, blueCoins), + (yellowCoinId, yellowCoins) + ] + +-------------------------------------------------------- +-- Minting Frequencies -- +-- -- +-- The frequencies represent a percent chance of any -- +-- given transaction to mint one of the three token -- +-- bundles. -- +-------------------------------------------------------- + +redFreq :: Int +redFreq = 30 + +blueFreq :: Int +blueFreq = 5 + +yellowFreq :: Int +yellowFreq = 50 + +genBundle :: Int -> Gen (Value c) -> Gen (Value c) +genBundle freq g = QC.frequency [(freq, g), (100 - freq, pure mempty)] + +genMint :: CryptoClass.Crypto c => Gen (Value c) +genMint = do + r <- genBundle redFreq genRed + b <- genBundle blueFreq genBlue + y <- genBundle yellowFreq genYellow + pure $ r <> b <> y + +------------------------------- +-- END Permissionless Tokens -- +------------------------------- + +-- | Add tokens to a non-empty list of transaction outputs. +-- NOTE: this function will raise an error if given an empty sequence. +addTokensToFirstOutput :: + ( Core.Value era ~ Value (Crypto era), + EraGen era + ) => + Value (Crypto era) -> + StrictSeq (TxOut era) -> + StrictSeq (TxOut era) +addTokensToFirstOutput ts ((TxOut a v) :<| os) = TxOut a (v <> ts) <| os +addTokensToFirstOutput _ StrictSeq.Empty = + error "addTokensToFirstOutput was given an empty sequence" genTxBody :: forall era. ( UsesValue era, + Core.Value era ~ Value (Crypto era), UsesAuxiliary era, EraGen era ) => @@ -85,21 +250,25 @@ genTxBody :: Coin -> StrictMaybe (Update era) -> StrictMaybe (AuxiliaryDataHash (Crypto era)) -> - Gen (TxBody era) + Gen (TxBody era, [Timelock (Crypto era)]) genTxBody slot ins outs cert wdrl fee upd meta = do validityInterval <- genValidityInterval slot - let mint = error "TODO @uroboros mint some Mary era tokens" + mint <- genMint + let outs' = addTokensToFirstOutput (mint) outs + ps = map (\p -> (Map.!) policyIndex p) (Set.toList $ policies mint) pure $ - TxBody - ins - outs - cert - wdrl - fee - validityInterval - upd - meta - mint + ( TxBody + ins + outs' + cert + wdrl + fee + validityInterval + upd + meta + mint, + ps -- These additional scripts are for the minting policies. + ) instance Split (Value era) where vsplit (Value n _) 0 = ([], Coin n) diff --git a/shelley-ma/shelley-ma-test/test/Tests.hs b/shelley-ma/shelley-ma-test/test/Tests.hs index 6d73baf6437..168a7a019ed 100644 --- a/shelley-ma/shelley-ma-test/test/Tests.hs +++ b/shelley-ma/shelley-ma-test/test/Tests.hs @@ -4,11 +4,12 @@ module Main where import Test.Cardano.Ledger.Allegra () +import Test.Cardano.Ledger.Allegra.ScriptTranslation (testScriptPostTranslation) import Test.Cardano.Ledger.Allegra.Translation (allegraTranslationTests) -import Test.Cardano.Ledger.EraBuffet (AllegraEra, TestCrypto) +import Test.Cardano.Ledger.EraBuffet (AllegraEra, MaryEra, TestCrypto) +import Test.Cardano.Ledger.Mary () import Test.Cardano.Ledger.Mary.Examples.MultiAssets (multiAssetsExample) import Test.Cardano.Ledger.Mary.Translation (maryTranslationTests) -import Test.Cardano.Ledger.Allegra.ScriptTranslation (testScriptPostTranslation) import Test.Cardano.Ledger.Mary.Value (valTests) import qualified Test.Cardano.Ledger.ShelleyMA.Serialisation as Serialisation import Test.Shelley.Spec.Ledger.PropertyTests (minimalPropertyTests, propertyTests) @@ -56,7 +57,8 @@ nightlyTests :: TestTree nightlyTests = testGroup "ShelleyMA Ledger - nightly" - [ propertyTests @(AllegraEra TestCrypto) + [ propertyTests @(AllegraEra TestCrypto), + minimalPropertyTests @(MaryEra TestCrypto) ] -- main entry point 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 287934a1ff4..16904c0ba21 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 @@ -64,7 +64,9 @@ class -- | Generate a genesis value for the Era genGenesisValue :: GenEnv era -> Gen (Core.Value era) - -- | Given some pre-generated data, generate an era-specific TxBody + -- | Given some pre-generated data, generate an era-specific TxBody, + -- and a list of additional scripts for eras that sometimes require + -- additional script witnessing. genEraTxBody :: GenEnv era -> SlotNo -> @@ -75,7 +77,7 @@ class Coin -> StrictMaybe (Update era) -> StrictMaybe (AuxiliaryDataHash (Crypto era)) -> - Gen (Core.TxBody era) + Gen (Core.TxBody era, [Core.Script era]) -- | Generate era-specific auxiliary data genEraAuxiliaryData :: Constants -> Gen (StrictMaybe (Core.AuxiliaryData era)) diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/ShelleyEraGen.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/ShelleyEraGen.hs index 7c8e5bb31b0..4b849aac94b 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/ShelleyEraGen.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/ShelleyEraGen.hs @@ -106,19 +106,21 @@ genTxBody :: Coin -> StrictMaybe (Update era) -> StrictMaybe (AuxiliaryDataHash (Crypto era)) -> - Gen (TxBody era) + Gen (TxBody era, [MultiSig (Crypto era)]) genTxBody slot inputs outputs certs wdrls fee update adHash = do ttl <- genTimeToLive slot - return $ - TxBody - inputs - outputs - certs - wdrls - fee - ttl - update - adHash + return + ( TxBody + inputs + outputs + certs + wdrls + fee + ttl + update + adHash, + [] -- Shelley does not need any additional script witnesses + ) genTimeToLive :: SlotNo -> Gen SlotNo genTimeToLive currentSlot = do 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 caad35eff2d..8399065b311 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 @@ -29,7 +29,7 @@ import Cardano.Ledger.Shelley.Constraints UsesScript, UsesTxBody, UsesTxOut (..), - UsesValue + UsesValue, ) import Cardano.Ledger.Val (Val (..), sumVal, (<+>), (<->), (<×>)) import Control.Monad (when) @@ -271,7 +271,7 @@ genTx spendingBalance outputAddrs draftFee - draftTxBody <- + (draftTxBody, additionalScripts) <- genEraTxBody ge slot @@ -283,11 +283,12 @@ genTx (maybeToStrictMaybe update) (hashAuxiliaryData @era <$> metadata) let draftTx = Tx draftTxBody (mkTxWits' draftTxBody) metadata + scripts' = Map.fromList $ map (\s -> (hashScript @era s, s)) additionalScripts -- We add now repeatedly add inputs until the process converges. converge remainderCoin wits - scripts + (scripts `Map.union` scripts') ksKeyPairs ksMSigScripts utxo @@ -323,7 +324,11 @@ deltaZero :: ( UsesScript era, UsesValue era, UsesTxOut era - ) => Coin -> Coin -> Addr (Crypto era) -> Delta era + ) => + Coin -> + Coin -> + Addr (Crypto era) -> + Delta era deltaZero initialfee minAda addr = Delta (initialfee <-> minAda) @@ -368,6 +373,7 @@ genNextDelta draftSize = sum [ 5 :: Integer, -- safety net in case the coin or a list prefix rolls over into a larger encoding + 12 :: Integer, -- TODO the size calculation somehow needs extra buffer when minting tokens encodedLen (max dfees (Coin 0)) - 1, foldr (\a b -> b + encodedLen a) 0 extraInputs, encodedLen change, @@ -551,6 +557,7 @@ converge -- | Return up to /k/ random elements from /items/ -- (instead of the less efficient /take k <$> QC.shuffle items/) ruffle :: Int -> [a] -> Gen [a] +ruffle _ [] = pure [] ruffle k items = do indices <- nub <$> QC.vectorOf k pickIndex pure $ map (items !!) indices @@ -642,7 +649,7 @@ calcOutputsFromBalance :: (Coin, StrictSeq (Core.TxOut era)) calcOutputsFromBalance balance_ addrs fee = ( fee <+> splitCoinRem, - StrictSeq.fromList $ zipWith (makeTxOut $ Proxy @era)addrs amountPerOutput + StrictSeq.fromList $ zipWith (makeTxOut $ Proxy @era) addrs amountPerOutput ) where -- split the available balance into equal portions (one for each address),