Add latency benchmark for shelley

lib/byron/cardano-wallet-byron.cabal

@@ -282,8 +282,6 @@ benchmark latency
    , stm
    , temporary
    , text
-  build-tools:
-      cardano-wallet-byron
   type:
      exitcode-stdio-1.0
   hs-source-dirs:

lib/jormungandr/cardano-wallet-jormungandr.cabal

@@ -311,8 +311,6 @@ benchmark latency
     , stm
     , temporary
     , text
-  build-tools:
-      cardano-wallet-jormungandr
   type:
      exitcode-stdio-1.0
   hs-source-dirs:

lib/shelley/bench/Latency.hs

@@ -0,0 +1,351 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+
+module Main where
+
+import Prelude
+
+import Cardano.BM.Data.LogItem
+    ( LogObject )
+import Cardano.BM.Data.Severity
+    ( Severity (..) )
+import Cardano.BM.Data.Tracer
+    ( contramap, nullTracer )
+import Cardano.BM.Trace
+    ( traceInTVarIO )
+import Cardano.CLI
+    ( Port (..) )
+import Cardano.Startup
+    ( withUtf8Encoding )
+import Cardano.Wallet.Api.Server
+    ( Listen (..) )
+import Cardano.Wallet.Api.Types
+    ( ApiAddress
+    , ApiFee
+    , ApiNetworkInformation
+    , ApiTransaction
+    , ApiUtxoStatistics
+    , ApiWallet
+    , WalletStyle (..)
+    )
+import Cardano.Wallet.LatencyBenchShared
+    ( LogCaptureFunc, fmtResult, fmtTitle, measureApiLogs, withLatencyLogging )
+import Cardano.Wallet.Logging
+    ( trMessage )
+import Cardano.Wallet.Network.Ports
+    ( unsafePortNumber )
+import Cardano.Wallet.Primitive.AddressDerivation
+    ( NetworkDiscriminant (..) )
+import Cardano.Wallet.Primitive.Types
+    ( SyncTolerance (..) )
+import Cardano.Wallet.Shelley
+    ( SomeNetworkDiscriminant (..)
+    , Tracers
+    , Tracers' (..)
+    , nullTracers
+    , serveWallet
+    )
+import Cardano.Wallet.Shelley.Compatibility
+    ( Shelley )
+import Cardano.Wallet.Shelley.Faucet
+    ( initFaucet )
+import Cardano.Wallet.Shelley.Launch
+    ( singleNodeParams, withBFTNode, withSystemTempDir )
+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 )
+import Data.Generics.Internal.VL.Lens
+    ( (^.) )
+import Data.Proxy
+    ( Proxy (..) )
+import Network.HTTP.Client
+    ( defaultManagerSettings
+    , managerResponseTimeout
+    , newManager
+    , responseTimeoutMicro
+    )
+import Network.Wai.Middleware.Logging
+    ( ApiLog (..) )
+import Numeric.Natural
+    ( Natural )
+import System.Directory
+    ( createDirectory )
+import System.FilePath
+    ( (</>) )
+import Test.Hspec
+    ( shouldBe )
+import Test.Integration.Framework.DSL
+    ( Context (..)
+    , Headers (..)
+    , Payload (..)
+    , eventually
+    , expectField
+    , expectResponseCode
+    , expectSuccess
+    , expectWalletUTxO
+    , faucetAmt
+    , fixturePassphrase
+    , fixtureWallet
+    , fixtureWalletWith
+    , json
+    , request
+    , unsafeRequest
+    , verify
+    )
+
+import qualified Cardano.Wallet.Api.Link as Link
+import qualified Data.Text as T
+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)
+
+  where
+    setupTracers :: TVar [LogObject ApiLog] -> Tracers IO
+    setupTracers tvar = nullTracers
+        { apiServerTracer = trMessage $ contramap snd (traceInTVarIO tvar) }
+
+walletApiBench
+    :: forall t (n :: NetworkDiscriminant). (t ~ Shelley, n ~ 'Mainnet)
+    => LogCaptureFunc ApiLog ()
+    -> ((Context t -> IO ()) -> IO ())
+    -> IO ()
+walletApiBench capture benchWithServer = do
+    fmtTitle "Non-cached run"
+    runWarmUpScenario
+
+    fmtTitle "Latencies for 2 fixture wallets scenario"
+    runScenario (nFixtureWallet 2)
+
+    fmtTitle "Latencies for 10 fixture wallets scenario"
+    runScenario (nFixtureWallet 10)
+
+    fmtTitle "Latencies for 100 fixture wallets scenario"
+    runScenario (nFixtureWallet 100)
+
+    fmtTitle "Latencies for 2 fixture wallets with 10 txs scenario"
+    runScenario (nFixtureWalletWithTxs 2 10)
+
+    fmtTitle "Latencies for 2 fixture wallets with 20 txs scenario"
+    runScenario (nFixtureWalletWithTxs 2 20)
+
+    fmtTitle "Latencies for 2 fixture wallets with 100 txs scenario"
+    runScenario (nFixtureWalletWithTxs 2 100)
+
+    fmtTitle "Latencies for 10 fixture wallets with 10 txs scenario"
+    runScenario (nFixtureWalletWithTxs 10 10)
+
+    fmtTitle "Latencies for 10 fixture wallets with 20 txs scenario"
+    runScenario (nFixtureWalletWithTxs 10 20)
+
+    fmtTitle "Latencies for 10 fixture wallets with 100 txs scenario"
+    runScenario (nFixtureWalletWithTxs 10 100)
+
+    fmtTitle "Latencies for 2 fixture wallets with 100 utxos scenario"
+    runScenario (nFixtureWalletWithUTxOs 2 100)
+
+    fmtTitle "Latencies for 2 fixture wallets with 200 utxos scenario"
+    runScenario (nFixtureWalletWithUTxOs 2 200)
+
+    fmtTitle "Latencies for 2 fixture wallets with 500 utxos scenario"
+    runScenario (nFixtureWalletWithUTxOs 2 500)
+
+    fmtTitle "Latencies for 2 fixture wallets with 1000 utxos scenario"
+    runScenario (nFixtureWalletWithUTxOs 2 1000)
+  where
+
+    -- Creates n fixture wallets and return two of them
+    nFixtureWallet n ctx = do
+        wal1 : wal2 : _ <- replicateM n (fixtureWallet ctx)
+        pure (wal1, wal2)
+
+    -- Creates n fixture wallets and send 1-lovelace 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 ctx = do
+        (wal1, wal2) <- nFixtureWallet n ctx
+
+        let amt = (1 :: Natural)
+        let batchSize = 10
+        let whole10Rounds = div m batchSize
+        let lastBit = mod m batchSize
+        let amtExp val = fromIntegral ((fromIntegral val) + faucetAmt) :: Natural
+        let expInflows =
+                if whole10Rounds > 0 then
+                    [x*batchSize | x<-[1..whole10Rounds]] ++ [lastBit]
+                else
+                    [lastBit]
+        let expInflows' = filter (/=0) expInflows
+
+        mapM_ (repeatPostTx ctx wal1 amt batchSize . amtExp) expInflows'
+        pure (wal1, wal2)
+
+    nFixtureWalletWithUTxOs n utxoNumber ctx = do
+        let utxoExp = replicate utxoNumber 1
+        wal1 <- fixtureWalletWith @n ctx utxoExp
+        (_, wal2) <- nFixtureWallet n ctx
+
+        eventually "Wallet balance is as expected" $ do
+            rWal1 <- request @ApiWallet ctx
+                (Link.getWallet @'Shelley wal1) Default Empty
+            verify rWal1
+                [ expectSuccess
+                , expectField
+                        (#balance . #getApiT . #available . #getQuantity)
+                        (`shouldBe` fromIntegral utxoNumber)
+                ]
+
+        rStat <- request @ApiUtxoStatistics ctx
+                (Link.getUTxOsStatistics @'Shelley wal1) Default Empty
+        expectResponseCode @IO HTTP.status200 rStat
+        expectWalletUTxO (fromIntegral <$> utxoExp) (snd rStat)
+        pure (wal1, wal2)
+
+    repeatPostTx ctx wDest amtToSend batchSize amtExp = do
+        wSrc <- fixtureWallet ctx
+        replicateM_ batchSize
+            (postTx ctx (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
+                [ expectSuccess
+                , expectField
+                    (#balance . #getApiT . #available . #getQuantity)
+                    (`shouldBe` amtExp)
+                ]
+        rDel <- request @ApiWallet  ctx (Link.deleteWallet @'Shelley wSrc) Default Empty
+        expectResponseCode @IO HTTP.status204 rDel
+        pure ()
+
+    postTx ctx (wSrc, postTxEndp, pass) wDest amt = do
+        (_, addrs) <- unsafeRequest @[ApiAddress n] ctx
+                      (Link.listAddresses @'Shelley wDest) Empty
+        let destination = (addrs !! 1) ^. #id
+        let payload = Json [json|{
+                "payments": [{
+                    "address": #{destination},
+                    "amount": {
+                        "quantity": #{amt},
+                        "unit": "lovelace"
+                    }
+                }],
+                "passphrase": #{pass}
+            }|]
+        r <- request @(ApiTransaction n) ctx (postTxEndp wSrc) Default payload
+        expectResponseCode HTTP.status202 r
+        return r
+
+    runScenario scenario = benchWithServer $ \ctx -> do
+        (wal1, wal2) <- scenario ctx
+
+        t1 <- measureApiLogs capture
+            (request @[ApiWallet] ctx (Link.listWallets @'Shelley) Default Empty)
+        fmtResult "listWallets        " t1
+
+        t2 <- measureApiLogs capture
+            (request @ApiWallet  ctx (Link.getWallet @'Shelley wal1) Default Empty)
+        fmtResult "getWallet          " t2
+
+        t3 <- measureApiLogs capture
+            (request @ApiUtxoStatistics ctx (Link.getUTxOsStatistics @'Shelley wal1) Default Empty)
+        fmtResult "getUTxOsStatistics " t3
+
+        t4 <- measureApiLogs capture
+            (request @[ApiAddress n] ctx (Link.listAddresses @'Shelley wal1) Default Empty)
+        fmtResult "listAddresses      " t4
+
+        t5 <- measureApiLogs capture
+            (request @[ApiTransaction n] ctx (Link.listTransactions @'Shelley wal1) Default Empty)
+        fmtResult "listTransactions   " t5
+
+        (_, addrs) <- unsafeRequest @[ApiAddress n] ctx (Link.listAddresses @'Shelley wal2) Empty
+        let amt = 1 :: Natural
+        let destination = (addrs !! 1) ^. #id
+        let payload = Json [json|{
+                "payments": [{
+                    "address": #{destination},
+                    "amount": {
+                        "quantity": #{amt},
+                        "unit": "lovelace"
+                    }
+                }]
+            }|]
+        t6 <- measureApiLogs capture $ request @ApiFee ctx
+            (Link.getTransactionFee @'Shelley wal1) Default payload
+        fmtResult "postTransactionFee " t6
+
+        t7 <- measureApiLogs capture $ request @ApiNetworkInformation ctx
+            Link.getNetworkInfo Default Empty
+        fmtResult "getNetworkInfo     " t7
+
+        pure ()
+
+    runWarmUpScenario = benchWithServer $ \ctx -> 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
+    :: Tracers IO
+    -> (Context Shelley -> IO ())
+    -> IO ()
+benchWithShelleyServer tracers action = do
+    ctx <- newEmptyMVar
+    let setupContext np wAddr = do
+            let baseUrl = "http://" <> T.pack (show wAddr) <> "/"
+            let sixtySeconds = 60*1000*1000 -- 60s in microseconds
+            manager <- (baseUrl,) <$> newManager (defaultManagerSettings
+                { managerResponseTimeout =
+                    responseTimeoutMicro sixtySeconds
+                })
+            faucet <- initFaucet
+            putMVar ctx $ Context
+                { _cleanup = pure ()
+                , _manager = manager
+                , _walletPort = Port . fromIntegral $ unsafePortNumber wAddr
+                , _faucet = faucet
+                , _feeEstimator = \_ -> error "feeEstimator not available"
+                , _networkParameters = np
+                , _target = Proxy
+                }
+    race_ (takeMVar ctx >>= action) (withServer setupContext)
+
+  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
+                (SomeNetworkDiscriminant $ Proxy @'Mainnet)
+                tracers
+                (SyncTolerance 10)
+                (Just db)
+                "127.0.0.1"
+                ListenOnRandomPort
+                Nothing
+                socketPath
+                block0
+                (gp, vData)
+                (act gp)