grapesy-1.0.0: test-stress/Main.hs

{-# LANGUAGE CPP #-}

module Main (main) where

import Control.Exception
import GHC.Conc (setUncaughtExceptionHandler)
import System.IO.Temp (writeSystemTempFile)
import Text.Show.Pretty (dumpStr)

#if defined(PROFILING) && MIN_VERSION_base(4,20,0)
import Control.Exception.Backtrace
#endif

import Test.Stress.Client
import Test.Stress.Cmdline
import Test.Stress.Driver
import Test.Stress.Common (say)
import Test.Stress.Server

{-------------------------------------------------------------------------------
  Stress tests

  Unlike the regular test suite, we support running the client and the server in
  separate processes, so that we can run each with their own set of RTS flags.
-------------------------------------------------------------------------------}

main :: IO ()
main = do
#if defined(PROFILING) && MIN_VERSION_base(4,20,0)
    setBacktraceMechanismState CostCentreBacktrace True
#endif

    -- Parse command-line options
    cmdline@Cmdline{..} <- getCmdline
    say (optsTracing cmdGlobalOpts) $
      "parsed command-line options: " ++ show cmdline

    setUncaughtExceptionHandler $ handleUncaughtExceptions cmdline

    case cmdRole of
      Client{..} ->
        client
          (optsTracing cmdGlobalOpts)
          (unwrapNotPretty <$> clientSecurity)
          clientServerPort
          (unwrapNotPretty <$> clientCompression)
          clientConnects
      Server{..} ->
        server
          (optsTracing cmdGlobalOpts)
          serverConfig
      Driver{..} ->
        driver
          (optsTracing cmdGlobalOpts)
          driverGenCharts
          driverWorkingDir
          driverDuration

handleUncaughtExceptions :: Cmdline -> SomeException -> IO ()
handleUncaughtExceptions cmdline e = do
    fp <- writeSystemTempFile "test-stress" $ unlines [
        dumpStr cmdline
      , displayException e
      ]
    putStrLn $ "Abnormal termination. See " ++ show fp