content: {-# LANGUAGE RecordWildCards #-}
  
  -- | Benchmark for protocols.
  module Language.Marlowe.Runtime.Benchmark (
    -- * Benchmarking
    BenchmarkConfig (..),
    LifecycleBenchmarkContext (..),
    Faucet (..),
    measure,
  ) where
  
  import Control.Monad (unless, when)
  import Control.Monad.IO.Class (liftIO)
  import Control.Monad.Trans.Marlowe (MarloweT)
  import Data.Aeson (FromJSON, ToJSON)
  import Data.Default (Default (..))
  import Data.Maybe (isJust)
  import Data.Time.Clock (getCurrentTime)
  import Data.Word (Word8)
  import GHC.Generics (Generic)
  import Language.Marlowe.Runtime.Benchmark.Query (Query (..))
  import Language.Marlowe.Runtime.ChainSync.Api (Address)
  import System.Directory (doesFileExist, removeFile)
  import System.IO (hPutStrLn, stderr)
  
  import qualified Cardano.Api as C
  import qualified Data.Aeson as A (encode)
  import qualified Data.ByteString.Lazy.Char8 as LBS8 (appendFile, putStrLn, unlines)
  import qualified Data.Map.Strict as M (Map, empty, null, toList)
  import qualified Language.Marlowe.Runtime.Benchmark.BulkSync as Bulk (measure)
  import qualified Language.Marlowe.Runtime.Benchmark.HeaderSync as HeaderSync (measure)
  import qualified Language.Marlowe.Runtime.Benchmark.Lifecycle as Lifecycle (measure)
  import qualified Language.Marlowe.Runtime.Benchmark.Query as Query (measure)
  import qualified Language.Marlowe.Runtime.Benchmark.Sync as Sync (measure)
  
  data Faucet = Faucet
    { address :: Address
    , privateKey :: C.SigningKey C.PaymentExtendedKey
    }
    deriving (Show)
  
  data LifecycleBenchmarkContext = LifecycleBenchmarkContext
    { nodeSocketPath :: C.SocketPath
    , networkId :: C.NetworkId
    , faucet :: Faucet
    }
    deriving (Show)
  
  -- | Benchmark configuration.
  data BenchmarkConfig = BenchmarkConfig
    { headerSyncParallelism :: Int
    -- ^ Number of parallel clients for `HeaderSync` protocol.
    , headerMaxContracts :: Int
    -- ^ Maximum number of contracts to be read by each `HeaderSync` client.
    , bulkParallelism :: Int
    -- ^ Number of parallel clients for the `BulkSync` protocol.
    , bulkPageSize :: Word8
    -- ^ Number of blocks to fetch at a time for the `BulkSync` clients.
    , bulkMaxBlocks :: Int
    -- ^ Maximum number of blocks to fetch for each `BulkSync` client.
    , syncParallelism :: Int
    -- ^ Number of parallel clients for `Sync` protocol.
    , syncBatchSize :: Int
    -- ^ Number of contracts to be read by each `Sync` client.
    , queryParallelism :: Int
    -- ^ Number of parallel clients for `Query` protocol.
    , queryBatchSize :: Int
    -- ^ Number of queries to be executed by each `Query` client.
    , queryPageSize :: Int
    -- ^ Page size for each `Query` client.
    , complexQueries :: M.Map String Query
    -- ^ Set of complex queries to be executed sequentially.
    , lifecycleParallelism :: Int
    -- ^ Number of parallel clients for basic transaction lifecycle.
    , lifecycleContracts :: Int
    -- ^ Number of contracts to be run by each basic transaction lifecycle client.
    }
    deriving (Eq, FromJSON, Generic, Ord, Show, ToJSON)
  
  instance Default BenchmarkConfig where
    def =
      BenchmarkConfig
        { headerSyncParallelism = 4
        , headerMaxContracts = maxBound
        , bulkParallelism = 4
        , bulkPageSize = 128
        , bulkMaxBlocks = maxBound
        , syncParallelism = 4
        , syncBatchSize = 512
        , queryParallelism = 4
        , queryBatchSize = 16
        , queryPageSize = 256
        , complexQueries = M.empty
        , lifecycleParallelism = 4
        , lifecycleContracts = 3
        }
  
  -- | Run the benchmarks.
  measure
    :: (C.IsShelleyBasedEra era)
    => BenchmarkConfig
    -> C.BabbageEraOnwards era
    -> Maybe LifecycleBenchmarkContext
    -> Maybe FilePath
    -> MarloweT IO ()
  measure BenchmarkConfig{..} eraOnwards lifecycleBenchmarkContextMaybe out =
    do
      liftIO $
        maybe
          (pure ())
          (\out' -> do exists <- doesFileExist out'; when exists $ removeFile out')
          out
      let report x =
            liftIO $ case out of
              Nothing -> mapM_ (LBS8.putStrLn . A.encode) x
              Just out' -> LBS8.appendFile out' $ LBS8.unlines $ A.encode <$> x
      when (headerSyncParallelism > 0) $
        do
          liftIO $ hPutStrLn stderr . ("HeaderSync: " <>) . show =<< getCurrentTime
          (headerSyncResults, contractIds) <- HeaderSync.measure headerSyncParallelism headerMaxContracts
          report headerSyncResults
          when (bulkParallelism > 0) $
            do
              liftIO $ hPutStrLn stderr . ("BulkSync: " <>) . show =<< getCurrentTime
              Bulk.measure bulkParallelism bulkPageSize bulkMaxBlocks
                >>= report
          when (syncParallelism > 0) $
            do
              liftIO $ hPutStrLn stderr . ("Sync: " <>) . show =<< getCurrentTime
              Sync.measure syncParallelism syncBatchSize contractIds
                >>= report
          when (queryParallelism > 0) $
            do
              liftIO $ hPutStrLn stderr . ("Query: " <>) . show =<< getCurrentTime
              Query.measure
                queryParallelism
                queryBatchSize
                queryPageSize
                "No policy ID"
                (replicate (queryParallelism * queryBatchSize) (QueryHeaders mempty))
                >>= report
          unless (M.null complexQueries) $
            do
              liftIO $ hPutStrLn stderr . ("Complex queries: " <>) . show =<< getCurrentTime
              sequence_
                [ Query.measure 1 1 queryPageSize label [query] >>= report
                | (label, query) <- M.toList complexQueries
                ]
      when (isJust lifecycleBenchmarkContextMaybe && lifecycleParallelism > 0) $
        do
          Just (LifecycleBenchmarkContext{..}) <- pure lifecycleBenchmarkContextMaybe
          liftIO $ hPutStrLn stderr . ("Lifecycle: " <>) . show =<< getCurrentTime
          lifecycleResults <-
            Lifecycle.measure
              nodeSocketPath
              eraOnwards
              networkId
              lifecycleParallelism
              (address faucet)
              (privateKey faucet)
              lifecycleContracts
          report lifecycleResults
      liftIO $ hPutStrLn stderr . ("Done: " <>) . show =<< getCurrentTime
  