Merge pull request #2046 from input-output-hk/paweljakubas/2021/fix-l…

…atency-benchmarks

use hardfork infrastructure in latency

lib/shelley/bench/Latency.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedLabels #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -36,12 +37,13 @@ import Cardano.Wallet.Api.Types
  , ApiTransaction
  , ApiUtxoStatistics
  , ApiWallet
+ , EncodeAddress (..)
  , WalletStyle (..)
  )
 import Cardano.Wallet.LatencyBenchShared
  ( LogCaptureFunc, fmtResult, fmtTitle, measureApiLogs, withLatencyLogging )
 import Cardano.Wallet.Logging
- ( trMessage )
+ ( stdoutTextTracer, trMessage )
 import Cardano.Wallet.Network.Ports
  ( unsafePortNumber )
 import Cardano.Wallet.Primitive.AddressDerivation
@@ -62,15 +64,22 @@ import Cardano.Wallet.Shelley.Compatibility
 import Cardano.Wallet.Shelley.Faucet
  ( initFaucet )
 import Cardano.Wallet.Shelley.Launch
- ( singleNodeParams, withBFTNode, withSystemTempDir )
+ ( RunningNode (..)
+ , sendFaucetFundsTo
+ , withCluster
+ , withSystemTempDir
+ , withTempDir
+ )
+import Control.Arrow
+ ( first )
 import Control.Concurrent.Async
  ( race_ )
 import Control.Concurrent.MVar
  ( newEmptyMVar, putMVar, takeMVar )
 import Control.Concurrent.STM.TVar
  ( TVar )
 import Control.Monad
- ( mapM_, replicateM, replicateM_, void )
+ ( mapM_, replicateM, replicateM_ )
 import Data.Generics.Internal.VL.Lens
  ( (^.) )
 import Data.Proxy
@@ -91,6 +100,8 @@ import System.FilePath
  ( (</>) )
 import Test.Hspec
  ( shouldBe )
+import Test.Integration.Faucet
+ ( shelleyIntegrationTestFunds )
 import Test.Integration.Framework.DSL
  ( Context (..)
  , Headers (..)
@@ -117,8 +128,8 @@ import qualified Network.HTTP.Types.Status as HTTP
 main :: forall t n. (t ~ Shelley, n ~ 'Mainnet) => IO ()
 main = withUtf8Encoding $
  withLatencyLogging setupTracers $ \tracers capture ->
- walletApiBench @t @n capture (benchWithShelleyServer tracers)
-
+ withShelleyServer tracers $ \ctx -> do
+ walletApiBench @t @n capture ctx
  where
  setupTracers :: TVar [LogObject ApiLog] -> Tracers IO
  setupTracers tvar = nullTracers
@@ -127,9 +138,9 @@ main = withUtf8Encoding $
 walletApiBench
  :: forall t (n :: NetworkDiscriminant). (t ~ Shelley, n ~ 'Mainnet)
  => LogCaptureFunc ApiLog ()
- -> ((Context t -> IO ()) -> IO ())
+ -> Context t
  -> IO ()
-walletApiBench capture benchWithServer = do
+walletApiBench capture ctx = do
  fmtTitle "Non-cached run"
  runWarmUpScenario
 
@@ -139,8 +150,11 @@ walletApiBench capture benchWithServer = do
  fmtTitle "Latencies for 10 fixture wallets scenario"
  runScenario (nFixtureWallet 10)
 
+ {-- PENDING: We currently have a limited amount of available fixture
+ wallets, so we can't just run a benchmark with 100 wallets in parallel.
  fmtTitle "Latencies for 100 fixture wallets scenario"
  runScenario (nFixtureWallet 100)
+ --}
 
  fmtTitle "Latencies for 2 fixture wallets with 10 txs scenario"
  runScenario (nFixtureWalletWithTxs 2 10)
@@ -169,12 +183,20 @@ walletApiBench capture benchWithServer = do
  fmtTitle "Latencies for 2 fixture wallets with 500 utxos scenario"
  runScenario (nFixtureWalletWithUTxOs 2 500)
 
+ {-- PENDING: Fee estimation is taking way longer than it should and this
+ scenario is not resolving in a timely manner.
+
+ To be re-enabled once #2006 & #2051 are fixed.
+
  fmtTitle "Latencies for 2 fixture wallets with 1000 utxos scenario"
  runScenario (nFixtureWalletWithUTxOs 2 1000)
+ --}
+ fmtTitle "Latencies for 2 fixture wallets with 1000 utxos scenario"
+ fmtTitle "CURRENTLY DISABLED. SEE #2006 & #2051"
  where
 
  -- Creates n fixture wallets and return two of them
- nFixtureWallet n ctx = do
+ nFixtureWallet n = do
  wal1 : wal2 : _ <- replicateM n (fixtureWallet ctx)
  pure (wal1, wal2)
 
@@ -183,8 +205,8 @@ walletApiBench capture benchWithServer = do
  -- 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 ctx = do
- (wal1, wal2) <- nFixtureWallet n ctx
+ nFixtureWalletWithTxs n m = do
+ (wal1, wal2) <- nFixtureWallet n
 
  let amt = (1 :: Natural)
  let batchSize = 10
@@ -198,13 +220,13 @@ walletApiBench capture benchWithServer = do
  [lastBit]
  let expInflows' = filter (/=0) expInflows
 
- mapM_ (repeatPostTx ctx wal1 amt batchSize . amtExp) expInflows'
+ mapM_ (repeatPostTx wal1 amt batchSize . amtExp) expInflows'
  pure (wal1, wal2)
 
- nFixtureWalletWithUTxOs n utxoNumber ctx = do
+ nFixtureWalletWithUTxOs n utxoNumber = do
  let utxoExp = replicate utxoNumber 1
  wal1 <- fixtureWalletWith @n ctx utxoExp
- (_, wal2) <- nFixtureWallet n ctx
+ (_, wal2) <- nFixtureWallet n
 
  eventually "Wallet balance is as expected" $ do
  rWal1 <- request @ApiWallet ctx
@@ -222,10 +244,10 @@ walletApiBench capture benchWithServer = do
  expectWalletUTxO (fromIntegral <$> utxoExp) (snd rStat)
  pure (wal1, wal2)
 
- repeatPostTx ctx wDest amtToSend batchSize amtExp = do
+ repeatPostTx wDest amtToSend batchSize amtExp = do
  wSrc <- fixtureWallet ctx
  replicateM_ batchSize
- (postTx ctx (wSrc, Link.createTransaction @'Shelley, fixturePassphrase) wDest amtToSend)
+ (postTx (wSrc, Link.createTransaction @'Shelley, fixturePassphrase) wDest amtToSend)
  eventually "repeatPostTx: wallet balance is as expected" $ do
  rWal1 <- request @ApiWallet ctx (Link.getWallet @'Shelley wDest) Default Empty
  verify rWal1
@@ -238,9 +260,9 @@ walletApiBench capture benchWithServer = do
  expectResponseCode @IO HTTP.status204 rDel
  pure ()
 
- postTx ctx (wSrc, postTxEndp, pass) wDest amt = do
+ postTx (wSrc, postTxEndp, pass) wDest amt = do
  (_, addrs) <- unsafeRequest @[ApiAddress n] ctx
-  (Link.listAddresses @'Shelley wDest) Empty
+ (Link.listAddresses @'Shelley wDest) Empty
  let destination = (addrs !! 1) ^. #id
  let payload = Json [json|{
  "payments": [{
@@ -256,8 +278,8 @@ walletApiBench capture benchWithServer = do
  expectResponseCode HTTP.status202 r
  return r
 
- runScenario scenario = benchWithServer $ \ctx -> do
- (wal1, wal2) <- scenario ctx
+ runScenario scenario = do
+ (wal1, wal2) <- scenario
 
  t1 <- measureApiLogs capture
  (request @[ApiWallet] ctx (Link.listWallets @'Shelley) Default Empty)
@@ -306,23 +328,23 @@ walletApiBench capture benchWithServer = do
 
  pure ()
  where
- arbitraryStake :: Maybe Coin
- arbitraryStake = Just $ ada 10000
- where ada = Coin . (1000*1000*)
+  arbitraryStake :: Maybe Coin
+  arbitraryStake = Just $ ada 10000
+  where ada = Coin . (1000*1000*)
 
- runWarmUpScenario = benchWithServer $ \ctx -> do
+ runWarmUpScenario = do
  -- this one is to have comparable results from first to last measurement
  -- in runScenario
  t <- measureApiLogs capture $ request @ApiNetworkInformation ctx
  Link.getNetworkInfo Default Empty
  fmtResult "getNetworkInfo " t
  pure ()
 
-benchWithShelleyServer
+withShelleyServer
  :: Tracers IO
  -> (Context Shelley -> IO ())
  -> IO ()
-benchWithShelleyServer tracers action = do
+withShelleyServer tracers action = do
  ctx <- newEmptyMVar
  let setupContext np wAddr = do
  let baseUrl = "http://" <> T.pack (show wAddr) <> "/"
@@ -345,11 +367,27 @@ benchWithShelleyServer tracers action = do
 
  where
  withServer act = withSystemTempDir nullTracer "latency" $ \dir -> do
- params <- singleNodeParams Error
- let db = dir </> "wallets"
- createDirectory db
- withBFTNode nullTracer dir params $ \socketPath block0 (gp, vData) ->
- void $ serveWallet
+ let db = dir </> "wallets"
+ createDirectory db
+ withCluster
+ nullTracer
+ Error
+ []
+ dir
+ onByron
+ (afterFork dir)
+ (onClusterStart act dir)
+ onByron _ = pure ()
+ afterFork dir _ = do
+ let encodeAddr = T.unpack . encodeAddress @'Mainnet
+ let addresses = map (first encodeAddr) shelleyIntegrationTestFunds
+ sendFaucetFundsTo stdoutTextTracer dir addresses
+
+ onClusterStart act dir (RunningNode socketPath block0 (gp, vData)) = do
+ -- NOTE: We may want to keep a wallet running across the fork, but
+ -- having three callbacks like this might not work well for that.
+ withTempDir nullTracer dir "wallets" $ \db -> do
+ serveWallet @(IO Shelley)
  (SomeNetworkDiscriminant $ Proxy @'Mainnet)
  tracers
  (SyncTolerance 10)

nix/haskell.nix

@@ -111,7 +111,19 @@ let
 
  # Add jormungandr to the PATH of the latency benchmark
  packages.cardano-wallet-jormungandr.components.benchmarks.latency = wrapBench jmPkgs.jormungandr;
- packages.cardano-wallet.components.benchmarks.latency = wrapBench pkgs.cardano-node;
+ packages.cardano-wallet.components.benchmarks.latency =
+ lib.optionalAttrs (!stdenv.hostPlatform.isWindows) {
+ build-tools = [ pkgs.makeWrapper ];
+ postInstall = ''
+ wrapProgram $out/bin/* \
+ --run "cd $src" \
+ --prefix PATH : ${pkgs.cardano-node}/bin
+
+ wrapProgram $out/bin/* \
+ --run "cd $src" \
+ --prefix PATH : ${pkgs.cardano-cli}/bin
+ '';
+ };
 
  # Add cardano-node to the PATH of the byroon restore benchmark.
  # cardano-node will want to write logs to a subdirectory of the working directory.