Merge #2421

2421: [ADP 627] Upgrade DB benchmarks r=hasufell a=hasufell

# Issue Number

ADP-627

# Overview

- [x] parametrize functions with `mkOutput`, so we can have different such functions (e.g. TokenBundles with only Ada or with multi assets)
- [x] create an `mkOutput` variant that creates multi asset tokenbundles

# Comments

## Questions

Do we always want to run both ada-only and tokenbundle benchmarks or do we just keep the ada-only commented out for debugging purposes?

## For QA maybe?

- [ ] compare ada-only benchmark run with pre-multiasset runs
- [ ] compare tokenbundle run with ada-only run

<!-- Additional comments or screenshots to attach if any -->

<!--
Don't forget to:

 ✓ Self-review your changes to make sure nothing unexpected slipped through
 ✓ Assign yourself to the PR
 ✓ Assign one or several reviewer(s)
 ✓ Jira will detect and link to this PR once created, but you can also link this PR in the description of the corresponding ticket
 ✓ Acknowledge any changes required to the Wiki
 ✓ Finally, in the PR description delete any empty sections and all text commented in <!--, so that this text does not appear in merge commit messages.
-->


Co-authored-by: Julian Ospald <julian.ospald@iohk.io>

lib/core/cardano-wallet-core.cabal

@@ -395,6 +395,7 @@ benchmark db
     , random
     , temporary
     , text
+    , text-class
     , time
     , transformers
     , unliftio

lib/core/test/bench/db/Main.hs

@@ -123,6 +123,8 @@ import Cardano.Wallet.Primitive.Types.Coin
     ( Coin (..) )
 import Cardano.Wallet.Primitive.Types.Hash
     ( Hash (..) )
+import Cardano.Wallet.Primitive.Types.TokenQuantity
+    ( TokenQuantity (..) )
 import Cardano.Wallet.Primitive.Types.Tx
     ( Direction (..)
     , TransactionInfo
@@ -138,6 +140,8 @@ import Cardano.Wallet.Unsafe
     ( someDummyMnemonic, unsafeRunExceptT )
 import Control.DeepSeq
     ( NFData (..), force )
+import Control.Monad
+    ( join )
 import Control.Monad.Trans.Except
     ( mapExceptT )
 import Criterion.Main
@@ -153,6 +157,8 @@ import Crypto.Hash
     ( hash )
 import Data.ByteString
     ( ByteString )
+import Data.Either
+    ( fromRight )
 import Data.Functor
     ( ($>) )
 import Data.Functor.Identity
@@ -167,6 +173,8 @@ import Data.Quantity
     ( Quantity (..) )
 import Data.Text
     ( Text )
+import Data.Text.Class
+    ( fromText )
 import Data.Time.Clock.POSIX
     ( posixSecondsToUTCTime )
 import Data.Time.Clock.System
@@ -196,21 +204,31 @@ import qualified Cardano.BM.Configuration.Model as CM
 import qualified Cardano.BM.Data.BackendKind as CM
 import qualified Cardano.Wallet.Primitive.AddressDerivation.Byron as Byron
 import qualified Cardano.Wallet.Primitive.Types.TokenBundle as TokenBundle
+import qualified Cardano.Wallet.Primitive.Types.TokenMap as TokenMap
 import qualified Data.ByteArray as BA
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Char8 as B8
 import qualified Data.Map.Strict as Map
+import qualified Data.Text as T
 
 main :: IO ()
 main = withUtf8Encoding $ withLogging $ \trace -> do
     let tr = filterSeverity (pure . const Error) $ trMessageText trace
     defaultMain
-        [ withDB tr bgroupWriteUTxO
-        , withDB tr bgroupReadUTxO
+        [ withDB tr (bgroupWriteUTxO (mkOutputsToken 100 200) "UTxO (Write)")
+        , withDB tr (bgroupReadUTxO (mkOutputsToken 100 200) "UTxO (Read)")
+        , withDB tr (bgroupWriteUTxO mkOutputsCoin "UTxO ada-only (Write)")
+        , withDB tr (bgroupReadUTxO mkOutputsCoin "UTxO ada-only (Read)")
         , withDB tr bgroupWriteSeqState
         , withDB tr bgroupWriteRndState
-        , withDB tr bgroupWriteTxHistory
-        , withDB tr bgroupReadTxHistory
+        , withDB tr $ bgroupWriteTxHistory mkOutputsCoin
+            "TxHistory ada-only (Write)"
+        , withDB tr $ bgroupReadTxHistory mkOutputsCoin
+            "TxHistory ada-only (Read)"
+        , withDB tr $ bgroupWriteTxHistory (mkOutputsToken 100 200)
+            "TxHistory (Write)"
+        , withDB tr $ bgroupReadTxHistory (mkOutputsToken 100 200)
+            "TxHistory (Read)"
         ]
     putStrLn "\n--"
     utxoDiskSpaceTests tr
@@ -224,8 +242,12 @@ main = withUtf8Encoding $ withLogging $ \trace -> do
 --
 -- Currently the DBLayer will only store a single checkpoint (no rollback), so
 -- the #Checkpoints axis is a bit meaningless.
-bgroupWriteUTxO :: DBLayerBench -> Benchmark
-bgroupWriteUTxO db = bgroup "UTxO (Write)"
+bgroupWriteUTxO
+    :: (Int -> Int -> [TxOut])
+    -> String
+    -> DBLayerBench
+    -> Benchmark
+bgroupWriteUTxO mkOutputs gn db = bgroup gn
     -- A fragmented wallet will have a large number of UTxO. The coin
     -- selection algorithm tries to prevent fragmentation.
     --
@@ -241,11 +263,15 @@ bgroupWriteUTxO db = bgroup "UTxO (Write)"
     ]
   where
     bUTxO n s = bench lbl $ withCleanDB db walletFixture $
-        benchPutUTxO n s . fst
+        benchPutUTxO mkOutputs n s . fst
       where lbl = n|+" CP x "+|s|+" UTxO"
 
-bgroupReadUTxO :: DBLayerBench -> Benchmark
-bgroupReadUTxO db = bgroup "UTxO (Read)"
+bgroupReadUTxO
+    :: (Int -> Int -> [TxOut])
+    -> String
+    -> DBLayerBench
+    -> Benchmark
+bgroupReadUTxO mkOutputs gn db = bgroup gn
     --      #Checkpoints   UTxO Size
     [ bUTxO            1           0
     , bUTxO            1          10
@@ -255,16 +281,16 @@ bgroupReadUTxO db = bgroup "UTxO (Read)"
     , bUTxO            1      100000
     ]
   where
-    bUTxO n s = bench lbl $ withUTxO db n s benchReadUTxO
+    bUTxO n s = bench lbl $ withUTxO mkOutputs db n s benchReadUTxO
         where lbl = n|+" CP x "+|s|+" UTxO"
 
-benchPutUTxO :: Int -> Int -> DBLayerBench -> IO ()
-benchPutUTxO numCheckpoints utxoSize DBLayer{..} = do
-    let cps = mkCheckpoints numCheckpoints utxoSize
+benchPutUTxO :: (Int -> Int -> [TxOut]) -> Int -> Int -> DBLayerBench -> IO ()
+benchPutUTxO mkOutputs numCheckpoints utxoSize DBLayer{..} = do
+    let cps = mkCheckpoints mkOutputs numCheckpoints utxoSize
     unsafeRunExceptT $ mapExceptT atomically $ mapM_ (putCheckpoint testPk) cps
 
-mkCheckpoints :: Int -> Int -> [WalletBench]
-mkCheckpoints numCheckpoints utxoSize =
+mkCheckpoints :: (Int -> Int -> [TxOut]) -> Int -> Int -> [WalletBench]
+mkCheckpoints mkOutputs numCheckpoints utxoSize =
     [ force (cp i) | !i <- [1..numCheckpoints] ]
   where
     cp i = unsafeInitWallet
@@ -287,17 +313,18 @@ benchReadUTxO DBLayer{..} = atomically $ readCheckpoint testPk
 -- Set up a database with some UTxO in checkpoints.
 withUTxO
     :: NFData b
-    => DBLayerBench
+    => (Int -> Int -> [TxOut])
+    -> DBLayerBench
     -> Int
     -> Int
     -> (DBLayerBench -> IO b)
     -> Benchmarkable
-withUTxO db n s = perRunEnv (utxoFixture db n s $> db)
+withUTxO mkOutputs db n s = perRunEnv (utxoFixture mkOutputs db n s $> db)
 
-utxoFixture :: DBLayerBench -> Int -> Int -> IO ()
-utxoFixture db@DBLayer{..} numCheckpoints utxoSize = do
+utxoFixture :: (Int -> Int -> [TxOut]) -> DBLayerBench -> Int -> Int -> IO ()
+utxoFixture mkOutputs db@DBLayer{..} numCheckpoints utxoSize = do
     walletFixture db
-    let cps = mkCheckpoints numCheckpoints utxoSize
+    let cps = mkCheckpoints mkOutputs numCheckpoints utxoSize
     unsafeRunExceptT $ mapM_ (mapExceptT atomically . putCheckpoint testPk) cps
 
 ----------------------------------------------------------------------------
@@ -444,8 +471,12 @@ mkRndAddresses numAddrs i =
 --
 -- - 50 inputs
 -- - 100 outputs
-bgroupWriteTxHistory :: DBLayerBench -> Benchmark
-bgroupWriteTxHistory db = bgroup "TxHistory (Write)"
+bgroupWriteTxHistory
+    :: (Int -> Int -> [TxOut])
+    -> String
+    -> DBLayerBench
+    -> Benchmark
+bgroupWriteTxHistory mkOutputs gn db = bgroup gn
     --                   #NTxs #NInputs #NOutputs  #SlotRange
     [ bTxHistory             1        1        1      [1..10]
     , bTxHistory            10        1        1      [1..10]
@@ -463,14 +494,18 @@ bgroupWriteTxHistory db = bgroup "TxHistory (Write)"
   where
     bTxHistory n i o r =
         bench lbl $ withCleanDB db walletFixture $
-            benchPutTxHistory n i o r . fst
+            benchPutTxHistory mkOutputs n i o r . fst
       where
         lbl = n|+" w/ "+|i|+"i + "+|o|+"o ["+|inf|+".."+|sup|+"]"
         inf = head r
         sup = last r
 
-bgroupReadTxHistory :: DBLayerBench -> Benchmark
-bgroupReadTxHistory db = bgroup "TxHistory (Read)"
+bgroupReadTxHistory
+    :: (Int -> Int -> [TxOut])
+    -> String
+    -> DBLayerBench
+    -> Benchmark
+bgroupReadTxHistory mkOutputs gn db = bgroup gn
     --             #NTxs  #SlotRange  #SortOrder  #Status  #SearchRange
     [ bTxHistory    1000    [1..100]  Descending  Nothing  wholeRange
     , bTxHistory    1000    [1..100]   Ascending  Nothing  wholeRange
@@ -485,7 +520,7 @@ bgroupReadTxHistory db = bgroup "TxHistory (Read)"
     wholeRange = (Nothing, Nothing)
     pending = Just Pending
     bTxHistory n r o st s =
-        bench lbl $ withTxHistory db n r $ benchReadTxHistory o s st
+        bench lbl $ withTxHistory mkOutputs db n r $ benchReadTxHistory o s st
       where
         lbl = unwords [show n, range, ord, mstatus, search]
         range = let inf = head r in let sup = last r in "["+|inf|+".."+|sup|+"]"
@@ -498,14 +533,15 @@ bgroupReadTxHistory db = bgroup "TxHistory (Read)"
             (Just inf, Just sup) -> inf|+".."+|sup|+""
 
 benchPutTxHistory
-    :: Int
+    :: (Int -> Int -> [TxOut])
+    -> Int
     -> Int
     -> Int
     -> [Word64]
     -> DBLayerBench
     -> IO ()
-benchPutTxHistory numTxs numInputs numOutputs range DBLayer{..} = do
-    let txs = mkTxHistory numTxs numInputs numOutputs range
+benchPutTxHistory mkOutputs numTxs numInputs numOutputs range DBLayer{..} = do
+    let txs = mkTxHistory mkOutputs numTxs numInputs numOutputs range
     unsafeRunExceptT $ mapExceptT atomically $ putTxHistory testPk txs
 
 benchReadTxHistory
@@ -521,8 +557,14 @@ benchReadTxHistory sortOrder (inf, sup) mstatus DBLayer{..} =
         (SlotNo . fromIntegral <$> inf)
         (SlotNo . fromIntegral <$> sup)
 
-mkTxHistory :: Int -> Int -> Int -> [Word64] -> [(Tx, TxMeta)]
-mkTxHistory numTx numInputs numOutputs range =
+mkTxHistory
+    :: (Int -> Int -> [TxOut])
+    -> Int
+    -> Int
+    -> Int
+    -> [Word64]
+    -> [(Tx, TxMeta)]
+mkTxHistory mkOutputs numTx numInputs numOutputs range =
     [ force
         ( (Tx (mkTxId inps outs mempty Nothing) Nothing inps outs mempty) Nothing
         , TxMeta
@@ -551,31 +593,62 @@ mkInputs prefix n =
   where
     lbl = show prefix <> "in"
 
-mkOutputs :: Int -> Int -> [TxOut]
-mkOutputs prefix n =
+-- | Creates transaction outputs with ada-only token bundles.
+mkOutputsCoin :: Int -> Int -> [TxOut]
+mkOutputsCoin prefix n =
     [ force
         (TxOut (mkAddress prefix i) (TokenBundle.fromCoin $ Coin 1))
     | !i <- [1..n]
     ]
 
+-- | Creates transaction outputs with multi-asset token bundles.
+mkOutputsToken :: Int -> Int -> Int -> Int -> [TxOut]
+mkOutputsToken assetCount tokenQuantity prefix n =
+    [ force (mkTxOut i)
+    | !i <- [1..n]
+    ]
+  where
+    mkTxOut i = TxOut
+        (mkAddress prefix i)
+        (TokenBundle.TokenBundle (Coin 1) (TokenMap.fromFlatList tokens))
+    mkTokenName = fromRight (error "Couldn't decode tokenName")
+        . fromText . T.pack . show
+    mkTokenPolicyId = fromRight (error "Couldn't decode tokenPolicyId")
+        . fromText
+        . T.pack
+        . take tokenPolicyIdHexStringLength
+        . join
+        . replicate tokenPolicyIdHexStringLength
+        . show
+    tokenPolicyIdHexStringLength = 56
+    tokens =
+        [ ( TokenMap.AssetId (mkTokenPolicyId ac) (mkTokenName ac)
+          , TokenQuantity $ fromIntegral tokenQuantity
+          )
+        | !ac <- [1 .. assetCount]
+        ]
+
 withTxHistory
     :: NFData b
-    => DBLayerBench
+    => (Int -> Int -> [TxOut])
+    -> DBLayerBench
     -> Int
     -> [Word64]
     -> (DBLayerBench -> IO b)
     -> Benchmarkable
-withTxHistory db s r = perRunEnv (txHistoryFixture db s r $> db)
+withTxHistory mkOutputs db s r =
+    perRunEnv (txHistoryFixture mkOutputs db s r $> db)
 
 txHistoryFixture
-    :: DBLayerBench
+    :: (Int -> Int -> [TxOut])
+    -> DBLayerBench
     -> Int
     -> [Word64]
     -> IO ()
-txHistoryFixture db@DBLayer{..} bSize range = do
+txHistoryFixture mkOutputs db@DBLayer{..} bSize range = do
     walletFixture db
     let (nInps, nOuts) = (20, 20)
-    let txs = mkTxHistory bSize nInps nOuts range
+    let txs = mkTxHistory mkOutputs bSize nInps nOuts range
     atomically $ unsafeRunExceptT $ putTxHistory testPk txs
 
 ----------------------------------------------------------------------------
@@ -696,7 +769,7 @@ utxoDiskSpaceTests tr = do
     bUTxO n s = benchDiskSize tr $ \db -> do
         putStrLn ("File size /"+|n|+" CP x "+|s|+" UTxO")
         walletFixture db
-        benchPutUTxO n s db
+        benchPutUTxO mkOutputsCoin n s db
 
 txHistoryDiskSpaceTests :: Tracer IO DBLog -> IO ()
 txHistoryDiskSpaceTests tr = do
@@ -716,7 +789,7 @@ txHistoryDiskSpaceTests tr = do
     bTxs n i o = benchDiskSize tr $ \db -> do
         putStrLn ("File size /"+|n|+" w/ "+|i|+"i + "+|o|+"o")
         walletFixture db
-        benchPutTxHistory n i o [1..100] db
+        benchPutTxHistory mkOutputsCoin n i o [1..100] db
 
 benchDiskSize :: Tracer IO DBLog -> (DBLayerBench -> IO ()) -> IO ()
 benchDiskSize tr action = bracket (setupDB tr) cleanupDB $ \(f, ctx, db) -> do