Merge #2665 #2667

2665: Add basic latency benchmarks for migrations r=piotr-iohk a=piotr-iohk

# Issue Number

ADP-680


# Overview

- 2c31861
  Add basic latency benchmarks for migrations


# Comments

[Migration Plan](http://cardano-wallet-benchmarks.herokuapp.com/latency?latency_category=4&latency_benchmark=all&latency_measurement=postMigrationPlan)
[Migration](http://cardano-wallet-benchmarks.herokuapp.com/latency?latency_category=4&latency_benchmark=all&latency_measurement=postMigration)


2667: Add property test for `UTxOIndex.selectRandomWithPriority`. r=jonathanknowles a=jonathanknowles

# Issue Number

ADP-890

# Overview

This PR adds a property test for `UTxOIndex.selectRandomWithPriority`.

The `selectRandomWithPriority`  function is designed to:
- select an entry at random from a UTxO index according to a specified list of filter conditions;
- traverse the specified list of filter conditions in order of priority **_from left to right_**.

The test added in this PR provides a basic sanity check to verify that priority order is respected.

# Sample Output

```hs
Cardano.Wallet.Primitive.Types.UTxOIndex
  Indexed UTxO set properties
    Index Selection
      prop_selectRandomWithPriority
        +++ OK, passed 1600 tests:
        59.69% have match for neither asset 1 nor asset 2
        17.12% have match for asset 1 but not for asset 2
        16.31% have match for asset 2 but not for asset 1
         6.88% have match for both asset 1 and asset 2

Finished in 1.0870 seconds
1 example, 0 failures
```

# QA Due Diligence

I ran this test 500 times to increase confidence that it will not fail spuriously. No failures were encountered.


Co-authored-by: Piotr Stachyra <piotr.stachyra@iohk.io>
Co-authored-by: Jonathan Knowles <jonathan.knowles@iohk.io>

lib/core/test/unit/Cardano/Wallet/Primitive/Types/UTxOIndexSpec.hs

@@ -35,6 +35,8 @@ import Data.Generics.Internal.VL.Lens
     ( view )
 import Data.Generics.Labels
     ()
+import Data.List.NonEmpty
+    ( NonEmpty (..) )
 import Data.Maybe
     ( isJust, isNothing )
 import Data.Ratio
@@ -55,9 +57,11 @@ import Test.QuickCheck
     , conjoin
     , counterexample
     , cover
+    , forAll
     , oneof
     , property
     , stdConfidence
+    , suchThat
     , withMaxSuccess
     , (===)
     )
@@ -155,6 +159,8 @@ spec =
             property prop_selectRandom_all_withAsset
         it "prop_selectRandom_all_withAssetOnly" $
             property prop_selectRandom_all_withAssetOnly
+        it "prop_selectRandomWithPriority" $
+            property prop_selectRandomWithPriority
 
     parallel $ describe "Set Selection" $ do
 
@@ -531,6 +537,38 @@ prop_selectRandom_all_withAssetOnly u a = checkCoverage $ monadicIO $ do
     assert $ UTxOIndex.deleteMany (fst <$> selectedEntries) u == u'
     assert $ UTxOIndex.insertMany selectedEntries u' == u
 
+-- | Verify that priority order is respected when selecting with more than
+--   one filter.
+--
+prop_selectRandomWithPriority :: UTxOIndex -> Property
+prop_selectRandomWithPriority u =
+    forAll (genAssetIdSmallRange) $ \a1 ->
+    forAll (genAssetIdSmallRange `suchThat` (/= a1)) $ \a2 ->
+    checkCoverage $ monadicIO $ do
+        haveMatchForAsset1 <- isJust <$>
+            run (UTxOIndex.selectRandom u $ WithAssetOnly a1)
+        haveMatchForAsset2 <- isJust <$>
+            run (UTxOIndex.selectRandom u $ WithAssetOnly a2)
+        monitor $ cover 4 (haveMatchForAsset1 && not haveMatchForAsset2)
+            "have match for asset 1 but not for asset 2"
+        monitor $ cover 4 (not haveMatchForAsset1 && haveMatchForAsset2)
+            "have match for asset 2 but not for asset 1"
+        monitor $ cover 4 (haveMatchForAsset1 && haveMatchForAsset2)
+            "have match for both asset 1 and asset 2"
+        monitor $ cover 4 (not haveMatchForAsset1 && not haveMatchForAsset2)
+            "have match for neither asset 1 nor asset 2"
+        result <- run $ UTxOIndex.selectRandomWithPriority u $
+            WithAssetOnly a1 :| [WithAssetOnly a2]
+        case result of
+            Just ((_, o), _) | o `txOutHasAsset` a1 -> do
+                assert haveMatchForAsset1
+            Just ((_, o), _) | o `txOutHasAsset` a2 -> do
+                assert (not haveMatchForAsset1)
+                assert haveMatchForAsset2
+            _ -> do
+                assert (not haveMatchForAsset1)
+                assert (not haveMatchForAsset2)
+
 --------------------------------------------------------------------------------
 -- Set selection properties
 --------------------------------------------------------------------------------

lib/shelley/bench/Latency.hs

@@ -37,6 +37,7 @@ import Cardano.Wallet.Api.Types
     , ApiTxId (..)
     , ApiUtxoStatistics
     , ApiWallet
+    , ApiWalletMigrationPlan (..)
     , EncodeAddress (..)
     , WalletStyle (..)
     )
@@ -203,15 +204,16 @@ walletApiBench capture ctx = do
     nFixtureWallet n = do
         wal1 : wal2 : _ <- replicateM n (fixtureWallet ctx)
         walMA <- fixtureMultiAssetWallet ctx
-        pure (wal1, wal2, walMA)
+        maWalletToMigrate <- fixtureMultiAssetWallet ctx
+        pure (wal1, wal2, walMA, maWalletToMigrate)
 
     -- Creates n fixture wallets and send 1-ada transactions to one of them
     -- (m times). The money is sent in batches (see batchSize below) from
     -- additionally created source fixture wallet. Then we wait for the money
     -- to be accommodated in recipient wallet. After that the source fixture
     -- wallet is removed.
     nFixtureWalletWithTxs n m = do
-        (wal1, wal2, walMA) <- nFixtureWallet n
+        (wal1, wal2, walMA, maWalletToMigrate) <- nFixtureWallet n
 
         let amt = minUTxOValue
         let batchSize = 10
@@ -226,12 +228,12 @@ walletApiBench capture ctx = do
         let expInflows' = filter (/=0) expInflows
 
         mapM_ (repeatPostTx wal1 amt batchSize . amtExp) expInflows'
-        pure (wal1, wal2, walMA)
+        pure (wal1, wal2, walMA, maWalletToMigrate)
 
     nFixtureWalletWithUTxOs n utxoNumber = do
         let utxoExp = replicate utxoNumber minUTxOValue
         wal1 <- fixtureWalletWith @n ctx utxoExp
-        (_, wal2, walMA) <- nFixtureWallet n
+        (_, wal2, walMA, maWalletToMigrate) <- nFixtureWallet n
 
         eventually "Wallet balance is as expected" $ do
             rWal1 <- request @ApiWallet ctx
@@ -247,7 +249,7 @@ walletApiBench capture ctx = do
                 (Link.getUTxOsStatistics @'Shelley wal1) Default Empty
         expectResponseCode HTTP.status200 rStat
         expectWalletUTxO (fromIntegral <$> utxoExp) (snd rStat)
-        pure (wal1, wal2, walMA)
+        pure (wal1, wal2, walMA, maWalletToMigrate)
 
     repeatPostTx wDest amtToSend batchSize amtExp = do
         wSrc <- fixtureWallet ctx
@@ -283,7 +285,7 @@ walletApiBench capture ctx = do
         expectResponseCode HTTP.status202 r
         return r
 
-    runScenario scenario = runResourceT $ scenario >>= \(wal1, wal2, walMA) -> liftIO $ do
+    runScenario scenario = runResourceT $ scenario >>= \(wal1, wal2, walMA, maWalletToMigrate) -> liftIO $ do
         t1 <- measureApiLogs capture
             (request @[ApiWallet] ctx (Link.listWallets @'Shelley) Default Empty)
         fmtResult "listWallets        " t1
@@ -384,6 +386,23 @@ walletApiBench capture ctx = do
             (Link.getAsset walMA polId assName) Default Empty
         fmtResult "getMultiAsset      " t11
 
+        -- Create a migration plan:
+        let endpointPlan = (Link.createMigrationPlan @'Shelley maWalletToMigrate)
+        t12a <- measureApiLogs capture $ request @(ApiWalletMigrationPlan n)
+            ctx endpointPlan Default $
+            Json [json|{addresses: #{addresses}}|]
+        fmtResult "postMigrationPlan  " t12a
+
+        -- Perform a migration:
+        let endpointMigrate = Link.migrateWallet @'Shelley maWalletToMigrate
+        t12b <- measureApiLogs capture $ request @[ApiTransaction n]
+            ctx endpointMigrate Default $
+            Json [json|
+                { passphrase: #{fixturePassphrase}
+                , addresses: #{addresses}
+                }|]
+        fmtResult "postMigration      " t12b
+
         pure ()
      where
         arbitraryStake :: Maybe Coin