Merge #1829

1829: Begin porting latency benchmark to shelley r=piotr-iohk a=rvl

Relates to #1825

# Overview

These refactors are the start of porting the latency bench from the byron backend to the shelley backend.

The measurement and reporting code is split into a separate module.

The bench scenario functions are reworked so that swapping backend will be easier.


Co-authored-by: Rodney Lorrimar <[email protected]>

lib/byron/cardano-wallet-byron.cabal

@@ -277,8 +277,6 @@ benchmark latency
    , stm
    , temporary
    , text
-   , text-class
-   , time
   build-tools:
       cardano-wallet-byron
   type:

lib/core-integration/cardano-wallet-core-integration.cabal

@@ -47,16 +47,19 @@ library
     , directory
     , exceptions
     , extra
+    , fmt
     , generic-lens
     , hspec
     , hspec-expectations-lifted
     , http-api-data
     , http-client
     , http-types
+    , iohk-monitoring
     , memory
     , process
     , retry
     , scrypt
+    , stm
     , template-haskell
     , text
     , text-class
@@ -92,3 +95,4 @@ library
       Test.Integration.Scenario.CLI.Network
       Test.Integration.Scenario.CLI.Port
       Cardano.Wallet.TransactionSpecShared
+      Cardano.Wallet.LatencyBenchShared

lib/core-integration/src/Cardano/Wallet/LatencyBenchShared.hs

@@ -0,0 +1,143 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+
+module Cardano.Wallet.LatencyBenchShared
+  ( -- * Measuring traces
+    withLatencyLogging
+  , measureApiLogs
+  , LogCaptureFunc
+
+    -- * Formatting results
+  , fmtResult
+  , fmtTitle
+  ) where
+
+import Prelude
+
+import Cardano.BM.Backend.Switchboard
+    ( effectuate )
+import Cardano.BM.Configuration.Static
+    ( defaultConfigStdout )
+import Cardano.BM.Data.LogItem
+    ( LOContent (..), LOMeta (..), LogObject (..) )
+import Cardano.BM.Data.Severity
+    ( Severity (..) )
+import Cardano.BM.Setup
+    ( setupTrace_, shutdown )
+import Control.Concurrent.STM.TVar
+    ( TVar, newTVarIO, readTVarIO, writeTVar )
+import Control.Exception
+    ( bracket, onException )
+import Control.Monad
+    ( mapM_, replicateM_ )
+import Control.Monad.STM
+    ( atomically )
+import Data.Maybe
+    ( mapMaybe )
+import Data.Time
+    ( NominalDiffTime )
+import Data.Time.Clock
+    ( diffUTCTime )
+import Fmt
+    ( Builder, build, fixedF, fmt, fmtLn, indentF, padLeftF, (+|), (|+) )
+import Network.Wai.Middleware.Logging
+    ( ApiLog (..), HandlerLog (..) )
+
+import qualified Cardano.BM.Configuration.Model as CM
+
+meanAvg :: [NominalDiffTime] -> Double
+meanAvg ts = sum (map realToFrac ts) * 1000 / fromIntegral (length ts)
+
+buildResult :: [NominalDiffTime] -> Builder
+buildResult [] = "ERR"
+buildResult ts = build $ fixedF 1 $ meanAvg ts
+
+fmtTitle :: Builder -> IO ()
+fmtTitle title = fmt (indentF 4 title)
+
+fmtResult :: String -> [NominalDiffTime] -> IO ()
+fmtResult title ts =
+    let titleExt = title|+" - " :: String
+        titleF = padLeftF 30 ' ' titleExt
+    in fmtLn (titleF+|buildResult ts|+" ms")
+
+isLogRequestStart :: ApiLog -> Bool
+isLogRequestStart = \case
+    ApiLog _ LogRequestStart -> True
+    _ -> False
+
+isLogRequestFinish :: ApiLog -> Bool
+isLogRequestFinish = \case
+    ApiLog _ LogRequestFinish -> True
+    _ -> False
+
+measureApiLogs :: LogCaptureFunc ApiLog () -> IO a -> IO [NominalDiffTime]
+measureApiLogs = measureLatency isLogRequestStart isLogRequestFinish
+
+-- | Run tests for at least this long to get accurate timings.
+sampleNTimes :: Int
+sampleNTimes = 10
+
+-- | Measure how long an action takes based on trace points and taking an
+-- average of results over a short time period.
+measureLatency
+    :: (msg -> Bool) -- ^ Predicate for start message
+    -> (msg -> Bool) -- ^ Predicate for end message
+    -> LogCaptureFunc msg () -- ^ Log capture function.
+    -> IO a -- ^ Action to run
+    -> IO [NominalDiffTime]
+measureLatency start finish capture action = do
+    (logs, ()) <- capture $ replicateM_ sampleNTimes action
+    pure $ extractTimings start finish logs
+
+-- | Scan through iohk-monitoring logs and extract time differences between
+-- start and end messages.
+extractTimings
+    :: (a -> Bool) -- ^ Predicate for start message
+    -> (a -> Bool) -- ^ Predicate for end message
+    -> [LogObject a] -- ^ Log messages
+    -> [NominalDiffTime]
+extractTimings isStart isFinish msgs = map2 mkDiff filtered
+  where
+    map2 _ [] = []
+    map2 f (a:b:xs) = (f a b:map2 f xs)
+    map2 _ _ = error "start trace without matching finish trace"
+
+    mkDiff (False, start) (True, finish) = diffUTCTime finish start
+    mkDiff (False, _) _ = error "missing finish trace"
+    mkDiff (True, _) _ = error "missing start trace"
+
+    filtered = mapMaybe filterMsg msgs
+    filterMsg logObj = case loContent logObj of
+        LogMessage msg | isStart msg -> Just (False, getTimestamp logObj)
+        LogMessage msg | isFinish msg -> Just (True, getTimestamp logObj)
+        _ -> Nothing
+    getTimestamp = tstamp . loMeta
+
+
+type LogCaptureFunc msg b = IO b -> IO ([LogObject msg], b)
+
+withLatencyLogging
+    :: (TVar [LogObject ApiLog] -> tracers)
+    -> (tracers -> LogCaptureFunc ApiLog b -> IO a)
+    -> IO a
+withLatencyLogging setupTracers action = do
+    tvar <- newTVarIO []
+    cfg <- defaultConfigStdout
+    CM.setMinSeverity cfg Debug
+    bracket (setupTrace_ cfg "bench-latency") (shutdown . snd) $ \(_, sb) -> do
+        action (setupTracers tvar) (logCaptureFunc tvar) `onException` do
+            fmtLn "Action failed. Here are the captured logs:"
+            readTVarIO tvar >>= mapM_ (effectuate sb) . reverse
+
+logCaptureFunc :: TVar [LogObject ApiLog] -> LogCaptureFunc ApiLog b
+logCaptureFunc tvar action = do
+  atomically $ writeTVar tvar []
+  res <- action
+  logs <- readTVarIO tvar
+  pure (reverse logs, res)

lib/core/src/Network/Wai/Middleware/Logging.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE LambdaCase #-}
@@ -30,6 +31,8 @@ import Cardano.BM.Data.Severity
     ( Severity (..) )
 import Cardano.BM.Data.Tracer
     ( HasPrivacyAnnotation (..), HasSeverityAnnotation (..) )
+import Cardano.BM.Tracing
+    ( ToObject )
 import Control.Applicative
     ( (<|>) )
 import Control.Arrow
@@ -39,7 +42,7 @@ import Control.Concurrent.MVar
 import Control.Tracer
     ( Tracer, contramap, traceWith )
 import Data.Aeson
-    ( Value (..) )
+    ( FromJSON (..), ToJSON (..), Value (..) )
 import Data.ByteString
     ( ByteString )
 import Data.ByteString.Builder
@@ -117,7 +120,7 @@ data ApiLoggerSettings = ApiLoggerSettings
 
 -- | Just a wrapper for readability
 newtype RequestId = RequestId Integer
-    deriving (Generic, Show, Eq)
+    deriving (Generic, Show, Eq, ToJSON)
 
 -- | Create a new opaque 'ApiLoggerSettings'
 newApiLoggerSettings :: IO ApiLoggerSettings
@@ -216,7 +219,7 @@ data ApiLog = ApiLog
     -- ^ Unique integer associated with the request, for the purpose of tracing.
     , logMsg :: HandlerLog
     -- ^ Event trace for the handler.
-    } deriving (Generic, Show)
+    } deriving (Generic, Show, ToJSON)
 
 instance HasPrivacyAnnotation ApiLog where
     getPrivacyAnnotation (ApiLog _ msg) = getPrivacyAnnotation msg
@@ -229,6 +232,11 @@ instance ToText ApiLog where
         "[" <> T.pack (show rid) <> "] "
         <> toText msg
 
+-- These instance are required by iohk-monitoring
+instance ToObject ApiLog
+instance FromJSON ApiLog where
+    parseJSON _ = fail "FromJSON ApiLog stub"
+
 -- | Tracer events related to the handling of a single request.
 data HandlerLog
     = LogRequestStart
@@ -257,6 +265,9 @@ instance ToText HandlerLog where
         LogResponseBody body -> T.decodeUtf8 body
         LogRequestFinish -> "Completed response to API request"
 
+instance ToJSON HandlerLog where
+    toJSON = String . toText
+
 -- | Removes sensitive details from valid request payloads and completely
 -- obfuscate invalid payloads.
 sanitize :: [Text] -> ByteString -> Text

lib/jormungandr/cardano-wallet-jormungandr.cabal

@@ -312,8 +312,6 @@ benchmark latency
     , stm
     , temporary
     , text
-    , text-class
-    , time
   build-tools:
       cardano-wallet-jormungandr
   type: