Add integration test for large asset counts

To ensure that our calculation matches the one of the ledger.

See
#2552 (comment)

for what it helped catch.

lib/core-integration/src/Test/Integration/Faucet.hs

@@ -20,9 +20,14 @@ module Test.Integration.Faucet
     , mirMnemonics
     , maMnemonics
 
+    -- * Sea horses
+    , seaHorseTokenName
+    , seaHorsePolicyId
+
       -- * Integration test funds
     , shelleyIntegrationTestFunds
     , maryIntegrationTestAssets
+    , seaHorseTestAssets
 
       -- * Internals
     , genByronFaucets
@@ -93,6 +98,7 @@ import qualified Cardano.Wallet.Primitive.AddressDerivation.Byron as Byron
 import qualified Cardano.Wallet.Primitive.AddressDerivation.Icarus as Icarus
 import qualified Cardano.Wallet.Primitive.AddressDerivation.Shelley as Shelley
 import qualified Cardano.Wallet.Primitive.Types.TokenBundle as TokenBundle
+import qualified Data.ByteString.Char8 as B8
 import qualified Data.List.NonEmpty as NE
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as T
@@ -2128,7 +2134,7 @@ bigDustWallet = unsafeMkMnemonic
 
 shelleyIntegrationTestFunds :: [(Address, Coin)]
 shelleyIntegrationTestFunds = mconcat
-    [ seqMnemonics >>= (take 10 . map (, defaultAmt) . addresses . SomeMnemonic)
+    [ seqMnemonics >>= take 10 . map (, defaultAmt) . addresses . SomeMnemonic
 
     , zip
          (addresses $ SomeMnemonic onlyDustWallet)
@@ -2189,9 +2195,6 @@ maryAssetScripts = map (first (unsafeFromText . T.pack))
     , ( "b3579e6306a5b3f49ba91ed4c5fd79dbe92d54867433ff6f92d47b40"
       , ( "58209e1caa45500051163e03176099f53dd85aff98331d6fc2c857226d6c406fe2dc"
         , "31fe7edd49aaca7982a28cfb917f8af01b9c1088bff300b1bc784f03" ) )
-    , ( "4ff049585c4b3070563966370f5427d4a2f3588bce4146d57a93c7d3"
-      , ( "582082a0d2af81ca0528387c37823706507478cead44f0250661542cdc5619ecaead"
-        , "452bbda4110154506faaddbbdf366e4db088e963a3f56e98832b3332" ) )
     , ( "e9f14eb5a8c5c4b70d7e41ba16b833396191bee9fb3966ccd0d012f8"
       , ( "5820e58c10bac5b4cbc984524a92576fad307fa8d53da4f408abd8ee8c1d3d0e9daf"
         , "84f25deb23ec4ebaa20998fdb9db5aa91d46938c1a5a5efa35766e30" ) )
@@ -2239,6 +2242,51 @@ maryIntegrationTestAssets = maMnemonics >>= take 3
         ]
     combined p = simple p `TokenBundle.add` fruit p
 
+-- Assets containing 120 different SeaHorses. Same policyId, but all different.
+--
+-- This is for testing with large token bundles / asset counts.
+--
+-- This is a separate defenition from maryIntegrationTestAssets to allow minting
+-- only 1 bundle per transaction without going over the maximum size
+-- (as we do want them as large as possible).
+seaHorseTestAssets
+    :: Int
+    -> [Address]
+    -> [(Address, (TokenBundle, [(String, String)]))]
+seaHorseTestAssets nPerAddr addrs = zip addrs $
+    map
+        (\is -> mint (seaHorse is) seaHorseAssetScript)
+        (chunks nPerAddr [1..])
+  where
+    mint mk (pid, info) = (mk pid, [info])
+    seaHorse is p = bundle p $ flip map is $ \i ->
+        (seaHorseTokenName i, TokenQuantity 1)
+    bundle p assets = TokenBundle.fromNestedList
+        (Coin 1000_000_000)
+        [(p, NE.fromList assets)]
+
+seaHorsePolicyId :: TokenPolicyId
+seaHorsePolicyId = fst seaHorseAssetScript
+
+-- | A pre-generated policy ID, paired with
+-- @(signing key, verification key hash)@ .
+seaHorseAssetScript :: (TokenPolicyId, (String, String))
+seaHorseAssetScript = first (unsafeFromText . T.pack)
+    ( "4ff049585c4b3070563966370f5427d4a2f3588bce4146d57a93c7d3"
+      , ( "582082a0d2af81ca0528387c37823706507478cead44f0250661542cdc5619ecaead"
+        , "452bbda4110154506faaddbbdf366e4db088e963a3f56e98832b3332" ) )
+
+seaHorseTokenName :: Int -> TokenName
+seaHorseTokenName i = UnsafeTokenName $
+    B8.pack $ "00000000000000000SeaHorse" <> show i
+
+-- https://stackoverflow.com/questions/12876384/grouping-a-list-into-lists-of-n-elements-in-haskell
+chunks :: Int -> [a] -> [[a]]
+chunks _ [] = []
+chunks n xs =
+    let (ys, zs) = splitAt n xs
+    in  ys : chunks n zs
+
 --
 -- Helpers
 --

lib/core-integration/src/Test/Integration/Framework/Context.hs

@@ -15,6 +15,8 @@ import Cardano.Wallet.Api.Types
     ( ApiEra )
 import Cardano.Wallet.Primitive.Types
     ( EpochNo, NetworkParameters, PoolRetirementCertificate )
+import Cardano.Wallet.Primitive.Types.Address
+    ( Address )
 import Cardano.Wallet.Transaction
     ( DelegationAction )
 import Data.IORef
@@ -59,6 +61,12 @@ data Context = Context
         -- era-specific assertions.
     , _smashUrl :: Text
         -- ^ Base URL of the mock smash server.
+
+    , _mintSeaHorseAssets :: Int -> [Address] -> IO ()
+        -- ^ TODO: Remove once we can unify cardano-wallet-core-integration and
+        -- cardano-wallet:integration, or when the wallet supports minting.
+        --
+        -- Cannot be used be serveral tests at a time. (!)
     }
     deriving Generic
 

lib/core-integration/src/Test/Integration/Scenario/API/Shelley/Transactions.hs

@@ -7,6 +7,7 @@
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 
@@ -55,7 +56,7 @@ import Cardano.Wallet.Primitive.Types.Tx
 import Cardano.Wallet.Unsafe
     ( unsafeFromText )
 import Control.Monad
-    ( forM_ )
+    ( forM, forM_ )
 import Control.Monad.IO.Unlift
     ( MonadIO (..), MonadUnliftIO (..), liftIO )
 import Control.Monad.Trans.Resource
@@ -100,8 +101,10 @@ import Test.Hspec.Expectations.Lifted
     ( expectationFailure, shouldBe, shouldNotBe, shouldSatisfy )
 import Test.Hspec.Extra
     ( flakyBecauseOf, it )
+import Test.Integration.Faucet
+    ( seaHorsePolicyId, seaHorseTokenName )
 import Test.Integration.Framework.DSL
-    ( Context
+    ( Context (_mintSeaHorseAssets)
     , Headers (..)
     , Payload (..)
     , between
@@ -146,6 +149,7 @@ import Test.Integration.Framework.DSL
     , unsafeRequest
     , utcIso8601ToText
     , verify
+    , waitForTxImmutability
     , walletId
     , (.<)
     , (.<=)
@@ -715,6 +719,56 @@ spec = describe "SHELLEY_TRANSACTIONS" $ do
                 , expectField (#assets . #total . #getApiT) (`shouldNotBe` TokenMap.empty)
                 ]
 
+    it "TRANS_ASSETS_CREATE_02c - Send SeaHorses" $ \ctx -> runResourceT $ do
+            -- Notes on the style of this test:
+            -- - By doing the minting here it is easier to control, and tweak
+            -- the values.
+            -- - The current _mintSeaHorseAssets cannot be called concurrently
+            -- - By grouping the setup of multiple wallets in a single test, we
+            -- gain some time.
+
+            -- 1. Setup by minting funds
+            let assetsPerAddrScenarios = [64 .. 70]
+            sourceWallets <- forM assetsPerAddrScenarios $ \nAssetsPerAddr -> do
+                wSrc <- fixtureWallet ctx
+                srcAddrs <-
+                    map (getApiT . fst . view #id) <$> listAddresses @n ctx wSrc
+                liftIO $ _mintSeaHorseAssets ctx nAssetsPerAddr (take 2 srcAddrs)
+                return (wSrc, nAssetsPerAddr)
+            wDest <- emptyWallet ctx
+            destAddr <- head . map (view #id) <$> listAddresses @n ctx wDest
+            waitForTxImmutability ctx
+
+            -- 2. Try spending from each wallet, and record the response.
+            responses <- forM sourceWallets $ \(wSrc, nPerAddr) -> do
+                let seaHorses = map $ \ix ->
+                        (( toText seaHorsePolicyId
+                        , toText $ seaHorseTokenName ix)
+                        , 1)
+                payload <- mkTxPayloadMA @n
+                    destAddr
+                    0
+                    (seaHorses [1, nPerAddr * 2])
+                    -- Send one token from our first bundle, and one token from
+                    -- our second bundle, to ensure the change output is large.
+                    fixturePassphrase
+
+                let verifyRes r = case r of
+                        (s, Right _)
+                            | s == HTTP.status202 -> Right ()
+                            | otherwise           -> Left $ mconcat
+                                [ "impossible: request succeeded, but got "
+                                , "status code "
+                                , show s
+                                ]
+                        (_, Left e) -> Left $ show e
+
+                (nPerAddr,) . verifyRes <$> request @(ApiTransaction n) ctx
+                    (Link.createTransaction @'Shelley wSrc) Default payload
+
+            -- 3. They should all succeed
+            responses `shouldBe` (map (, Right ()) assetsPerAddrScenarios)
+
     let hasAssetOutputs :: [AddressAmount (ApiT Address, Proxy n)] -> Bool
         hasAssetOutputs = any ((/= mempty) . view #assets)
 

lib/shelley/bench/Latency.hs

@@ -397,6 +397,7 @@ withShelleyServer tracers action = do
                     error "poolGarbageCollectionEvents not available"
                 , _smashUrl = ""
                 , _mainEra = maxBound
+                , _mintSeaHorseAssets = error "mintSeaHorseAssets not available"
                 }
     race_ (takeMVar ctx >>= action) (withServer setupContext)
 

lib/shelley/exe/local-cluster.hs

@@ -231,7 +231,7 @@ main = withLocalClusterSetup $ \dir clusterLogs walletLogs ->
 
         sendFaucetFundsTo trCluster' socketPath dir $
             encodeAddresses shelleyIntegrationTestFunds
-        sendFaucetAssetsTo trCluster' socketPath dir $
+        sendFaucetAssetsTo trCluster' socketPath dir 20 $
             encodeAddresses maryIntegrationTestAssets
         moveInstantaneousRewardsTo trCluster' socketPath dir rewards
 

lib/shelley/src/Cardano/Wallet/Shelley/Launch/Cluster.hs

@@ -1249,12 +1249,13 @@ sendFaucetAssetsTo
     :: Tracer IO ClusterLog
     -> CardanoNodeConn
     -> FilePath
+    -> Int -- ^ batch size
     -> [(String, (TokenBundle, [(String, String)]))] -- ^ (address, assets)
     -> IO ()
-sendFaucetAssetsTo tr conn dir targets = do
+sendFaucetAssetsTo tr conn dir batchSize targets = do
     era <- getClusterEra dir
     when (era >= MaryHardFork) $
-        batch 20 targets $ sendFaucet tr conn dir "assets"
+        batch batchSize targets $ sendFaucet tr conn dir "assets"
 
 -- | Build, sign, and send a batch of faucet funding transactions using
 -- @cardano-cli@. This function is used by 'sendFaucetFundsTo' and

lib/shelley/test/data/cardano-node-shelley/shelley-genesis.yaml

@@ -16,7 +16,7 @@ protocolParams:
     major: 0
   minUTxOValue: 1000000
   decentralisationParam: 0.25 # means 75% decentralised
-  maxTxSize: 4096
+  maxTxSize: 16384
   minFeeA: 100
   maxBlockBodySize: 239857
   minFeeB: 100000

lib/shelley/test/integration/Main.hs

@@ -122,6 +122,7 @@ import Test.Integration.Faucet
     ( genRewardAccounts
     , maryIntegrationTestAssets
     , mirMnemonics
+    , seaHorseTestAssets
     , shelleyIntegrationTestFunds
     )
 import Test.Integration.Framework.Context
@@ -238,7 +239,7 @@ specWithServer testDir (tr, tracers) = aroundAll withContext
         poolGarbageCollectionEvents <- newIORef []
         let dbEventRecorder =
                 recordPoolGarbageCollectionEvents poolGarbageCollectionEvents
-        let setupContext smashUrl np wAddr = bracketTracer' tr "setupContext" $ do
+        let setupContext smashUrl faucetConn np wAddr = bracketTracer' tr "setupContext" $ do
                 let baseUrl = "http://" <> T.pack (show wAddr) <> "/"
                 prometheusUrl <- (maybe "none" (\(h, p) -> T.pack h <> ":" <> toText @(Port "Prometheus") p)) <$> getPrometheusURL
                 ekgUrl <- (maybe "none" (\(h, p) -> T.pack h <> ":" <> toText @(Port "EKG") p)) <$> getEKGURL
@@ -261,6 +262,9 @@ specWithServer testDir (tr, tracers) = aroundAll withContext
                     , _poolGarbageCollectionEvents = poolGarbageCollectionEvents
                     , _mainEra = era
                     , _smashUrl = smashUrl
+                    , _mintSeaHorseAssets = \addrs nPerAddr -> do
+                        sendFaucetAssetsTo tr' faucetConn testDir 1 $
+                            encodeAddresses (seaHorseTestAssets addrs nPerAddr)
                     }
         let action' = bracketTracer' tr "spec" . action
         res <- race
@@ -297,15 +301,15 @@ specWithServer testDir (tr, tracers) = aroundAll withContext
                 onClusterStart (onReady $ T.pack smashUrl) dbDecorator
 
     tr' = contramap MsgCluster tr
+    encodeAddresses = map (first (T.unpack . encodeAddress @'Mainnet))
     setupFaucet conn = do
         traceWith tr MsgSettingUpFaucet
         let rewards = (,Coin $ fromIntegral oneMillionAda) <$>
                 concatMap genRewardAccounts mirMnemonics
         moveInstantaneousRewardsTo tr' conn testDir rewards
-        let encodeAddresses = map (first (T.unpack . encodeAddress @'Mainnet))
         sendFaucetFundsTo tr' conn testDir $
             encodeAddresses shelleyIntegrationTestFunds
-        sendFaucetAssetsTo tr' conn testDir $
+        sendFaucetAssetsTo tr' conn testDir 20 $
             encodeAddresses maryIntegrationTestAssets
 
     onClusterStart action dbDecorator (RunningNode conn block0 (gp, vData)) = do
@@ -329,7 +333,7 @@ specWithServer testDir (tr, tracers) = aroundAll withContext
                 conn
                 block0
                 (gp, vData)
-                (action gp)
+                (action conn gp)
                 `withException` (traceWith tr . MsgServerError)
 
 {-------------------------------------------------------------------------------