{-# LANGUAGE OverloadedStrings #-} module Instana.SDK.IntegrationTest.Runner (runSuites) where import qualified Data.ByteString.Lazy.Char8 as LBSC8 import Data.List as List import qualified Data.Maybe as Maybe import qualified Network.HTTP.Client as HTTP import System.Exit as Exit import System.Process as Process import Test.HUnit import qualified Instana.SDK.IntegrationTest.HttpHelper as HttpHelper import Instana.SDK.IntegrationTest.HUnitExtra (mergeCounts) import Instana.SDK.IntegrationTest.Suite (ConditionalSuite (..), Suite) import qualified Instana.SDK.IntegrationTest.Suite as Suite import qualified Instana.SDK.IntegrationTest.TestHelper as TestHelper import Instana.SDK.IntegrationTest.Util (putStrFlush) {-| Runs a collection of test suites. -} runSuites :: [ConditionalSuite] -> IO Counts runSuites allSuites = do let exlusiveSuites = List.filter Suite.isExclusive allSuites (actions, skippedDueToExlusive) = if not (null exlusiveSuites) then ( List.map runConditionalSuite exlusiveSuites , length allSuites - length exlusiveSuites ) else (List.map runConditionalSuite allSuites, 0) if not (null exlusiveSuites) then putStrLn $ "\n\nRunning only " ++ show (List.length exlusiveSuites) ++ " suite(s) marked as exclusive, ignoring all others." else putStrLn $ "\n\nRunning " ++ show (List.length allSuites) ++ " test suite(s)." results <- sequence actions let mergedResults = mergeCounts results caseCount = cases mergedResults + skippedDueToExlusive triedCount = tried mergedResults errCount = errors mergedResults failCount = failures mergedResults putStrLn $ "SUMMARY: Cases: " ++ show caseCount ++ " Tried: " ++ show triedCount ++ " Errors: " ++ show errCount ++ " Failures: " ++ show failCount if errCount > 0 && failCount > 0 then Exit.die "šŸ˜± šŸ˜­ There have been errors and failures! šŸ˜± šŸ˜­" else if errCount > 0 then Exit.die "šŸ˜± There have been errors! šŸ˜±" else if failCount > 0 then Exit.die "šŸ˜­ There have been test failures. šŸ˜­" else putStrLn "šŸŽ‰ All tests have passed. šŸŽ‰" return mergedResults {-| Runs the suite unless it is skipped. -} runConditionalSuite :: ConditionalSuite -> IO Counts runConditionalSuite conditionalSuite = do case conditionalSuite of Run suite -> runSuite suite Exclusive suite -> runSuite suite Skip _ -> return $ Counts 1 0 0 0 {-| Starts the app under test and the agent stub, then runs the test suite. -} runSuite :: Suite -> IO Counts runSuite suite = do let suiteLabel = Suite.label suite putStrFlush $ "\nExecuting test suite: " ++ suiteLabel ++ "\n\n" let options = Suite.options suite customAgentName = Suite.customAgentName options agentStubCommand = (if Suite.usePidTranslation options then "SIMULATE_PID_TRANSLATION=true " else "" ) ++ (if Maybe.isJust customAgentName then let Just agentName = customAgentName in "AGENT_NAME=\"" ++ agentName ++ "\" " else "" ) ++ (if Suite.startupDelay options then "STARTUP_DELAY=2500 " else "" ) ++ (if Suite.simulateConnectionLoss options then "SIMULATE_CONNECTION_LOSS=true " else "" ) ++ "stack exec instana-haskell-agent-stub" appCommand = (if Maybe.isJust customAgentName then let Just agentName = customAgentName in "INSTANA_AGENT_NAME=\"" ++ agentName ++ "\" " else "" ) ++ "INSTANA_LOG_LEVEL=INFO " ++ "stack exec instana-haskell-test-wai-server" putStrLn $ "Running: " ++ agentStubCommand Process.withCreateProcess (Process.shell agentStubCommand) (\_ _ _ _ -> do putStrLn $ "Running: " ++ appCommand Process.withCreateProcess (Process.shell appCommand) (\_ _ _ _ -> runTests suite) ) runTests :: Suite -> IO Counts runTests suite = do putStrFlush "ā± waiting for agent stub to come up" _ <- HttpHelper.retryRequestRecovering TestHelper.pingAgentStub putStrLn "\nāœ… agent stub is up" putStrFlush "ā± waiting for app to come up" appPingResponse <- HttpHelper.retryRequestRecovering TestHelper.pingApp let appPingBody = HTTP.responseBody appPingResponse appPid = (read (LBSC8.unpack appPingBody) :: Int) putStrLn $ "\nāœ… app is up, PID is " ++ (show appPid) results <- waitForAgentConnectionAndRun suite appPid -- The withProcess calls that starts the agent stub and the external app -- should also terminate them when the test suite is done or when an error -- occurs while running the test suite. On MacOS, this works. On Linux, these -- processes do not get terminated, for the following reasons: They are -- started via -- "/bin/sh -c \"stack exec ...\"" and Process.createWith will send a TERM -- signal to terminate the started process. On Linux, this results only in the -- "bin/sh" process to be terminated, but the "stack exec" not. Thus, the -- first started agent stub/app instance would never be shut down. To make -- sure the process instances get shut down, we send an extra HTTP request to -- ask the processes to terminate themselves. _ <- TestHelper.shutDownAgentStub _ <- TestHelper.shutDownApp return results -- |Waits for the app under test to establish a connection to the agent, then -- runs the tests of the given suite. waitForAgentConnectionAndRun :: Suite -> Int -> IO Counts waitForAgentConnectionAndRun suite appPid = do let options = Suite.options suite discoveries <- TestHelper.waitForExternalAgentConnection (Suite.usePidTranslation options) appPid case discoveries of Left message -> assertFailure $ "Could not start test suites " ++ (Suite.label suite) ++ ". The agent connection could not be established: " ++ message Right (_, pid) -> runTestSuite pid suite runTestSuite :: String -> Suite -> IO Counts runTestSuite pid suite = do integrationTestsIO <- wrapSuite pid suite runTestTT integrationTestsIO wrapSuite :: String -> Suite -> IO Test wrapSuite pid suite = do let label = Suite.label suite testsIO = (Suite.tests suite) pid -- Reset the agent stub's recordeds spans after each test, but do not reset -- the discoveries, as all tests of one suite share the connection -- establishment process. testsWithReset = List.map (\testIO -> testIO >>= (\testResult -> TestHelper.resetSpans >> return testResult) ) testsIO -- sequence all tests into one action tests <- sequence testsWithReset return $ TestLabel label $ TestList tests