diff --git a/cabal.project b/cabal.project index bc8d6703385..4750a9ce2b9 100644 --- a/cabal.project +++ b/cabal.project @@ -69,6 +69,7 @@ packages: , lib/text-class/ , lib/wai-middleware-logging/ , lib/wallet/ + , lib/wallet-benchmarks/ -- Using RDRAND instead of /dev/urandom as an entropy source for key -- generation is dubious. Set the flag so we use /dev/urandom by default. diff --git a/lib/launcher/cardano-wallet-launcher.cabal b/lib/launcher/cardano-wallet-launcher.cabal index 5a9d125b12f..571bfbcf7bf 100644 --- a/lib/launcher/cardano-wallet-launcher.cabal +++ b/lib/launcher/cardano-wallet-launcher.cabal @@ -38,6 +38,7 @@ library , filepath , fmt , iohk-monitoring + , network , process , text , text-class @@ -48,6 +49,7 @@ library exposed-modules: Cardano.Launcher , Cardano.Launcher.Node + Cardano.Launcher.Wallet , Cardano.Startup if os(windows) build-depends: Win32 diff --git a/lib/launcher/src/Cardano/Launcher/Wallet.hs b/lib/launcher/src/Cardano/Launcher/Wallet.hs new file mode 100644 index 00000000000..f2b138db87b --- /dev/null +++ b/lib/launcher/src/Cardano/Launcher/Wallet.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE RecordWildCards #-} + +-- | +-- Copyright: © 2023-2023 IOHK +-- License: Apache-2.0 +-- +-- Provides a function to launch @cardano-wallet@. +module Cardano.Launcher.Wallet + ( -- * Startup + withCardanoWallet + , CardanoWalletConfig (..) + , NetworkConfig (..) + + -- * Run + , CardanoWalletConn + , getWalletPort + ) where + +import Prelude + +import Cardano.Launcher + ( LauncherLog, ProcessHasExited, withBackendCreateProcess ) +import Cardano.Launcher.Node + ( CardanoNodeConn, nodeSocketFile ) +import Control.Tracer + ( Tracer (..) ) +import Data.Text.Class + ( FromText (..), ToText (..) ) +import Network.Socket + ( PortNumber ) +import UnliftIO.Process + ( CreateProcess (..), proc ) + +{----------------------------------------------------------------------------- + Launching a `cardano-wallet` process +------------------------------------------------------------------------------} +-- | Parameters for connecting to the running wallet process. +newtype CardanoWalletConn = CardanoWalletConn { getWalletPort :: PortNumber } + deriving (Show, Eq) + +instance ToText CardanoWalletConn where + toText = toText . fromEnum . getWalletPort + +instance FromText CardanoWalletConn where + fromText = fmap (CardanoWalletConn . toEnum) . fromText + +data NetworkConfig + = Mainnet + | Testnet { nodeByronGenesis :: FilePath } + deriving (Show, Eq) + +-- | A subset of the @cardano-wallet@ CLI parameters, +-- used for starting the process. +data CardanoWalletConfig = CardanoWalletConfig + { walletPort :: PortNumber + -- ^ Port number for HTTP API. Good default: 8090. + , walletDatabaseDir :: FilePath + -- ^ Path to the wallet database file. + , walletNetwork :: NetworkConfig + -- ^ Network (mainnet or a testnet) that we connect to. + , extraArgs :: [String] + -- ^ Extra arguments to be passed to the process + } deriving (Show, Eq) + +-- | Spawns a @cardano-wallet@ process. +-- +-- IMPORTANT: @cardano-wallet@ must be available on the current path. +withCardanoWallet + :: Tracer IO LauncherLog + -- ^ Trace for subprocess control logging + -> CardanoNodeConn + -> CardanoWalletConfig + -> (CardanoWalletConn -> IO a) + -- ^ Callback function with a socket filename and genesis params + -> IO (Either ProcessHasExited a) +withCardanoWallet tr node cfg@CardanoWalletConfig{..} action = + withBackendCreateProcess tr (cardanoWallet cfg node) $ + \_ _ -> action $ CardanoWalletConn walletPort + +cardanoWallet :: CardanoWalletConfig -> CardanoNodeConn -> CreateProcess +cardanoWallet CardanoWalletConfig{..} node = + proc "cardano-wallet" $ + [ "serve" + , "--node-socket", nodeSocketFile node + , "--database", walletDatabaseDir + , "--port", show walletPort + ] + <> case walletNetwork of + Mainnet -> ["--mainnet"] + Testnet path -> ["--testnet", path] + <> extraArgs diff --git a/lib/wallet-benchmarks/bench/memory-benchmark.hs b/lib/wallet-benchmarks/bench/memory-benchmark.hs new file mode 100644 index 00000000000..6e451242e2b --- /dev/null +++ b/lib/wallet-benchmarks/bench/memory-benchmark.hs @@ -0,0 +1,239 @@ +{-# LANGUAGE RecordWildCards #-} + +import Prelude + +import Cardano.BM.Data.Tracer + ( HasPrivacyAnnotation (..), HasSeverityAnnotation (..) ) +import Cardano.Startup + ( installSignalHandlers, withUtf8Encoding ) +import Control.Concurrent + ( threadDelay ) +import Control.Monad + ( unless, void, when ) +import Control.Tracer + ( Tracer (..), contramap, traceWith ) +import Data.List + ( intersperse ) +import Data.Maybe + ( fromMaybe ) +import Data.Text + ( Text ) +import Data.Text.Class + ( ToText (..) ) +import System.FilePath + ( takeBaseName, () ) +import System.IO.Temp + ( withSystemTempDirectory ) +import Text.Read + ( readMaybe ) + +import qualified Cardano.BM.Configuration.Model as Log +import qualified Cardano.BM.Configuration.Static as Log +import qualified Cardano.BM.Data.BackendKind as Log +import qualified Cardano.BM.Data.LogItem as Log +import qualified Cardano.BM.Data.Severity as Log +import qualified Cardano.BM.Setup as Log +import qualified Cardano.Launcher as C +import qualified Cardano.Launcher.Node as C +import qualified Cardano.Launcher.Wallet as C +import qualified System.Process as S + +{----------------------------------------------------------------------------- + Configuration +------------------------------------------------------------------------------} +testSnapshot :: FilePath +testSnapshot = "membench-snapshot.tgz" + +testBlockHeight :: Int +testBlockHeight = 7280 + +cabalDataDir :: FilePath +cabalDataDir = "lib/wallet-benchmarks/data" + +testMnemonic :: [String] +testMnemonic = + [ "slab","praise","suffer","rabbit","during","dream" + , "arch","harvest","culture","book","owner","loud" + , "wool","salon","table","animal","vivid","arrow" + , "dirt","divide","humble","tornado","solution","jungle" + ] + +{----------------------------------------------------------------------------- + Main +------------------------------------------------------------------------------} +main :: IO () +main = withUtf8Encoding $ do + requireExecutable "cardano-node" "--version" + requireExecutable "cardano-wallet" "version" + requireExecutable "curl" "--version" + requireExecutable "jq" "--version" + + installSignalHandlers (pure ()) + trText <- initLogging "memory-benchmark" Log.Debug + let tr = contramap toText trText + + withSystemTempDirectory "wallet" $ \tmp -> do + cfg <- copyNodeSnapshot tmp + void $ withCardanoNode tr cfg $ \node -> do + sleep 2 + withCardanoWallet tr cfg node $ \wallet -> void $ do + sleep 1 + createWallet wallet testMnemonic + sleep 1 + waitUntilSynchronized wallet + +waitUntilSynchronized :: C.CardanoWalletConn -> IO () +waitUntilSynchronized wallet = do + height <- getLatestBlockHeight wallet + when (height < testBlockHeight) $ do + sleep 1 + waitUntilSynchronized wallet + +copyNodeSnapshot :: FilePath -> IO BenchmarkConfig +copyNodeSnapshot tmp = do + copyFile (cabalDataDir testSnapshot) tmp + let dir = tmp takeBaseName testSnapshot + decompress (tmp testSnapshot) tmp + pure $ BenchmarkConfig + { nodeConfigDir = dir "config" + , nodeDatabaseDir = dir "db-node" + , walletDatabaseDir = dir "db-wallet" + } + +{----------------------------------------------------------------------------- + Cardano commands +------------------------------------------------------------------------------} +getLatestBlockHeight :: C.CardanoWalletConn -> IO Int +getLatestBlockHeight wallet = + fmap (fromMaybe 0 . readMaybe) + . flip S.readCreateProcess "" + . S.shell + $ curlGetCommand wallet "/wallets" + <> " | jq '.[0].tip.height.quantity'" + +curlGetCommand + :: C.CardanoWalletConn -> String -> String +curlGetCommand wallet path = + "curl -X GET " <> walletURL wallet <> path + +createWallet :: C.CardanoWalletConn -> [String] -> IO () +createWallet wallet mnemonic = + curlPostJSON wallet "/wallets" $ unwords + [ "{ \"mnemonic_sentence\": " <> showMnemonic mnemonic <> "," + , " \"passphrase\": \"Secure Passphrase\"," + , " \"name\": \"Memory Benchmark\"," + , " \"address_pool_gap\": 20" + , "}" + ] + where + braces l r s = l <> s <> r + showMnemonic = + braces "[" "]" . unwords . intersperse "," . map (braces "\"" "\"") + +curlPostJSON :: C.CardanoWalletConn -> String -> String -> IO () +curlPostJSON wallet path json = + S.callProcess + "curl" + [ "-X", "POST" + , "-d", json + , "-H", "Content-Type: application/json" + , walletURL wallet <> path + ] + +walletURL :: C.CardanoWalletConn -> String +walletURL wallet = + "http://localhost:" <> show (C.getWalletPort wallet) <> "/v2" + +data BenchmarkConfig = BenchmarkConfig + { nodeConfigDir :: FilePath + , nodeDatabaseDir :: FilePath + , walletDatabaseDir :: FilePath + } + deriving (Eq, Show) + +-- | Start a `cardano-wallet` process on the benchmark configuration. +withCardanoWallet + :: Tracer IO C.LauncherLog + -> BenchmarkConfig + -> C.CardanoNodeConn + -> (C.CardanoWalletConn -> IO r) + -> IO (Either C.ProcessHasExited r) +withCardanoWallet tr BenchmarkConfig{..} node = + C.withCardanoWallet tr node + C.CardanoWalletConfig + { C.walletPort = + 8060 + , C.walletNetwork = + C.Testnet $ nodeConfigDir "byron-genesis.json" + , C.walletDatabaseDir = + walletDatabaseDir + , C.extraArgs = + profilingOptions + } + where + profilingOptions = words "+RTS -N1 -qg -A1m -I0 -T -h -i0.01 -RTS" + +-- | Start a `cardano-node` process on the benchmark configuration. +withCardanoNode + :: Tracer IO C.LauncherLog + -> BenchmarkConfig + -> (C.CardanoNodeConn -> IO r) + -> IO (Either C.ProcessHasExited r) +withCardanoNode tr BenchmarkConfig{..} = + C.withCardanoNode tr + C.CardanoNodeConfig + { C.nodeDir = nodeDatabaseDir + , C.nodeConfigFile = nodeConfigDir "config.json" + , C.nodeTopologyFile = nodeConfigDir "topology.json" + , C.nodeDatabaseDir = nodeDatabaseDir + , C.nodeDlgCertFile = Nothing + , C.nodeSignKeyFile = Nothing + , C.nodeOpCertFile = Nothing + , C.nodeKesKeyFile = Nothing + , C.nodeVrfKeyFile = Nothing + , C.nodePort = Just (C.NodePort 8061) + , C.nodeLoggingHostname = Nothing + } + +{----------------------------------------------------------------------------- + Utilities +------------------------------------------------------------------------------} +sleep :: Int -> IO () +sleep seconds = threadDelay (seconds * 1000 * 1000) + +-- | Throw an exception if the executable is not in the `$PATH`. +requireExecutable :: FilePath -> String -> IO () +requireExecutable name cmd = S.callProcess name [cmd] + +copyFile :: FilePath -> FilePath -> IO () +copyFile source destination = S.callProcess "cp" [source,destination] + +decompress :: FilePath -> FilePath -> IO () +decompress source destination = + S.callProcess "tar" ["-xzvf", source, "-C", destination] + +{----------------------------------------------------------------------------- + Logging +------------------------------------------------------------------------------} +initLogging :: Text -> Log.Severity -> IO (Tracer IO Text) +initLogging name minSeverity = do + c <- Log.defaultConfigStdout + Log.setMinSeverity c minSeverity + Log.setSetupBackends c [Log.KatipBK, Log.AggregationBK] + (tr, _sb) <- Log.setupTrace_ c name + pure (trMessageText tr) + +-- | Tracer transformer which transforms traced items to their 'ToText' +-- representation and further traces them as a 'Log.LogObject'. +-- If the 'ToText' representation is empty, then no tracing happens. +trMessageText + :: (ToText a, HasPrivacyAnnotation a, HasSeverityAnnotation a) + => Tracer IO (Log.LoggerName, Log.LogObject Text) + -> Tracer IO a +trMessageText tr = Tracer $ \arg -> do + let msg = toText arg + unless (msg == mempty) $ do + meta <- Log.mkLOMeta + (getSeverityAnnotation arg) + (getPrivacyAnnotation arg) + traceWith tr (mempty, Log.LogObject mempty meta (Log.LogMessage msg)) diff --git a/lib/wallet-benchmarks/cardano-wallet-benchmarks.cabal b/lib/wallet-benchmarks/cardano-wallet-benchmarks.cabal new file mode 100644 index 00000000000..ee70a32cfdb --- /dev/null +++ b/lib/wallet-benchmarks/cardano-wallet-benchmarks.cabal @@ -0,0 +1,43 @@ +cabal-version: 3.0 +name: cardano-wallet-benchmarks +version: 2023.4.14 +synopsis: Benchmarks for the `cardano-wallet` exectuable. +description: This package is a collection of benchmarks + for the `cardano-wallet` exectuable. + It currently comprises a memory benchmark (heap profile). +homepage: https://github.com/cardano-foundation/cardano-wallet +author: High Assurance Lab at Cardano Foundation +maintainer: cardanofoundation.org +copyright: 2023 Cardano Foundation +license: Apache-2.0 +category: Web +build-type: Simple + +common language + ghc-options: -threaded -Wall + default-language: Haskell2010 + default-extensions: + NamedFieldPuns + NoImplicitPrelude + OverloadedStrings + +benchmark memory + import: language + type: exitcode-stdio-1.0 + hs-source-dirs: bench + main-is: memory-benchmark.hs + build-depends: + , base + , cardano-wallet-launcher + , cardano-wallet-test-utils + , containers + , contra-tracer + , filepath + , fmt + , iohk-monitoring + , network + , process + , temporary + , text + , text-class + , transformers diff --git a/lib/wallet-benchmarks/data/membench-snapshot.tgz b/lib/wallet-benchmarks/data/membench-snapshot.tgz new file mode 100644 index 00000000000..2222d725d5b Binary files /dev/null and b/lib/wallet-benchmarks/data/membench-snapshot.tgz differ diff --git a/lib/wallet/src/Cardano/Wallet.hs b/lib/wallet/src/Cardano/Wallet.hs index c565c1cd01e..b950e947116 100644 --- a/lib/wallet/src/Cardano/Wallet.hs +++ b/lib/wallet/src/Cardano/Wallet.hs @@ -635,7 +635,7 @@ import Ouroboros.Consensus.Util.IOLike import Statistics.Quantile ( medianUnbiased, quantiles ) import UnliftIO.Exception - ( Exception, catch, evaluate, throwIO ) + ( Exception, catch, evaluate, throwIO, try ) import UnliftIO.MVar ( modifyMVar_, newMVar ) @@ -910,14 +910,32 @@ readDelegation walletState = do dels <- view #delegations <$> readDBVar walletState pure $ \dsarg -> Dlgs.readDelegation dsarg dels +-- | Return information about the current epoch. +-- +-- In the event that wall clock time is too far ahead of the node, +-- we return the epoch of the node tip. getCurrentEpochSlotting :: NetworkLayer IO block -> IO CurrentEpochSlotting getCurrentEpochSlotting nl = do - epoch <- Slotting.currentEpoch ti + epoch <- getCurrentEpoch mkCurrentEpochSlotting ti epoch where - ti = neverFails "currentEpoch is past horizon" $ timeInterpreter nl + ti = Slotting.expectAndThrowFailures $ timeInterpreter nl + + getCurrentEpoch = + currentEpochFromWallClock >>= \case + Right a -> pure a + Left _ -> currentEpochFromNodeTip + + currentEpochFromNodeTip :: IO W.EpochNo + currentEpochFromNodeTip = do + tip <- currentNodeTip nl + interpretQuery ti $ Slotting.epochOf $ tip ^. #slotNo + + currentEpochFromWallClock :: IO (Either PastHorizonException W.EpochNo) + currentEpochFromWallClock = + try $ Slotting.currentEpoch ti -- | Retrieve the wallet state for the wallet with the given ID. readWallet