Mary minimal property tests

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

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)

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

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))

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