{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Instana.SDK.IntegrationTest.SpecCompliance
  ( allTestsW3cCorrelationOn
  , allTestsW3cCorrelationOff
  ) where


import           Control.Concurrent                     (threadDelay)
import           Data.Aeson                             ((.:), (.:?), (.=))
import qualified Data.Aeson                             as Aeson
import           Data.Aeson.Types                       (FromJSON)
import qualified Data.Aeson.Types                       as AesonTypes
import           Data.Array                             ((!))
import qualified Data.Array                             as Array
import qualified Data.ByteString.Char8                  as BSC8
import qualified Data.ByteString.Lazy.Char8             as LBSC8
import qualified Data.CaseInsensitive                   as CI
import           Data.HashMap.Strict                    (HashMap)
import qualified Data.HashMap.Strict                    as HashMap
import           Data.Maybe                             (catMaybes, isNothing,
                                                         listToMaybe)
import           Data.Text                              (Text)
import qualified Data.Text                              as T
import qualified Data.Vector                            as Vector
import           Instana.SDK.AgentStub.TraceRequest     (From (..),
                                                         InstanaAncestor, Span)
import qualified Instana.SDK.AgentStub.TraceRequest     as TraceRequest
import           Instana.SDK.IntegrationTest.HUnitExtra (applyLabel,
                                                         assertAllIO, failIO)
import qualified Instana.SDK.IntegrationTest.HttpHelper as HttpHelper
import           Instana.SDK.IntegrationTest.Suite      (AppUnderTest)
import qualified Instana.SDK.IntegrationTest.TestHelper as TestHelper
import qualified Network.HTTP.Client                    as HTTP
import           Network.HTTP.Types                     (Header)
import qualified Network.HTTP.Types.Header
import           Test.HUnit
import qualified Text.Regex.Base.RegexLike              as RegexBase
import           Text.Regex.TDFA.String                 (Regex)


data RunSubsetOfCases =
    RunAll
  | RunSubset [Int]


testCasesToRun :: RunSubsetOfCases
testCasesToRun = RunAll


allTestsW3cCorrelationOn ::
  Aeson.Array
  -> AppUnderTest
  -> String
  -> String
  -> [IO Test]
allTestsW3cCorrelationOn
    specificationComplianceTestCases
    appUnderTest
    route
    pid = do
  jsonToTestCases
    appUnderTest
    False
    route
    pid
    specificationComplianceTestCases


allTestsW3cCorrelationOff ::
  Aeson.Array
  -> AppUnderTest
  -> String
  -> String
  -> [IO Test]
allTestsW3cCorrelationOff
    specificationComplianceTestCases
    appUnderTest
    route
    pid =
  jsonToTestCases
    appUnderTest
    True
    route
    pid
    specificationComplianceTestCases


data SpecTestCase = SpecTestCase
  { index                 :: Int
  , scenario              :: String
  , whatToDo              :: String
  , disableW3cCorrelation :: Maybe Text
  , xInstanaTIn           :: Maybe String
  , xInstanaSIn           :: Maybe String
  , xInstanaLIn           :: Maybe String
  , xInstanaSyntheticIn   :: Maybe String
  , traceparentIn         :: Maybe String
  , tracestateIn          :: Maybe String
  , serverTiming          :: Maybe String
  , entrySpanT            :: Maybe String
  , entrySpanP            :: Maybe String
  , entrySpanS            :: Maybe String
  , entrySpanIa           :: Maybe InstanaAncestor
  , entrySpanTp           :: Maybe Bool
  , entrySpanLt           :: Maybe String
  , entrySpanCrid         :: Maybe String
  , entrySpanCrtp         :: Maybe String
  , entrySpanSy           :: Maybe Bool
  , exitSpanT             :: Maybe String
  , exitSpanP             :: Maybe String
  , exitSpanS             :: Maybe String
  , exitSpanIa            :: Maybe InstanaAncestor
  , exitSpanTp            :: Maybe Bool
  , exitSpanLt            :: Maybe String
  , exitSpanCrid          :: Maybe String
  , exitSpanCrtp          :: Maybe String
  , exitSpanSy            :: Maybe Bool
  , xInstanaTOut          :: Maybe String
  , xInstanaSOut          :: Maybe String
  , xInstanaLOut          :: Maybe String
  , traceparentOut        :: Maybe String
  , tracestateOut         :: Maybe String
  }
  deriving (Show)


instance FromJSON SpecTestCase where
  parseJSON = Aeson.withObject "Spec Test Case" $
    \obj ->
      SpecTestCase
        <$> obj .: "index"
        <*> obj .: "Scenario/incoming headers"
        <*> obj .: "What to do?"
        <*> obj .:? "INSTANA_DISABLE_W3C_TRACE_CORRELATION"
        <*> obj .:? "X-INSTANA-T in"
        <*> obj .:? "X-INSTANA-S in"
        <*> obj .:? "X-INSTANA-L in"
        <*> obj .:? "X-INSTANA-SYNTHETIC in"
        <*> obj .:? "traceparent in"
        <*> obj .:? "tracestate in"
        <*> obj .:? "Server-Timing"
        <*> obj .:? "entrySpan.t"
        <*> obj .:? "entrySpan.p"
        <*> obj .:? "entrySpan.s"
        <*> obj .:? "entrySpan.ia"
        <*> obj .:? "entrySpan.tp"
        <*> obj .:? "entrySpan.lt"
        <*> obj .:? "entrySpan.crid"
        <*> obj .:? "entrySpan.crtp"
        <*> obj .:? "entrySpan.sy"
        <*> obj .:? "exitSpan.t"
        <*> obj .:? "exitSpan.p"
        <*> obj .:? "exitSpan.s"
        <*> obj .:? "exitSpan.ia"
        <*> obj .:? "exitSpan.tp"
        <*> obj .:? "exitSpan.lt"
        <*> obj .:? "exitSpan.crid"
        <*> obj .:? "exitSpan.crtp"
        <*> obj .:? "exitSpan.sy"
        <*> obj .:? "X-INSTANA-T out"
        <*> obj .:? "X-INSTANA-S out"
        <*> obj .:? "X-INSTANA-L out"
        <*> obj .:? "traceparent out"
        <*> obj .:? "tracestate out"


type ValueForPlaceholder = (Text, Text)


type ValuesForPlaceholders = [ValueForPlaceholder]


type TestContext = ([Assertion], ValuesForPlaceholders)


addAssertion :: Assertion -> TestContext -> TestContext
addAssertion newAssertion (existingAssertions, valuesForPlaceholders) =
  (existingAssertions ++ [newAssertion], valuesForPlaceholders)


addAssertions :: [Assertion] -> TestContext -> TestContext
addAssertions newAssertions (existingAssertions, valuesForPlaceholders) =
  (existingAssertions ++ newAssertions, valuesForPlaceholders)


addPlaceholderValue :: ValueForPlaceholder -> TestContext -> TestContext
addPlaceholderValue newValue (assertions, valuesForPlaceholders) =
  (assertions, valuesForPlaceholders ++ [newValue])


data ExpectedActual =
    S String
  | MS (Maybe String)
  | MIA (Maybe InstanaAncestor)
  | MB (Maybe Bool)


instance Eq ExpectedActual where
  S s1 == S s2 =
    s1 == s2
  S s1 == MS (Just s2) =
    s1 == s2
  S _ == MS Nothing =
    False
  MS ms1 == S s2 =
    S s2 == MS ms1
  S _ == MIA _ =
    False
  MIA _ == S _ =
    False
  S _ == MB _ =
    False
  MB _ == S _ =
    False
  MS ms1 == MS ms2 =
    ms1 == ms2
  MS _ == MIA _ =
    False
  MIA _ == MS _ =
    False
  MS _ == MB _ =
    False
  MB _ == MS _ =
    False
  MIA mia1 == MIA mia2 =
    mia1 == mia2
  MIA _ == MB _ =
    False
  MB _ == MIA _ =
    False
  MB mb1 == MB mb2 =
    mb1 == mb2


instance Show ExpectedActual where
  show (S s)    = show s
  show (MS ms)  = show ms
  show (MIA ia) = show ia
  show (MB mb)  = show mb


unpack :: ExpectedActual -> String
unpack (S s)         = s
unpack (MS (Just s)) = s
unpack (MS Nothing)  = "Nothing"
unpack (MIA ia)      = show ia
unpack (MB mb)       = show mb


jsonToTestCases ::
  AppUnderTest
  -> Bool
  -> String
  -> String
  -> Aeson.Array
  -> [IO Test]
jsonToTestCases
    appUnderTest
    w3cCorrelationDisabled
    route
    pid
    allTestCaseAsJson = do
  let
    testCasesDefinitionAesonValues = Vector.toList allTestCaseAsJson
    testCasesDefinitionEitherValues :: [Either String SpecTestCase]
    testCasesDefinitionEitherValues =
      map jsonToTestCaseDefinition testCasesDefinitionAesonValues
    testCasesDefinitions :: [SpecTestCase]
    testCasesDefinitions =
      map
        (\testCaseDefinitionEither ->
          case testCaseDefinitionEither of
            Left errorMessage ->
              -- Could not parse JSON to test case definition.
              -- Because we are lazy, we just let the test suite crash :-)
              error errorMessage
            Right testCaseDefinition ->
              testCaseDefinition
        )
        testCasesDefinitionEitherValues
    testCaseDefinitionsForW3cDisabledSetting :: [SpecTestCase]
    testCaseDefinitionsForW3cDisabledSetting =
      filter
        (\testCaseDefinition ->
          if w3cCorrelationDisabled then
            case disableW3cCorrelation testCaseDefinition of
              Just value ->
                not $ T.null value
              Nothing ->
                False
          else
            case disableW3cCorrelation testCaseDefinition of
              Just value ->
                T.null value
              Nothing ->
                True
        )
        testCasesDefinitions
    testCaseDefinitionsFiltered :: [SpecTestCase]
    testCaseDefinitionsFiltered =
      case testCasesToRun of
        RunAll -> testCaseDefinitionsForW3cDisabledSetting
        RunSubset subset ->
          filter
            (\testCaseDefinition ->
              elem (index testCaseDefinition) subset
            )
            testCaseDefinitionsForW3cDisabledSetting
  map
    (testCaseDefinitionToTest appUnderTest route pid)
    testCaseDefinitionsFiltered


jsonToTestCaseDefinition :: Aeson.Value -> Either String SpecTestCase
jsonToTestCaseDefinition testCaseAsJson =
  AesonTypes.parseEither
    Aeson.parseJSON
    testCaseAsJson :: Either String SpecTestCase


testCaseDefinitionToTest ::
  AppUnderTest
  -> String
  -> String
  -> SpecTestCase
  -> IO Test
testCaseDefinitionToTest appUnderTest route pid testCaseDefinition = do
  let
    label =
      (show $ index testCaseDefinition) ++ ": " ++
      scenario testCaseDefinition ++ " -> " ++
      whatToDo testCaseDefinition
    headers = testCaseDefinitionToHeaders testCaseDefinition
  putStrLn $ "Creating test: " ++ label ++ "\nwith headers:\n" ++ show headers
  putStrLn $ "TEST CASE: " ++ show testCaseDefinition
  applyLabel label $
    runSpecTestCase
      appUnderTest
      route
      pid
      headers
      testCaseDefinition


testCaseDefinitionToHeaders :: SpecTestCase -> [Header]
testCaseDefinitionToHeaders testCaseDefinition =
  catMaybes $
    map toHeader
      [ ("X-INSTANA-T", xInstanaTIn testCaseDefinition)
      , ("X-INSTANA-S", xInstanaSIn testCaseDefinition)
      , ("X-INSTANA-L", xInstanaLIn testCaseDefinition)
      , ("X-INSTANA-SYNTHETIC", xInstanaSyntheticIn testCaseDefinition)
      , ("traceparent", traceparentIn testCaseDefinition)
      , ("tracestate", tracestateIn testCaseDefinition)
      ]
  where
    toHeader (_, Nothing)       = Nothing
    toHeader (name, Just value) = Just (name, BSC8.pack value)


runSpecTestCase ::
  AppUnderTest
  -> String
  -> String
  -> [Header]
  -> SpecTestCase
  -> IO Test
runSpecTestCase appUnderTest route pid headers testCaseDefinition = do
  let
    suppressionHeader =
      filter
        (\(name, value) ->
          (name == (CI.mk (BSC8.pack "X-INSTANA-L"))) &&
          (value == BSC8.pack "0")
        )
        headers
    suppressed =
      (length suppressionHeader) >= 1
  executeRequestAndVerify
    appUnderTest
    testCaseDefinition
    route
    pid
    suppressed
    headers


executeRequestAndVerify ::
  AppUnderTest
  -> SpecTestCase
  -> String
  -> String
  -> Bool
  -> [Header]
  -> IO Test
executeRequestAndVerify
  appUnderTest
  testCaseDefinition
  route
  pid
  suppressed
  headers = do
  response <-
    HttpHelper.doAppRequest
      appUnderTest
      (route ++ "?some=query&parameters=1")
      "GET"
      headers
  let
    initialTestContext = ([], [])

    testContextAfterServerTimingCheck =
       verifyServerTimingHeader
         testCaseDefinition
         initialTestContext
         response

    eitherResponseBody =
      Aeson.eitherDecode' $ HTTP.responseBody response

    from = Just $ From pid "agent-stub-id"

  case eitherResponseBody of
    Right responseBody -> do
      let
        testContextAfterDownstreamHeaderCheck =
           verifyHttpHeadersOnDownstreamRequest
             testCaseDefinition
             testContextAfterServerTimingCheck
             responseBody

      case suppressed of

        False ->
          verifySpans
            testCaseDefinition
            testContextAfterDownstreamHeaderCheck
            route
            responseBody
            from

        True ->
          verifySuppression testContextAfterDownstreamHeaderCheck

    Left decodeError ->
      failIO $ "Could decode HTTP response body: " ++ decodeError


verifyServerTimingHeader ::
  SpecTestCase
  -> TestContext
  -> HTTP.Response LBSC8.ByteString
  -> TestContext
verifyServerTimingHeader testCaseDefinition testContext response =
  let
    responseHeaders = HTTP.responseHeaders response
    serverTimingTuple ::
      Maybe (Network.HTTP.Types.Header.HeaderName, BSC8.ByteString)
    serverTimingTuple =
      listToMaybe $
        filter
          (\ (headerName, _) -> headerName == "Server-Timing")
          responseHeaders
    actualServerTimingValueM = BSC8.unpack <$> (snd <$> serverTimingTuple)
    expectedServerTimingValueM = serverTiming testCaseDefinition
  in
  case (expectedServerTimingValueM, actualServerTimingValueM) of
    (Just expectedServerTimingValue, Just actualServerTimingValue) ->
      if containsPlaceholder expectedServerTimingValue then
        parseForPlaceholders
          testContext
          "Server-Timing header"
          expectedServerTimingValue
          actualServerTimingValue
      else
        addAssertion
          (assertEqual "Server-Timing header"
             expectedServerTimingValue
             actualServerTimingValue
          )
          testContext

    (Just expectedServerTimingValue, Nothing)  ->
      addAssertion
        (assertFailure $ "Expected Server-Timing header " ++
           expectedServerTimingValue ++ ", but got nothing."
        )
        testContext

    (Nothing, Just actualServerTimingValue)  ->
      addAssertion
        (assertFailure $ "Expected no Server-Timing header, but got " ++
            actualServerTimingValue ++ "."
        )
        testContext

    (Nothing, Nothing)  ->
      testContext


verifyHttpHeadersOnDownstreamRequest ::
  SpecTestCase
  -> TestContext
  -> HashMap Text AesonTypes.Value
  -> TestContext
verifyHttpHeadersOnDownstreamRequest
  testCaseDefinition
  testContext
  responseBody =
  let
    testContextAfterXInstanaLCheck =
      addAssertion
        (xInstanaLAssertion responseBody testCaseDefinition)
        testContext
  in
  foldr
    (\(header, accessor) currentTestContext ->
      let
        message =
          "value for downstream HTTP header " ++ (T.unpack header)
        expectedValueM :: Maybe String
        expectedValueM = accessor testCaseDefinition
      in
      case expectedValueM of

        Just expectedValue ->
          if containsPlaceholder expectedValue then
            parseForPlaceholderJsonValue
              currentTestContext
              message
              expectedValue
              (HashMap.lookup header responseBody)
          else
            addAssertion
              (assertEqualInMap message expectedValue header responseBody)
              currentTestContext
        Nothing ->
          addAssertion
            (assertNotInMap message header responseBody)
            currentTestContext
    )
    testContextAfterXInstanaLCheck
    [ ("X-INSTANA-T", xInstanaTOut)
    , ("X-INSTANA-S", xInstanaSOut)
    -- X-INSTANA-L is checked separately via xInstanaLAssertion
    , ("traceparent", traceparentOut)
    , ("tracestate", tracestateOut)
    ]


xInstanaLAssertion :: HashMap Text AesonTypes.Value -> SpecTestCase -> Assertion
xInstanaLAssertion responseBody testCaseDefinition =
  case xInstanaLOut testCaseDefinition of
    Just "1" ->
      let
        actualValueM = HashMap.lookup "X-INSTANA-L" responseBody
      in
      assertBool "Expected X-INSTANA-L to be either absent or \"1\"" $
        (actualValueM == Nothing) || (actualValueM == (Just $ Aeson.String "1"))

    Just "0" ->
      assertEqualInMap
        "value for downstream HTTP header X-INSTANA-L"
        "0"
        "X-INSTANA-L"
        responseBody

    _ ->
      fail $
        "Unexpected expectation value for downstream X-INSTANA-L in test " ++
        "case defintion: " ++
        (show $ xInstanaLOut testCaseDefinition)


verifySpans ::
  SpecTestCase
  -> TestContext
  -> String
  -> HashMap Text AesonTypes.Value
  -> Maybe From
  -> IO Test
verifySpans
  testCaseDefinition
  testContext
  route
  responseBody
  from = do
  spansResults <-
    TestHelper.waitForRegisteredSpansMatching
      [ "haskell.wai.server", "haskell.http.client" ]
  case spansResults of
    Left failure ->
      failIO $ "Could not load recorded spans from agent stub: " ++ failure
    Right spans -> do
      let
        maybeEntrySpan =
          TestHelper.getSpanByRegisteredName "haskell.wai.server" spans
        maybeExitSpan =
          TestHelper.getSpanByRegisteredName "haskell.http.client" spans
      if isNothing maybeEntrySpan || isNothing maybeExitSpan
        then
          failIO "expected spans have not been recorded"
        else do
          let
            Just entrySpan = maybeEntrySpan
            Just exitSpan = maybeExitSpan
            (assertions, _) =
              (spanAssertions
                testCaseDefinition
                testContext
                route
                entrySpan
                exitSpan
                from
              )
          putStrLn $ "ENTRY " ++ show entrySpan
          putStrLn $ "EXIT " ++ show exitSpan
          putStrLn $ "RESPONSE " ++ show responseBody
          assertAllIO $ assertions


spanAssertions ::
  SpecTestCase
  -> TestContext
  -> String
  -> Span
  -> Span
  -> Maybe From
  -> TestContext
spanAssertions
  testCaseDefinition
  testContext
  route
  entrySpan
  exitSpan
  from =
  addAssertions
    (fixedSpanAssertions route entrySpan exitSpan from)
    (spanAssertionsFromTestCaseDefinition
        testCaseDefinition
        testContext
        entrySpan
        exitSpan
    )


fixedSpanAssertions ::
  String
  -> Span
  -> Span
  -> Maybe From
  -> [Assertion]
fixedSpanAssertions route entrySpan exitSpan from =
  [ assertBool "entry timestamp" $ TraceRequest.ts entrySpan > 0
  , assertBool "entry duration" $ TraceRequest.d entrySpan > 0
  , assertEqual "entry kind" 1 (TraceRequest.k entrySpan)
  , assertEqual "entry error count" 0 (TraceRequest.ec entrySpan)
  , assertEqual "entry from" from $ TraceRequest.f entrySpan
  , assertEqual "entry data"
    ( Aeson.object
      [ "http" .= (Aeson.object
          [ "method" .= ("GET" :: String)
          , "host"   .= ("127.0.0.1:1207" :: String)
          , "url"    .= ("/" ++ route)
          , "params" .= ("some=query&parameters=1" :: String)
          , "status" .= (200 :: Int)
          ]
        )
      ]
    )
    (TraceRequest.spanData entrySpan)
  , assertBool "exit timestamp" $ TraceRequest.ts exitSpan > 0
  , assertBool "exit duration" $ TraceRequest.d exitSpan > 0
  , assertEqual "exit kind" 2 (TraceRequest.k exitSpan)
  , assertEqual "exit error count" 0 (TraceRequest.ec exitSpan)
  , assertEqual "exit from" from $ TraceRequest.f exitSpan
  , assertEqual "exit data"
    ( Aeson.object
      [ "http" .= (Aeson.object
          [ "method" .= ("GET" :: String)
          , "url"    .= ("http://127.0.0.1:1208/echo" :: String)
          , "params" .= ("some=query&parameters=2" :: String)
          , "status" .= (200 :: Int)
          ]
        )
      ]
    )
    (TraceRequest.spanData exitSpan)
  ]


spanAssertionsFromTestCaseDefinition ::
  SpecTestCase
  -> TestContext
  -> Span
  -> Span
  -> TestContext
spanAssertionsFromTestCaseDefinition
  testCaseDefinition
  testContext
  entrySpan
  exitSpan =
  let
    testContextAfterEntrySpanChecks =
      verifyEntrySpan testCaseDefinition testContext entrySpan
  in
  verifyExitSpan testCaseDefinition testContextAfterEntrySpanChecks exitSpan


verifyEntrySpan ::
  SpecTestCase
  -> TestContext
  -> Span
  -> TestContext
verifyEntrySpan testCaseDefinition testContext entrySpan =
  verifySpan testCaseDefinition testContext "entry" entrySpan $
    [ ( "t"   , MS  . entrySpanT    , S   . TraceRequest.t    )
    , ( "p"   , MS  . entrySpanP    , MS  . TraceRequest.p    )
    , ( "s"   , MS  . entrySpanS    , S   . TraceRequest.s    )
    , ( "ia"  , MIA . entrySpanIa   , MIA . TraceRequest.ia   )
    , ( "tp"  , MB  . entrySpanTp   , MB  . TraceRequest.tp   )
    , ( "lt"  , MS  . entrySpanLt   , MS  . TraceRequest.lt   )
    , ( "crid", MS  . entrySpanCrid , MS  . TraceRequest.crid )
    , ( "crtp", MS  . entrySpanCrtp , MS  . TraceRequest.crtp )
    , ( "sy"  , MB  . entrySpanSy   , MB  . TraceRequest.sy   )
    ]


verifyExitSpan ::
  SpecTestCase
  -> TestContext
  -> Span
  -> TestContext
verifyExitSpan testCaseDefinition testContext exitSpan =
  verifySpan testCaseDefinition testContext "exit" exitSpan $
  [ ( "t"   , MS  . exitSpanT    , S   . TraceRequest.t    )
  , ( "p"   , MS  . exitSpanP    , MS  . TraceRequest.p    )
  , ( "s"   , MS  . exitSpanS    , S   . TraceRequest.s    )
  , ( "ia"  , MIA . exitSpanIa   , MIA . TraceRequest.ia   )
  , ( "tp"  , MB  . exitSpanTp   , MB  . TraceRequest.tp   )
  , ( "lt"  , MS  . exitSpanLt   , MS  . TraceRequest.lt   )
  , ( "crid", MS  . exitSpanCrid , MS  . TraceRequest.crid )
  , ( "crtp", MS  . exitSpanCrtp , MS  . TraceRequest.crtp )
  , ( "sy"  , MB  . exitSpanSy   , MB  . TraceRequest.sy   )
  ]


verifySpan ::
  SpecTestCase
  -> TestContext
  -> String
  -> Span
  -> [(String, SpecTestCase -> ExpectedActual, Span -> ExpectedActual)]
  -> TestContext
verifySpan testCaseDefinition testContext spanKindLabel span_ accessorPairs =
  foldr
    (\(attributeLabel, testCaseAccesor, spanAccesor) currentTestContext ->
      let
        label = spanKindLabel ++ " span." ++ attributeLabel
        expectedValue = testCaseAccesor testCaseDefinition
        actualValue = spanAccesor span_
      in
      if containsPlaceholder' expectedValue then
        parseForPlaceholders
          currentTestContext
          label
          (unpack expectedValue)
          (unpack actualValue)
      else
        addAssertion
          (assertEqual
            label
            expectedValue
            actualValue
          )
          currentTestContext
    )
    testContext
    accessorPairs


verifySuppression ::
  TestContext
  -> IO Test
verifySuppression (assertions, _) = do
  -- wait a few seconds, then check that no spans have been recorded
  threadDelay $ 5 * 1000 * 1000
  spansResults <-
    TestHelper.waitForRegisteredSpansMatching []
  case spansResults of
    Left failure ->
      failIO $ "Could not load recorded spans from agent stub: " ++ failure
    Right spans -> do
      if not (null spans)
        then
          failIO "spans have been recorded although they should have not"
        else
          assertAllIO $ assertions


containsPlaceholder :: String -> Bool
containsPlaceholder = elem '$'


containsPlaceholder' :: ExpectedActual -> Bool
containsPlaceholder' (S s)         = elem '$' s
containsPlaceholder' (MS (Just s)) = elem '$' s
containsPlaceholder' (MS Nothing)  = False
containsPlaceholder' (MIA _)       = False
containsPlaceholder' (MB _)        = False


parseForPlaceholders ::
  TestContext
  -> String
  -> String
  -> String
  -> TestContext
parseForPlaceholders testContext label template value =
  let
    templateRegex =
      (RegexBase.makeRegex ("\\$[a-z0-9_]+" :: String)) :: Regex

    -- I'm sorry, this is ugly and complicated. To ease the pain, let's follow
    -- along with an example. Assuming we have:
    -- template = 00-0000000000000000$new_64_bit_trace_id-$new_span_id_2-01
    -- value = 00-0000000000000000b9e374754ca092b9-de54a2e7e1ceffc4-01
    -- Then we will get:

    -- placeholdersInString = [ '$new_64_bit_trace_id', '$new_span_id_2' ]
    placeholdersInStringMatches = RegexBase.matchAllText templateRegex template
    placeholdersInString =
       map
         (\match-> T.pack $ fst $ match ! 0)
         placeholdersInStringMatches

    -- Now escape "$" characters so they are used as literals in the regex:
    -- escapedPlaceholdersInString = [ '\\$new_64_bit_trace_id', '\\$new_span_id_2' ]
    escapedPlaceholdersInString =
      map (\tpl -> T.replace "$" "\\$" tpl) placeholdersInString

    -- Now we want to find all _fixed_ parts of the template string, that is,
    -- the parts between the placeholders:
    -- placeholderRegex = "^(.*)\\$new_64_bit_trace_id(.*)\\$new_span_id_2(.*)$"
    placeholderRegex =
      constructRegex "^(.*)" escapedPlaceholdersInString "(.*)" "(.*)$"

    fixedLiteralsMatchStructure =
      RegexBase.matchOnceText placeholderRegex template
    in
    case fixedLiteralsMatchStructure of

      Nothing ->
        addAssertion
          (assertFailure
              ("Failure: No fixed literals match for template " ++ template ++
               " (" ++ label ++ ")."
              )
          )
          testContext

      Just (_, fixedLiteralsMatches, _) ->
        if null fixedLiteralsMatches
          then
            addAssertion
              (assertFailure
                  ("Failure: No placeholder match result " ++ template ++
                   " (" ++ label ++ ")."
                  )
              )
              testContext
          else
            let
               -- fixedLiterals = [ '00-0000000000000000', '-', '-01' ]
               fixedLiterals = extractMatches fixedLiteralsMatches

               -- valuesRegex = '^00-0000000000000000(.*)-(.*)-01$'
               valuesRegex =
                 constructRegex "^" fixedLiterals "(.*)" "$"

               -- Finally, extract the values that the current value has for the
               -- placeholders.
               valuesMatchStructure =
                 RegexBase.matchOnceText valuesRegex value
               in
               case valuesMatchStructure of

                 Nothing ->
                   addAssertion
                     (assertFailure $
                       "Failure: Could not match the value " ++ value ++
                       " against the template " ++ template ++
                       " (" ++ label ++ ")."
                     )
                     testContext

                 Just (_, valuesMatches, _) ->
                   if null valuesMatches
                     then
                       addAssertion
                         (assertFailure $
                            "Failure: Could not match the value " ++ value ++
                            " against the template " ++ template ++
                            " (" ++ label ++ ")."
                         )
                         testContext
                     else
                       let
                         -- actualValues =
                         --   ['3124d02b3e5b1531', 'e16a9d4443b7e2d1']
                         actualValues = extractMatches valuesMatches
                       in
                       updatePlaceholdersAndCreateAssertions
                         testContext
                         label
                         placeholdersInString
                         actualValues


updatePlaceholdersAndCreateAssertions ::
  TestContext
  -> String
  -> [Text]
  -> [Text]
  -> TestContext
updatePlaceholdersAndCreateAssertions
  testContext
  label
  placeholdersInString
  actualValues =
  foldr
    (\(idx, placeholder) currentTestContext ->
       let
         (_, currentValuesForPlaceholders) = currentTestContext
         existingValueM = lookup placeholder currentValuesForPlaceholders
         newValue = actualValues !! idx
       in
       case existingValueM of
         Just existingValue ->
           addAssertion
             ( assertEqual
                 ( T.unpack $ T.concat
                   [ "The placeholder "
                   , placeholder
                   , " had the value "
                   , existingValue
                   , " earlier but now it has the value "
                   , newValue
                   , ". The same placeholders needs to always have "
                   , "the same value throughout one single test case ("
                   , (T.pack label)
                   , ")."
                   ]
                 )
                 existingValue
                 newValue
             )
             currentTestContext

         Nothing ->
           addPlaceholderValue
             (placeholder, newValue)
             testContext
    )
    testContext
    (zip [0..] placeholdersInString)


parseForPlaceholderJsonValue ::
  TestContext
  -> String
  -> String
  -> Maybe AesonTypes.Value
  -> TestContext
parseForPlaceholderJsonValue testContext label template value =
  case value of
    Just aesonValue ->
      case aesonValue of
        AesonTypes.String stringValue ->
          parseForPlaceholders
            testContext
            label
            template
            (T.unpack stringValue)
        _ ->
          addAssertion
            (assertFailure $
                "Failure: Expecte a string value but instead got " ++
                show aesonValue ++ " when matching against the template " ++
                template ++ " (" ++ label ++ ")."
            )
            testContext
    Nothing ->
      addAssertion
        (assertFailure $
            "Failure: A value was expected to be present in the HTTP " ++
            "response but was not when matching against the template " ++
            template ++ " (" ++ label ++ ")."

        )
        testContext


constructRegex :: Text -> [Text] -> Text -> Text -> Regex
constructRegex start strings separator end =
  RegexBase.makeRegex
    (T.unpack $ T.concat
      [ start
      , T.intercalate separator strings
      , end
      ])


extractMatches :: RegexBase.MatchText String -> [Text]
extractMatches matchArray =
  map
    (\submatch -> T.pack $ fst submatch)
    (tail $ Array.elems matchArray)


assertEqualInMap ::
  String ->
  String ->
  Text ->
  HashMap Text Aeson.Value ->
  Assertion
assertEqualInMap label expected key jsonMap =
  assertEqual label
      (Just $ Aeson.String $ T.pack $ expected)
      (HashMap.lookup key jsonMap)


assertNotInMap ::
  String ->
  Text ->
  HashMap Text Aeson.Value ->
  Assertion
assertNotInMap label key jsonMap =
  assertEqual label Nothing (HashMap.lookup key jsonMap)