{-# LANGUAGE OverloadedStrings #-}
{-|
Module      : Instana.SDK.SDK
Description : The main API of the Instana Haskell Trace SDK.

Instana.SDK.SDK is the main API of the Instana Haskell Trace SDK. Use one of
'initInstana', 'initConfiguredInstana', 'withInstana', or
'withConfiguredInstana' to get an InstanaContext. Then use the context with any
of the 'withRootEntry', 'withEntry', 'withExit' functions for tracing.
-}
module Instana.SDK.SDK
    ( Config
    , InstanaContext
    , addAnnotation
    , addAnnotationAt
    , addAnnotationValueAt
    , addHttpTracingHeaders
    , addToErrorCount
    , addWebsiteMonitoringBackEndCorrelation
    , agentHost
    , agentPort
    , captureHttpStatus
    , completeEntry
    , completeExit
    , currentParentId
    , currentSpan
    , currentSpanId
    , currentTraceId
    , currentTraceIdInternal
    , defaultConfig
    , forceTransmissionAfter
    , forceTransmissionStartingAt
    , incrementErrorCount
    , initConfiguredInstana
    , initInstana
    , isConnected
    , maxBufferedSpans
    , postProcessHttpResponse
    , readHttpTracingHeaders
    , serviceName
    , setCorrelationId
    , setCorrelationType
    , setServiceName
    , setSynthetic
    , startEntry
    , startExit
    , startHttpEntry
    , startHttpExit
    , startRootEntry
    , withConfiguredInstana
    , withEntry
    , withExit
    , withHttpEntry
    , withHttpEntry_
    , withHttpExit
    , withInstana
    , withRootEntry
    ) where


import           Control.Concurrent                   (ThreadId)
import qualified Control.Concurrent                   as Concurrent
import           Control.Concurrent.STM               (STM)
import qualified Control.Concurrent.STM               as STM
import           Control.Monad                        (join, when)
import           Control.Monad.IO.Class               (MonadIO, liftIO)
import           Data.Aeson                           (ToJSON)
import qualified Data.ByteString.Char8                as BSC8
import           Data.CaseInsensitive                 (CI)
import qualified Data.CaseInsensitive                 as CI
import qualified Data.List                            as List
import qualified Data.Map.Strict                      as Map
import qualified Data.Maybe                           as Maybe
import qualified Data.Sequence                        as Seq
import           Data.Text                            (Text)
import qualified Data.Text                            as T
import           Data.Time.Clock.POSIX                (getPOSIXTime)
import qualified Network.HTTP.Client                  as HTTP
import qualified Network.HTTP.Types                   as HTTPTypes
import qualified Network.Socket                       as Socket
import qualified Network.Wai                          as Wai
import           System.Log.Logger                    (warningM)
import qualified System.Posix.Process                 as Process

import           Instana.SDK.Config
import           Instana.SDK.Internal.Command         (Command)
import qualified Instana.SDK.Internal.Command         as Command
import           Instana.SDK.Internal.Config          (FinalConfig)
import qualified Instana.SDK.Internal.Config          as InternalConfig
import           Instana.SDK.Internal.Context         (ConnectionState (..),
                                                       InternalContext (InternalContext))
import qualified Instana.SDK.Internal.Context         as InternalContext
import           Instana.SDK.Internal.Id              (Id)
import qualified Instana.SDK.Internal.Id              as Id
import           Instana.SDK.Internal.Logging         (instanaLogger)
import qualified Instana.SDK.Internal.Logging         as Logging
import qualified Instana.SDK.Internal.Metrics.Sample  as Sample
import qualified Instana.SDK.Internal.Secrets         as Secrets
import qualified Instana.SDK.Internal.ServerTiming    as ServerTiming
import           Instana.SDK.Internal.SpanStack       (SpanStack)
import qualified Instana.SDK.Internal.SpanStack       as SpanStack
import           Instana.SDK.Internal.Util            ((|>))
import           Instana.SDK.Internal.W3CTraceContext (W3CTraceContext)
import qualified Instana.SDK.Internal.W3CTraceContext as W3CTraceContext
import qualified Instana.SDK.Internal.Worker          as Worker
import           Instana.SDK.Span.EntrySpan           (EntrySpan (..))
import qualified Instana.SDK.Span.EntrySpan           as EntrySpan
import           Instana.SDK.Span.ExitSpan            (ExitSpan (ExitSpan))
import qualified Instana.SDK.Span.ExitSpan            as ExitSpan
import           Instana.SDK.Span.NonRootEntry        (NonRootEntry (NonRootEntry))
import qualified Instana.SDK.Span.NonRootEntry        as NonRootEntry
import           Instana.SDK.Span.RootEntry           (RootEntry (RootEntry))
import qualified Instana.SDK.Span.RootEntry           as RootEntry
import           Instana.SDK.Span.SimpleSpan          (SimpleSpan)
import qualified Instana.SDK.Span.SimpleSpan          as SimpleSpan
import           Instana.SDK.Span.Span                (Span (..), SpanKind (..))
import qualified Instana.SDK.Span.Span                as Span
import           Instana.SDK.Span.SpanData            (Annotation (..),
                                                       AnnotationValue)
import qualified Instana.SDK.Span.SpanData            as SpanData
import           Instana.SDK.Span.SpanType            (SpanType (RegisteredSpan))
import qualified Instana.SDK.Span.SpanType            as SpanType
import           Instana.SDK.TracingHeaders           (TracingHeaders,
                                                       readHttpTracingHeaders)
import qualified Instana.SDK.TracingHeaders           as TracingHeaders


{-| A container for all the things the Instana SDK needs to do its work.
-}
type InstanaContext = InternalContext


httpServerSpan :: SpanType
httpServerSpan :: SpanType
httpServerSpan = RegisteredSpanType -> SpanType
RegisteredSpan RegisteredSpanType
SpanType.HaskellWaiServer


{-| Initializes the Instana SDK and the connection to the Instana agent.

The configuration is read from the environment, falling back to default values.
-}
initInstana :: MonadIO m => m InstanaContext
initInstana :: m InstanaContext
initInstana = do
  FinalConfig
conf <- IO FinalConfig -> m FinalConfig
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FinalConfig -> m FinalConfig)
-> IO FinalConfig -> m FinalConfig
forall a b. (a -> b) -> a -> b
$ IO FinalConfig
InternalConfig.readConfigFromEnvironmentAndApplyDefaults
  IO InstanaContext -> m InstanaContext
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO InstanaContext -> m InstanaContext)
-> IO InstanaContext -> m InstanaContext
forall a b. (a -> b) -> a -> b
$ FinalConfig -> IO InstanaContext
initInstanaInternal FinalConfig
conf


{-| Initializes the Instana SDK and the connection to the Instana agent, then
calls the given function with the established connection.

The configuration is read from the environment, falling back to default values.
-}
withInstana :: MonadIO m => (InstanaContext -> m a) -> m a
withInstana :: (InstanaContext -> m a) -> m a
withInstana fn :: InstanaContext -> m a
fn = do
  FinalConfig
conf <- IO FinalConfig -> m FinalConfig
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO FinalConfig
InternalConfig.readConfigFromEnvironmentAndApplyDefaults
  FinalConfig -> (InstanaContext -> m a) -> m a
forall (m :: * -> *) a.
MonadIO m =>
FinalConfig -> (InstanaContext -> m a) -> m a
withInstanaInternal FinalConfig
conf InstanaContext -> m a
fn


{-| Initializes the Instana SDK and the connection to the Instana agent, using
the given Instana configuration.

Configuration settings that have not been set in the given configuration are
read from the environment, falling back to default values.
-}
initConfiguredInstana :: MonadIO m => Config -> m InstanaContext
initConfiguredInstana :: Config -> m InstanaContext
initConfiguredInstana conf :: Config
conf  = do
  Config
confFromEnv <- IO Config -> m Config
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Config -> m Config) -> IO Config -> m Config
forall a b. (a -> b) -> a -> b
$ IO Config
InternalConfig.readConfigFromEnvironment
  let
     mergedConf :: FinalConfig
mergedConf = Config -> Config -> FinalConfig
InternalConfig.mergeConfigs Config
conf Config
confFromEnv
  IO InstanaContext -> m InstanaContext
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO InstanaContext -> m InstanaContext)
-> IO InstanaContext -> m InstanaContext
forall a b. (a -> b) -> a -> b
$ FinalConfig -> IO InstanaContext
initInstanaInternal FinalConfig
mergedConf


{-| Initializes the Instana SDK and the connection to the Instana agent, then
calls the given function with the established connection, using the given
Instana configuration.

Configuration settings that have not been set in the given configuration are
read from the environment, falling back to default values.
-}
withConfiguredInstana :: MonadIO m => Config -> (InstanaContext -> m a) -> m a
withConfiguredInstana :: Config -> (InstanaContext -> m a) -> m a
withConfiguredInstana conf :: Config
conf fn :: InstanaContext -> m a
fn = do
  Config
confFromEnv <- IO Config -> m Config
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Config -> m Config) -> IO Config -> m Config
forall a b. (a -> b) -> a -> b
$ IO Config
InternalConfig.readConfigFromEnvironment
  let
     mergedConf :: FinalConfig
mergedConf = Config -> Config -> FinalConfig
InternalConfig.mergeConfigs Config
conf Config
confFromEnv
  FinalConfig -> (InstanaContext -> m a) -> m a
forall (m :: * -> *) a.
MonadIO m =>
FinalConfig -> (InstanaContext -> m a) -> m a
withInstanaInternal FinalConfig
mergedConf InstanaContext -> m a
fn


withInstanaInternal ::
  MonadIO m =>
  FinalConfig
  -> (InstanaContext -> m a)
  -> m a
withInstanaInternal :: FinalConfig -> (InstanaContext -> m a) -> m a
withInstanaInternal conf :: FinalConfig
conf fn :: InstanaContext -> m a
fn = do
  InstanaContext
context <- IO InstanaContext -> m InstanaContext
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO InstanaContext -> m InstanaContext)
-> IO InstanaContext -> m InstanaContext
forall a b. (a -> b) -> a -> b
$ FinalConfig -> IO InstanaContext
initInstanaInternal FinalConfig
conf
  InstanaContext -> m a
fn InstanaContext
context


initInstanaInternal :: FinalConfig -> IO InstanaContext
initInstanaInternal :: FinalConfig -> IO InstanaContext
initInstanaInternal conf :: FinalConfig
conf = do
  Int
now <- POSIXTime -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round (POSIXTime -> Int) -> (POSIXTime -> POSIXTime) -> POSIXTime -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (POSIXTime -> POSIXTime -> POSIXTime
forall a. Num a => a -> a -> a
* 1000) (POSIXTime -> Int) -> IO POSIXTime -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO POSIXTime
getPOSIXTime
  ProcessID
pid <- IO ProcessID
Process.getProcessID
  String -> IO ()
Logging.initLogger (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ ProcessID -> String
forall a. Show a => a -> String
show ProcessID
pid
  TQueue Command
commandQueue <- IO (TQueue Command)
forall a. IO (TQueue a)
STM.newTQueueIO
  TVar (Seq QueuedSpan)
spanQueue <- Seq QueuedSpan -> IO (TVar (Seq QueuedSpan))
forall a. a -> IO (TVar a)
STM.newTVarIO (Seq QueuedSpan -> IO (TVar (Seq QueuedSpan)))
-> Seq QueuedSpan -> IO (TVar (Seq QueuedSpan))
forall a b. (a -> b) -> a -> b
$ Seq QueuedSpan
forall a. Seq a
Seq.empty
  TVar ConnectionState
connectionState <- ConnectionState -> IO (TVar ConnectionState)
forall a. a -> IO (TVar a)
STM.newTVarIO (ConnectionState -> IO (TVar ConnectionState))
-> ConnectionState -> IO (TVar ConnectionState)
forall a b. (a -> b) -> a -> b
$ ConnectionState
Unconnected
  TVar (Maybe CInt)
fileDescriptor <- Maybe CInt -> IO (TVar (Maybe CInt))
forall a. a -> IO (TVar a)
STM.newTVarIO (Maybe CInt -> IO (TVar (Maybe CInt)))
-> Maybe CInt -> IO (TVar (Maybe CInt))
forall a b. (a -> b) -> a -> b
$ Maybe CInt
forall a. Maybe a
Nothing
  ThreadId
threadId <- IO ThreadId
Concurrent.myThreadId
  TVar (Map ThreadId SpanStack)
currentSpans <- Map ThreadId SpanStack -> IO (TVar (Map ThreadId SpanStack))
forall a. a -> IO (TVar a)
STM.newTVarIO (Map ThreadId SpanStack -> IO (TVar (Map ThreadId SpanStack)))
-> Map ThreadId SpanStack -> IO (TVar (Map ThreadId SpanStack))
forall a b. (a -> b) -> a -> b
$ ThreadId -> SpanStack -> Map ThreadId SpanStack
forall k a. k -> a -> Map k a
Map.singleton ThreadId
threadId SpanStack
SpanStack.empty
  TVar TimedSample
previousMetricsSample <- TimedSample -> IO (TVar TimedSample)
forall a. a -> IO (TVar a)
STM.newTVarIO (TimedSample -> IO (TVar TimedSample))
-> TimedSample -> IO (TVar TimedSample)
forall a b. (a -> b) -> a -> b
$ Int -> TimedSample
Sample.empty Int
now
  -- HTTP.newManager is keep-alive by default (10 connections, we set it to 5)
  Manager
manager <- ManagerSettings -> IO Manager
HTTP.newManager (ManagerSettings -> IO Manager) -> ManagerSettings -> IO Manager
forall a b. (a -> b) -> a -> b
$
    ManagerSettings
HTTP.defaultManagerSettings
      { managerConnCount :: Int
HTTP.managerConnCount = 5
      , managerResponseTimeout :: ResponseTimeout
HTTP.managerResponseTimeout = Int -> ResponseTimeout
HTTP.responseTimeoutMicro (Int -> ResponseTimeout) -> Int -> ResponseTimeout
forall a b. (a -> b) -> a -> b
$ 5000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* 1000
      , managerRawConnection :: IO (Maybe HostAddress -> String -> Int -> IO Connection)
HTTP.managerRawConnection =
          (Socket -> IO ())
-> IO (Maybe HostAddress -> String -> Int -> IO Connection)
HTTP.rawConnectionModifySocket
            (\socket :: Socket
socket -> do
                CInt
fileDescriptorFromSocket <- Socket -> IO CInt
Socket.fdSocket Socket
socket
                STM () -> IO ()
forall a. STM a -> IO a
STM.atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$
                  TVar (Maybe CInt) -> Maybe CInt -> STM ()
forall a. TVar a -> a -> STM ()
STM.writeTVar TVar (Maybe CInt)
fileDescriptor (CInt -> Maybe CInt
forall a. a -> Maybe a
Just CInt
fileDescriptorFromSocket)
            )
      }
  let
    context :: InstanaContext
context =
      InternalContext :: FinalConfig
-> Int
-> Manager
-> TQueue Command
-> TVar (Seq QueuedSpan)
-> TVar ConnectionState
-> TVar (Maybe CInt)
-> TVar (Map ThreadId SpanStack)
-> TVar TimedSample
-> InstanaContext
InternalContext
        { config :: FinalConfig
InternalContext.config = FinalConfig
conf
         -- sdkStartTime will be used to approximate the process start time on
         -- non-Linux platforms where System.SysInfo is not available. The
         -- assumption is that the SDK is initialized right at the start of the
         -- process.
        , sdkStartTime :: Int
InternalContext.sdkStartTime = Int
now
        , httpManager :: Manager
InternalContext.httpManager = Manager
manager
        , commandQueue :: TQueue Command
InternalContext.commandQueue = TQueue Command
commandQueue
        , spanQueue :: TVar (Seq QueuedSpan)
InternalContext.spanQueue = TVar (Seq QueuedSpan)
spanQueue
        , connectionState :: TVar ConnectionState
InternalContext.connectionState = TVar ConnectionState
connectionState
        , fileDescriptor :: TVar (Maybe CInt)
InternalContext.fileDescriptor = TVar (Maybe CInt)
fileDescriptor
        , currentSpans :: TVar (Map ThreadId SpanStack)
InternalContext.currentSpans = TVar (Map ThreadId SpanStack)
currentSpans
        , previousMetricsSample :: TVar TimedSample
InternalContext.previousMetricsSample = TVar TimedSample
previousMetricsSample
        }
  -- The worker thread will also try to establish the connection to the agent
  -- and only start its work when that was successful.
  InstanaContext -> IO ()
Worker.spawnWorker InstanaContext
context
  InstanaContext -> IO InstanaContext
forall (m :: * -> *) a. Monad m => a -> m a
return InstanaContext
context


-- |Wraps an IO action in 'startRootEntry' and 'completeEntry'. For incoming
-- HTTP requests, prefer 'withHttpEntry' instead.
withRootEntry ::
  MonadIO m =>
  InstanaContext
  -> SpanType
  -> m a
  -> m a
withRootEntry :: InstanaContext -> SpanType -> m a -> m a
withRootEntry context :: InstanaContext
context spanType :: SpanType
spanType io :: m a
io = do
  InstanaContext -> SpanType -> m ()
forall (m :: * -> *).
MonadIO m =>
InstanaContext -> SpanType -> m ()
startRootEntry InstanaContext
context SpanType
spanType
  a
result <- m a
io
  InstanaContext -> m ()
forall (m :: * -> *). MonadIO m => InstanaContext -> m ()
completeEntry InstanaContext
context
  a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
result


-- |Wraps an IO action in 'startEntry' and 'completeEntry'. For incoming HTTP
-- requests, prefer 'withHttpEntry' instead.
withEntry ::
  MonadIO m =>
  InstanaContext
  -> String
  -> String
  -> SpanType
  -> m a
  -> m a
withEntry :: InstanaContext -> String -> String -> SpanType -> m a -> m a
withEntry context :: InstanaContext
context traceId :: String
traceId parentId :: String
parentId spanType :: SpanType
spanType io :: m a
io = do
  InstanaContext -> String -> String -> SpanType -> m ()
forall (m :: * -> *).
MonadIO m =>
InstanaContext -> String -> String -> SpanType -> m ()
startEntry InstanaContext
context String
traceId String
parentId SpanType
spanType
  a
result <- m a
io
  InstanaContext -> m ()
forall (m :: * -> *). MonadIO m => InstanaContext -> m ()
completeEntry InstanaContext
context
  a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
result


-- |Wraps an IO action in 'startEntry' and 'completeEntry'. This internal method
-- accepts Id values instead of String values for trace ID/parent ID, to allow
-- span.lt to be transported alongside the shortened trace ID.
withEntry' ::
  MonadIO m =>
  InstanaContext
  -> Id
  -> Id
  -> SpanType
  -> m a
  -> m a
withEntry' :: InstanaContext -> Id -> Id -> SpanType -> m a -> m a
withEntry' context :: InstanaContext
context traceId :: Id
traceId parentId :: Id
parentId spanType :: SpanType
spanType io :: m a
io = do
  InstanaContext -> Id -> Id -> SpanType -> m ()
forall (m :: * -> *).
MonadIO m =>
InstanaContext -> Id -> Id -> SpanType -> m ()
startEntry' InstanaContext
context Id
traceId Id
parentId SpanType
spanType
  a
result <- m a
io
  InstanaContext -> m ()
forall (m :: * -> *). MonadIO m => InstanaContext -> m ()
completeEntry InstanaContext
context
  a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
result


-- |A convenience function that examines the given incoming HTTP request for
-- Instana tracing headers
-- (https://docs.instana.io/core_concepts/tracing/#http-tracing-headers)
-- and wraps the given IO action either in 'startRootEntry' or  'startEntry' and
-- 'completeEntry', depending on the presence or absence of these headers. It
-- will also capture the response HTTP status (and set the span's error count
-- if it is 5xx). Finally, it will add (or append to) the HTTP response header
-- (Server-Timing) that is used for website monitoring back end correlation.
-- (The latter part is the difference to 'withHttpEntry_', plus the slightly
-- different type signature.)
--
-- This function should be preferred over 'withHttpEntry_'.
--
-- You do not need to handle incoming HTTP requests at all when using the
-- Instana WAI middleware plug-in.
withHttpEntry ::
  MonadIO m =>
  InstanaContext
  -> Wai.Request
  -> m Wai.Response
  -> m Wai.Response
withHttpEntry :: InstanaContext -> Request -> m Response -> m Response
withHttpEntry context :: InstanaContext
context request :: Request
request io :: m Response
io = do
    Response
response <- InstanaContext -> Request -> m Response -> m Response
forall (m :: * -> *) a.
MonadIO m =>
InstanaContext -> Request -> m a -> m a
withHttpEntry_ InstanaContext
context Request
request (m Response -> m Response) -> m Response -> m Response
forall a b. (a -> b) -> a -> b
$ do
      m Response
io m Response -> (Response -> m Response) -> m Response
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= InstanaContext -> Response -> m Response
forall (m :: * -> *).
MonadIO m =>
InstanaContext -> Response -> m Response
postProcessHttpResponse InstanaContext
context
    Response -> m Response
forall (m :: * -> *) a. Monad m => a -> m a
return Response
response


-- |A variant of 'withHttpEntry' with a more general type signature, but less
-- features. It will automatically continue the trace from incoming headers just
-- like withHttpEntry does, but it will not capture the status code of the HTTP
-- response or add the response header for website monitoring back end
-- correlation (Server-Timing).
--
-- It is recommended to use 'withHttpEntry' instead of this function, if
-- possible. Alternatively, you can also call 'postProcessHttpResponse' inside
-- the 'withHttpEntry_' block to cover the two missing features mentioned above.
--
-- Note that you do not need to handle incoming HTTP requests at all when using
-- the Instana WAI middleware plug-in.
withHttpEntry_ ::
  MonadIO m =>
  InstanaContext
  -> Wai.Request
  -> m a
  -> m a
withHttpEntry_ :: InstanaContext -> Request -> m a -> m a
withHttpEntry_ context :: InstanaContext
context request :: Request
request io :: m a
io =
  InstanaContext -> Request -> HttpTracingHandlers m a -> m a -> m a
forall (m :: * -> *) a.
MonadIO m =>
InstanaContext -> Request -> HttpTracingHandlers m a -> m a -> m a
commonHttpHandling
    InstanaContext
context
    Request
request
    HttpTracingHandlers :: forall (m :: * -> *) a.
(InstanaContext -> String -> String -> m a -> m a)
-> (InstanaContext -> W3CTraceContext -> m a -> m a)
-> (InstanaContext -> Id -> Id -> m a -> m a)
-> (InstanaContext -> TracingHeaders -> m a -> m a)
-> HttpTracingHandlers m a
HttpTracingHandlers
      { continueFromInstanaHeaders :: InstanaContext -> String -> String -> m a -> m a
continueFromInstanaHeaders = InstanaContext -> String -> String -> m a -> m a
forall (m :: * -> *) a.
MonadIO m =>
InstanaContext -> String -> String -> m a -> m a
withHttpEntryContinueFromInstanaHeaders
      , continueFromTraceParent :: InstanaContext -> W3CTraceContext -> m a -> m a
continueFromTraceParent = InstanaContext -> W3CTraceContext -> m a -> m a
forall (m :: * -> *) a.
MonadIO m =>
InstanaContext -> W3CTraceContext -> m a -> m a
withHttpEntryContinueFromTraceParent
      , continueFromTraceStateInstanaKeyValuePair :: InstanaContext -> Id -> Id -> m a -> m a
continueFromTraceStateInstanaKeyValuePair =
          InstanaContext -> Id -> Id -> m a -> m a
forall (m :: * -> *) a.
MonadIO m =>
InstanaContext -> Id -> Id -> m a -> m a
withHttpEntryContinueFromTraceStateInstanaKeyValuePair
      , createRoot :: InstanaContext -> TracingHeaders -> m a -> m a
createRoot = InstanaContext -> TracingHeaders -> m a -> m a
forall (m :: * -> *) a.
MonadIO m =>
InstanaContext -> TracingHeaders -> m a -> m a
withHttpEntryRoot
      }
    m a
io


-- |A variant of 'withHttpEntry' that continues a trace from Instana headers
-- (X-INSTANA-T, X-INSTANA-S and X-INSTANA-L).
withHttpEntryContinueFromInstanaHeaders ::
  MonadIO m
  => InstanaContext
  -> String
  -> String
  -> m a
  -> m a
withHttpEntryContinueFromInstanaHeaders :: InstanaContext -> String -> String -> m a -> m a
withHttpEntryContinueFromInstanaHeaders context :: InstanaContext
context t :: String
t s :: String
s io :: m a
io =
  InstanaContext -> String -> String -> SpanType -> m a -> m a
forall (m :: * -> *) a.
MonadIO m =>
InstanaContext -> String -> String -> SpanType -> m a -> m a
withEntry InstanaContext
context String
t String
s SpanType
httpServerSpan m a
io


-- |A variant of 'withHttpEntry' that continues a trace from the W3C trace
-- context headers traceparent.
withHttpEntryContinueFromTraceParent ::
  MonadIO m
  => InstanaContext
  -> W3CTraceContext
  -> m a
  -> m a
withHttpEntryContinueFromTraceParent :: InstanaContext -> W3CTraceContext -> m a -> m a
withHttpEntryContinueFromTraceParent context :: InstanaContext
context w3cTraceContext :: W3CTraceContext
w3cTraceContext io :: m a
io =
  let
    traceParent :: TraceParent
traceParent = W3CTraceContext -> TraceParent
W3CTraceContext.traceParent W3CTraceContext
w3cTraceContext
  in
  InstanaContext -> Id -> Id -> SpanType -> m a -> m a
forall (m :: * -> *) a.
MonadIO m =>
InstanaContext -> Id -> Id -> SpanType -> m a -> m a
withEntry'
    InstanaContext
context
    (TraceParent -> Id
W3CTraceContext.traceId TraceParent
traceParent)
    (TraceParent -> Id
W3CTraceContext.parentId TraceParent
traceParent)
    SpanType
httpServerSpan
    (InstanaContext -> m ()
forall (m :: * -> *). MonadIO m => InstanaContext -> m ()
setSpanTpFlag InstanaContext
context m () -> m a -> m a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m a
io)


-- |A variant of 'withHttpEntry' that continues a trace from the Instana
-- key-value pair from the tracestate header.
withHttpEntryContinueFromTraceStateInstanaKeyValuePair ::
  MonadIO m
  => InstanaContext
  -> Id
  -> Id
  -> m a
  -> m a
withHttpEntryContinueFromTraceStateInstanaKeyValuePair :: InstanaContext -> Id -> Id -> m a -> m a
withHttpEntryContinueFromTraceStateInstanaKeyValuePair context :: InstanaContext
context t :: Id
t s :: Id
s io :: m a
io =
  InstanaContext -> Id -> Id -> SpanType -> m a -> m a
forall (m :: * -> *) a.
MonadIO m =>
InstanaContext -> Id -> Id -> SpanType -> m a -> m a
withEntry' InstanaContext
context Id
t Id
s SpanType
httpServerSpan m a
io


-- |A variant of 'withHttpEntry' that does not continue a trace but starts a
-- new trace.
withHttpEntryRoot ::
  MonadIO m
  => InstanaContext
  -> TracingHeaders
  -> m a
  -> m a
withHttpEntryRoot :: InstanaContext -> TracingHeaders -> m a -> m a
withHttpEntryRoot context :: InstanaContext
context tracingHeaders :: TracingHeaders
tracingHeaders io :: m a
io =
  InstanaContext -> SpanType -> m a -> m a
forall (m :: * -> *) a.
MonadIO m =>
InstanaContext -> SpanType -> m a -> m a
withRootEntry InstanaContext
context SpanType
httpServerSpan (m a -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$
    InstanaContext -> TracingHeaders -> m ()
forall (m :: * -> *).
MonadIO m =>
InstanaContext -> TracingHeaders -> m ()
addCorrelationTypeAndIdToSpan InstanaContext
context TracingHeaders
tracingHeaders
    m () -> m a -> m a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m a
io


-- |Wraps an IO action in 'startExit' and 'completeExit'.
withExit ::
  MonadIO m =>
  InstanaContext
  -> SpanType
  -> m a
  -> m a
withExit :: InstanaContext -> SpanType -> m a -> m a
withExit context :: InstanaContext
context spanType :: SpanType
spanType io :: m a
io = do
  InstanaContext -> SpanType -> m ()
forall (m :: * -> *).
MonadIO m =>
InstanaContext -> SpanType -> m ()
startExit InstanaContext
context SpanType
spanType
  a
result <- m a
io
  InstanaContext -> m ()
forall (m :: * -> *). MonadIO m => InstanaContext -> m ()
completeExit InstanaContext
context
  a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
result


-- |Wraps an IO action in 'startHttpExit' and 'completeExit'. The given action
-- is accepted as a function (Request -> IO a) and is expected to use the
-- provided request parameter for executing the HTTP request.
withHttpExit ::
  MonadIO m =>
  InstanaContext
  -> HTTP.Request
  -> (HTTP.Request -> m a)
  -> m a
withHttpExit :: InstanaContext -> Request -> (Request -> m a) -> m a
withHttpExit context :: InstanaContext
context request :: Request
request io :: Request -> m a
io = do
  Request
request' <- InstanaContext -> Request -> m Request
forall (m :: * -> *).
MonadIO m =>
InstanaContext -> Request -> m Request
startHttpExit InstanaContext
context Request
request
  a
result <- Request -> m a
io Request
request'
  InstanaContext -> m ()
forall (m :: * -> *). MonadIO m => InstanaContext -> m ()
completeExit InstanaContext
context
  a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
result


-- |Creates a preliminary/incomplete root entry span, which should later be
-- completed with 'completeEntry'.
startRootEntry ::
  MonadIO m =>
  InstanaContext
  -> SpanType
  -> m ()
startRootEntry :: InstanaContext -> SpanType -> m ()
startRootEntry context :: InstanaContext
context spanType :: SpanType
spanType = do
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    Int
timestamp <- POSIXTime -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round (POSIXTime -> Int) -> (POSIXTime -> POSIXTime) -> POSIXTime -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (POSIXTime -> POSIXTime -> POSIXTime
forall a. Num a => a -> a -> a
* 1000) (POSIXTime -> Int) -> IO POSIXTime -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO POSIXTime
getPOSIXTime
    Id
traceId <- IO Id
Id.generate
    let
      newSpan :: EntrySpan
newSpan =
        RootEntry -> EntrySpan
RootEntrySpan (RootEntry -> EntrySpan) -> RootEntry -> EntrySpan
forall a b. (a -> b) -> a -> b
$
          RootEntry :: Id
-> SpanType
-> Int
-> Int
-> Maybe Text
-> Bool
-> Maybe Text
-> Maybe Text
-> SpanData
-> Maybe W3CTraceContext
-> RootEntry
RootEntry
            { spanAndTraceId :: Id
RootEntry.spanAndTraceId  = Id
traceId
            , spanType :: SpanType
RootEntry.spanType        = SpanType
spanType
            , timestamp :: Int
RootEntry.timestamp       = Int
timestamp
            , errorCount :: Int
RootEntry.errorCount      = 0
            , serviceName :: Maybe Text
RootEntry.serviceName     = Maybe Text
forall a. Maybe a
Nothing
            , synthetic :: Bool
RootEntry.synthetic       = Bool
False
            , correlationType :: Maybe Text
RootEntry.correlationType = Maybe Text
forall a. Maybe a
Nothing
            , correlationId :: Maybe Text
RootEntry.correlationId   = Maybe Text
forall a. Maybe a
Nothing
            , spanData :: SpanData
RootEntry.spanData        = SpanKind -> SpanType -> SpanData
Span.initialData SpanKind
EntryKind SpanType
spanType
            , w3cTraceContext :: Maybe W3CTraceContext
RootEntry.w3cTraceContext = Maybe W3CTraceContext
forall a. Maybe a
Nothing
            }
    InstanaContext -> (Maybe SpanStack -> SpanStack) -> IO ()
pushSpan
      InstanaContext
context
      (\stack :: Maybe SpanStack
stack ->
        case Maybe SpanStack
stack of
          Nothing ->
            -- We did not initialise the span stack for this thread, do it now.
            EntrySpan -> SpanStack
SpanStack.entry EntrySpan
newSpan
          Just spanStack :: SpanStack
spanStack ->
            SpanStack
spanStack
            SpanStack -> (SpanStack -> SpanStack) -> SpanStack
forall a b. a -> (a -> b) -> b
|> Span -> SpanStack -> SpanStack
SpanStack.push (EntrySpan -> Span
Entry EntrySpan
newSpan)
      )


-- |Creates a preliminary/incomplete entry span, which should later be completed
-- by calling 'completeEntry'.
startEntry ::
  MonadIO m =>
  InstanaContext
  -> String
  -> String
  -> SpanType
  -> m ()
startEntry :: InstanaContext -> String -> String -> SpanType -> m ()
startEntry context :: InstanaContext
context traceId :: String
traceId parentId :: String
parentId spanType :: SpanType
spanType = do
  let
    tId :: Id
tId = String -> Id
Id.fromString String
traceId
    pId :: Id
pId = String -> Id
Id.fromString String
parentId
  InstanaContext -> Id -> Id -> SpanType -> m ()
forall (m :: * -> *).
MonadIO m =>
InstanaContext -> Id -> Id -> SpanType -> m ()
startEntry' InstanaContext
context Id
tId Id
pId SpanType
spanType


-- |Creates a preliminary/incomplete entry span, which should later be completed
-- by calling 'completeEntry'. This internal method accepts Id values instead of
-- String values for trace ID/parent ID, to allow span.lt to be transported
-- alongside the shortened trace ID.
startEntry' ::
  MonadIO m =>
  InstanaContext
  -> Id
  -> Id
  -> SpanType
  -> m ()
startEntry' :: InstanaContext -> Id -> Id -> SpanType -> m ()
startEntry' context :: InstanaContext
context traceId :: Id
traceId parentId :: Id
parentId spanType :: SpanType
spanType = do
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    Int
timestamp <- POSIXTime -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round (POSIXTime -> Int) -> (POSIXTime -> POSIXTime) -> POSIXTime -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (POSIXTime -> POSIXTime -> POSIXTime
forall a. Num a => a -> a -> a
* 1000) (POSIXTime -> Int) -> IO POSIXTime -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO POSIXTime
getPOSIXTime
    Id
spanId <- IO Id
Id.generate
    let
      newSpan :: EntrySpan
newSpan =
        NonRootEntry -> EntrySpan
NonRootEntrySpan (NonRootEntry -> EntrySpan) -> NonRootEntry -> EntrySpan
forall a b. (a -> b) -> a -> b
$
          NonRootEntry :: Id
-> Id
-> Id
-> SpanType
-> Int
-> Int
-> Maybe Text
-> Bool
-> SpanData
-> Maybe W3CTraceContext
-> Bool
-> NonRootEntry
NonRootEntry
            { traceId :: Id
NonRootEntry.traceId         = Id
traceId
            , spanId :: Id
NonRootEntry.spanId          = Id
spanId
            , parentId :: Id
NonRootEntry.parentId        = Id
parentId
            , spanType :: SpanType
NonRootEntry.spanType        = SpanType
spanType
            , timestamp :: Int
NonRootEntry.timestamp       = Int
timestamp
            , errorCount :: Int
NonRootEntry.errorCount      = 0
            , serviceName :: Maybe Text
NonRootEntry.serviceName     = Maybe Text
forall a. Maybe a
Nothing
            , synthetic :: Bool
NonRootEntry.synthetic       = Bool
False
            , spanData :: SpanData
NonRootEntry.spanData        = SpanKind -> SpanType -> SpanData
Span.initialData SpanKind
EntryKind SpanType
spanType
            , w3cTraceContext :: Maybe W3CTraceContext
NonRootEntry.w3cTraceContext = Maybe W3CTraceContext
forall a. Maybe a
Nothing
            , tpFlag :: Bool
NonRootEntry.tpFlag          = Bool
False
            }
    InstanaContext -> (Maybe SpanStack -> SpanStack) -> IO ()
pushSpan
      InstanaContext
context
      (\stack :: Maybe SpanStack
stack ->
        case Maybe SpanStack
stack of
          Nothing ->
            -- We did not initialise the span stack for this thread yet, do
            -- it now.
            EntrySpan -> SpanStack
SpanStack.entry EntrySpan
newSpan
          Just spanStack :: SpanStack
spanStack ->
            SpanStack
spanStack
            SpanStack -> (SpanStack -> SpanStack) -> SpanStack
forall a b. a -> (a -> b) -> b
|> Span -> SpanStack -> SpanStack
SpanStack.push (EntrySpan -> Span
Entry EntrySpan
newSpan)
      )
    () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()


-- |A convenience function that examines the given request for Instana tracing
-- headers (https://docs.instana.io/core_concepts/tracing/#http-tracing-headers)
-- and either calls 'startRootEntry' or  'startEntry', depending on the presence
-- of absence of these headers.
startHttpEntry ::
  MonadIO m =>
  InstanaContext
  -> Wai.Request
  -> m ()
startHttpEntry :: InstanaContext -> Request -> m ()
startHttpEntry context :: InstanaContext
context request :: Request
request = do
  InstanaContext
-> Request -> HttpTracingHandlers m () -> m () -> m ()
forall (m :: * -> *) a.
MonadIO m =>
InstanaContext -> Request -> HttpTracingHandlers m a -> m a -> m a
commonHttpHandling
    InstanaContext
context
    Request
request
    HttpTracingHandlers :: forall (m :: * -> *) a.
(InstanaContext -> String -> String -> m a -> m a)
-> (InstanaContext -> W3CTraceContext -> m a -> m a)
-> (InstanaContext -> Id -> Id -> m a -> m a)
-> (InstanaContext -> TracingHeaders -> m a -> m a)
-> HttpTracingHandlers m a
HttpTracingHandlers
      { continueFromInstanaHeaders :: InstanaContext -> String -> String -> m () -> m ()
continueFromInstanaHeaders = InstanaContext -> String -> String -> m () -> m ()
forall (m :: * -> *) a.
MonadIO m =>
InstanaContext -> String -> String -> m a -> m a
startHttpEntryContinueFromInstanaHeaders
      , continueFromTraceParent :: InstanaContext -> W3CTraceContext -> m () -> m ()
continueFromTraceParent = InstanaContext -> W3CTraceContext -> m () -> m ()
forall (m :: * -> *) a.
MonadIO m =>
InstanaContext -> W3CTraceContext -> m a -> m a
startHttpEntryContinueFromTraceParent
      , continueFromTraceStateInstanaKeyValuePair :: InstanaContext -> Id -> Id -> m () -> m ()
continueFromTraceStateInstanaKeyValuePair =
          InstanaContext -> Id -> Id -> m () -> m ()
forall (m :: * -> *) a.
MonadIO m =>
InstanaContext -> Id -> Id -> m a -> m a
startHttpEntryContinueFromTraceStateInstanaKeyValuePair
      , createRoot :: InstanaContext -> TracingHeaders -> m () -> m ()
createRoot = InstanaContext -> TracingHeaders -> m () -> m ()
forall (m :: * -> *) a.
MonadIO m =>
InstanaContext -> TracingHeaders -> m a -> m a
startHttpEntryRoot
      }
    (() -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())


-- |A variant of 'startHttpEntry' that continues a trace from Instana headers
-- (X-INSTANA-T, X-INSTANA-S and X-INSTANA-L).
startHttpEntryContinueFromInstanaHeaders ::
  MonadIO m
  => InstanaContext
  -> String
  -> String
  -> m a
  -> m a
startHttpEntryContinueFromInstanaHeaders :: InstanaContext -> String -> String -> m a -> m a
startHttpEntryContinueFromInstanaHeaders context :: InstanaContext
context t :: String
t s :: String
s io :: m a
io = do
  InstanaContext -> String -> String -> SpanType -> m ()
forall (m :: * -> *).
MonadIO m =>
InstanaContext -> String -> String -> SpanType -> m ()
startEntry InstanaContext
context String
t String
s SpanType
httpServerSpan
  m a
io


-- |A variant of 'startHttpEntry' that continues a trace from the W3C trace
-- context headers traceparent.
startHttpEntryContinueFromTraceParent ::
  MonadIO m
  => InstanaContext
  -> W3CTraceContext
  -> m a
  -> m a
startHttpEntryContinueFromTraceParent :: InstanaContext -> W3CTraceContext -> m a -> m a
startHttpEntryContinueFromTraceParent context :: InstanaContext
context w3cTraceContext :: W3CTraceContext
w3cTraceContext io :: m a
io = do
  let
    traceParent :: TraceParent
traceParent = W3CTraceContext -> TraceParent
W3CTraceContext.traceParent W3CTraceContext
w3cTraceContext
  InstanaContext -> Id -> Id -> SpanType -> m ()
forall (m :: * -> *).
MonadIO m =>
InstanaContext -> Id -> Id -> SpanType -> m ()
startEntry'
    InstanaContext
context
    (TraceParent -> Id
W3CTraceContext.traceId TraceParent
traceParent)
    (TraceParent -> Id
W3CTraceContext.parentId TraceParent
traceParent)
    SpanType
httpServerSpan
  (InstanaContext -> m ()
forall (m :: * -> *). MonadIO m => InstanaContext -> m ()
setSpanTpFlag InstanaContext
context m () -> m a -> m a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m a
io)


-- |A variant of 'startHttpEntry' that continues a trace from the Instana
-- key-value pair from the tracestate header.
startHttpEntryContinueFromTraceStateInstanaKeyValuePair ::
  MonadIO m
  => InstanaContext
  -> Id
  -> Id
  -> m a
  -> m a
startHttpEntryContinueFromTraceStateInstanaKeyValuePair :: InstanaContext -> Id -> Id -> m a -> m a
startHttpEntryContinueFromTraceStateInstanaKeyValuePair
    context :: InstanaContext
context
    t :: Id
t
    s :: Id
s
    io :: m a
io = do
  InstanaContext -> Id -> Id -> SpanType -> m ()
forall (m :: * -> *).
MonadIO m =>
InstanaContext -> Id -> Id -> SpanType -> m ()
startEntry'
    InstanaContext
context
    Id
t
    Id
s
    SpanType
httpServerSpan
  m a
io


-- |A variant of 'startHttpEntry' that does not continue a trace but starts a
-- new trace.
startHttpEntryRoot ::
  MonadIO m
  => InstanaContext
  -> TracingHeaders
  -> m a
  -> m a
startHttpEntryRoot :: InstanaContext -> TracingHeaders -> m a -> m a
startHttpEntryRoot context :: InstanaContext
context tracingHeaders :: TracingHeaders
tracingHeaders io :: m a
io = do
  InstanaContext -> SpanType -> m ()
forall (m :: * -> *).
MonadIO m =>
InstanaContext -> SpanType -> m ()
startRootEntry InstanaContext
context SpanType
httpServerSpan
  InstanaContext -> TracingHeaders -> m ()
forall (m :: * -> *).
MonadIO m =>
InstanaContext -> TracingHeaders -> m ()
addCorrelationTypeAndIdToSpan InstanaContext
context TracingHeaders
tracingHeaders
  m a
io


-- |A set of handlers to continue a trace from incoming headers or create a
-- new trace, which can be either used from withHttpEntry or startHttpEntry.
data HttpTracingHandlers m a = HttpTracingHandlers
  { HttpTracingHandlers m a
-> InstanaContext -> String -> String -> m a -> m a
continueFromInstanaHeaders ::
      InstanaContext
      -> String
      -> String
      -> m a
      -> m a
  , HttpTracingHandlers m a
-> InstanaContext -> W3CTraceContext -> m a -> m a
continueFromTraceParent ::
      InstanaContext
      -> W3CTraceContext
      -> m a
      -> m a
  , HttpTracingHandlers m a -> InstanaContext -> Id -> Id -> m a -> m a
continueFromTraceStateInstanaKeyValuePair ::
      InstanaContext
      -> Id
      -> Id
      -> m a
      -> m a
  , HttpTracingHandlers m a
-> InstanaContext -> TracingHeaders -> m a -> m a
createRoot ::
      InstanaContext
      -> TracingHeaders
      -> m a
      -> m a
  }


-- |Bundles common handling for startHttpEntry and withHttpEntry.
commonHttpHandling ::
  MonadIO m =>
  InstanaContext
  -> Wai.Request
  -> HttpTracingHandlers m a
  -> m a
  -> m a
commonHttpHandling :: InstanaContext -> Request -> HttpTracingHandlers m a -> m a -> m a
commonHttpHandling context :: InstanaContext
context request :: Request
request httpTracingHandlers :: HttpTracingHandlers m a
httpTracingHandlers io :: m a
io = do
  let
    tracingHeaders :: TracingHeaders
tracingHeaders = Request -> TracingHeaders
readHttpTracingHeaders Request
request
    traceId :: Maybe String
traceId = TracingHeaders -> Maybe String
TracingHeaders.traceId TracingHeaders
tracingHeaders
    spanId :: Maybe String
spanId = TracingHeaders -> Maybe String
TracingHeaders.spanId TracingHeaders
tracingHeaders
    level :: TracingLevel
level = TracingHeaders -> TracingLevel
TracingHeaders.level TracingHeaders
tracingHeaders
    traceparent :: Maybe String
traceparent = TracingHeaders -> Maybe String
TracingHeaders.traceparent TracingHeaders
tracingHeaders
    tracestate :: Maybe String
tracestate = TracingHeaders -> Maybe String
TracingHeaders.tracestate TracingHeaders
tracingHeaders

    -- discard incoming X-INSTANA-T/-S if eum correlation data is present
    (traceId' :: Maybe String
traceId', spanId' :: Maybe String
spanId') =
      case TracingHeaders -> Maybe String
TracingHeaders.correlationId TracingHeaders
tracingHeaders of
        Nothing ->
          (Maybe String
traceId, Maybe String
spanId)
        Just _ ->
          (Maybe String
forall a. Maybe a
Nothing, Maybe String
forall a. Maybe a
Nothing)

    w3cTraceContext :: Maybe W3CTraceContext
w3cTraceContext =
      case Maybe String
traceparent of
        Just tp :: String
tp ->
          String -> Maybe String -> Maybe W3CTraceContext
W3CTraceContext.decode String
tp Maybe String
tracestate
        Nothing ->
          Maybe W3CTraceContext
forall a. Maybe a
Nothing

  case TracingLevel
level of

    TracingHeaders.Trace ->
      InstanaContext
-> Request
-> HttpTracingHandlers m a
-> TracingHeaders
-> Maybe W3CTraceContext
-> Maybe String
-> Maybe String
-> m a
-> m a
forall (m :: * -> *) a.
MonadIO m =>
InstanaContext
-> Request
-> HttpTracingHandlers m a
-> TracingHeaders
-> Maybe W3CTraceContext
-> Maybe String
-> Maybe String
-> m a
-> m a
executeTracedHttpRequest
        InstanaContext
context
        Request
request
        HttpTracingHandlers m a
httpTracingHandlers
        TracingHeaders
tracingHeaders
        Maybe W3CTraceContext
w3cTraceContext
        Maybe String
traceId'
        Maybe String
spanId'
        m a
io

    TracingHeaders.Suppress ->
      InstanaContext -> Maybe W3CTraceContext -> m a -> m a
forall (m :: * -> *) a.
MonadIO m =>
InstanaContext -> Maybe W3CTraceContext -> m a -> m a
executeSuppressedHttpRequest InstanaContext
context Maybe W3CTraceContext
w3cTraceContext m a
io


-- |Evaluates the incoming headers (Instana headers and W3C trace context) and
-- decides from which set of headers to continue the trace (or to start a new
-- trace).
executeTracedHttpRequest ::
  MonadIO m =>
  InstanaContext
  -> Wai.Request
  -> HttpTracingHandlers m a
  -> TracingHeaders
  -> Maybe W3CTraceContext
  -> Maybe String
  -> Maybe String
  -> m a
  -> m a
executeTracedHttpRequest :: InstanaContext
-> Request
-> HttpTracingHandlers m a
-> TracingHeaders
-> Maybe W3CTraceContext
-> Maybe String
-> Maybe String
-> m a
-> m a
executeTracedHttpRequest
    context :: InstanaContext
context
    request :: Request
request
    httpTracingHandlers :: HttpTracingHandlers m a
httpTracingHandlers
    tracingHeaders :: TracingHeaders
tracingHeaders
    w3cTraceContext :: Maybe W3CTraceContext
w3cTraceContext
    traceId :: Maybe String
traceId
    spanId :: Maybe String
spanId
    io :: m a
io = do
  let
    synthetic :: Bool
synthetic = TracingHeaders -> Bool
TracingHeaders.synthetic TracingHeaders
tracingHeaders

    io' :: m a
io' =
      (InstanaContext -> Maybe W3CTraceContext -> m ()
forall (m :: * -> *).
MonadIO m =>
InstanaContext -> Maybe W3CTraceContext -> m ()
setW3cTraceContext InstanaContext
context Maybe W3CTraceContext
w3cTraceContext)
      m () -> m a -> m a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m a
io
      m a -> (a -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\ioResult :: a
ioResult -> do
        InstanaContext -> Request -> Bool -> m ()
forall (m :: * -> *).
MonadIO m =>
InstanaContext -> Request -> Bool -> m ()
addHttpData InstanaContext
context Request
request Bool
synthetic
        a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
ioResult
      )

    w3cTsInKvPair :: Maybe InstanaKeyValuePair
w3cTsInKvPair =
      Maybe (Maybe InstanaKeyValuePair) -> Maybe InstanaKeyValuePair
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe InstanaKeyValuePair) -> Maybe InstanaKeyValuePair)
-> Maybe (Maybe InstanaKeyValuePair) -> Maybe InstanaKeyValuePair
forall a b. (a -> b) -> a -> b
$
        TraceState -> Maybe InstanaKeyValuePair
W3CTraceContext.instanaKeyValuePair (TraceState -> Maybe InstanaKeyValuePair)
-> (W3CTraceContext -> TraceState)
-> W3CTraceContext
-> Maybe InstanaKeyValuePair
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
          W3CTraceContext -> TraceState
W3CTraceContext.traceState (W3CTraceContext -> Maybe InstanaKeyValuePair)
-> Maybe W3CTraceContext -> Maybe (Maybe InstanaKeyValuePair)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe W3CTraceContext
w3cTraceContext
    tIdFromW3cInKvPair :: Maybe Id
tIdFromW3cInKvPair = InstanaKeyValuePair -> Id
W3CTraceContext.instanaTraceId (InstanaKeyValuePair -> Id)
-> Maybe InstanaKeyValuePair -> Maybe Id
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe InstanaKeyValuePair
w3cTsInKvPair
    pIdFromW3cInKvPair :: Maybe Id
pIdFromW3cInKvPair = InstanaKeyValuePair -> Id
W3CTraceContext.instanaParentId (InstanaKeyValuePair -> Id)
-> Maybe InstanaKeyValuePair -> Maybe Id
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe InstanaKeyValuePair
w3cTsInKvPair

    w3cTraceCorrelationDisabled :: Bool
w3cTraceCorrelationDisabled =
      FinalConfig -> Bool
InternalConfig.disableW3cTraceCorrelation (FinalConfig -> Bool)
-> (InstanaContext -> FinalConfig) -> InstanaContext -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InstanaContext -> FinalConfig
InternalContext.config (InstanaContext -> Bool) -> InstanaContext -> Bool
forall a b. (a -> b) -> a -> b
$
        InstanaContext
context

  case ( Maybe String
traceId
       , Maybe String
spanId
       , Maybe W3CTraceContext
w3cTraceContext
       , Bool
w3cTraceCorrelationDisabled
       , Maybe Id
tIdFromW3cInKvPair
       , Maybe Id
pIdFromW3cInKvPair
       ) of

    (Just t :: String
t, Just s :: String
s, _, _, _, _) ->
      (HttpTracingHandlers m a
-> InstanaContext -> String -> String -> m a -> m a
forall (m :: * -> *) a.
HttpTracingHandlers m a
-> InstanaContext -> String -> String -> m a -> m a
continueFromInstanaHeaders HttpTracingHandlers m a
httpTracingHandlers)
        InstanaContext
context
        String
t
        String
s
        m a
io'

    (_, _, Just w3cCtx :: W3CTraceContext
w3cCtx, False, _, _) ->
      (HttpTracingHandlers m a
-> InstanaContext -> W3CTraceContext -> m a -> m a
forall (m :: * -> *) a.
HttpTracingHandlers m a
-> InstanaContext -> W3CTraceContext -> m a -> m a
continueFromTraceParent HttpTracingHandlers m a
httpTracingHandlers)
        InstanaContext
context
        W3CTraceContext
w3cCtx
        m a
io'

    (_, _, _, True, Just t :: Id
t, Just s :: Id
s) ->
      (HttpTracingHandlers m a -> InstanaContext -> Id -> Id -> m a -> m a
forall (m :: * -> *) a.
HttpTracingHandlers m a -> InstanaContext -> Id -> Id -> m a -> m a
continueFromTraceStateInstanaKeyValuePair HttpTracingHandlers m a
httpTracingHandlers)
        InstanaContext
context
        Id
t
        Id
s
        m a
io'

    _                ->
      (HttpTracingHandlers m a
-> InstanaContext -> TracingHeaders -> m a -> m a
forall (m :: * -> *) a.
HttpTracingHandlers m a
-> InstanaContext -> TracingHeaders -> m a -> m a
createRoot HttpTracingHandlers m a
httpTracingHandlers)
        InstanaContext
context
        TracingHeaders
tracingHeaders
        m a
io'


-- |Handles an incoming HTTP request when tracing is suppressed.
executeSuppressedHttpRequest ::
  MonadIO m =>
  InstanaContext
  -> Maybe W3CTraceContext
  -> m a
  -> m a
executeSuppressedHttpRequest :: InstanaContext -> Maybe W3CTraceContext -> m a -> m a
executeSuppressedHttpRequest context :: InstanaContext
context maybeW3cTraceContext :: Maybe W3CTraceContext
maybeW3cTraceContext io :: m a
io = do
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    W3CTraceContext
w3cTraceContext <-
      case Maybe W3CTraceContext
maybeW3cTraceContext of
        Just w3cCtx :: W3CTraceContext
w3cCtx ->
          W3CTraceContext -> IO W3CTraceContext
forall (m :: * -> *) a. Monad m => a -> m a
return W3CTraceContext
w3cCtx
        Nothing -> do
          IO W3CTraceContext
W3CTraceContext.initBogusContextForSuppressedRequest
    InstanaContext -> (Maybe SpanStack -> SpanStack) -> IO ()
pushSpan
      InstanaContext
context
      (\stack :: Maybe SpanStack
stack ->
        case Maybe SpanStack
stack of
          Nothing ->
            -- We did not initialise the span stack for this thread, do it
            -- now.
            W3CTraceContext -> SpanStack
SpanStack.suppress W3CTraceContext
w3cTraceContext
          Just spanStack :: SpanStack
spanStack ->
            W3CTraceContext -> SpanStack -> SpanStack
SpanStack.pushSuppress W3CTraceContext
w3cTraceContext SpanStack
spanStack
      )
  m a
io


addHttpData ::
  MonadIO m =>
  InstanaContext ->
  Wai.Request ->
  Bool ->
  m ()
addHttpData :: InstanaContext -> Request -> Bool -> m ()
addHttpData context :: InstanaContext
context request :: Request
request synthetic :: Bool
synthetic = do
  [CI ByteString]
extraHeadersConfig <- IO [CI ByteString] -> m [CI ByteString]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [CI ByteString] -> m [CI ByteString])
-> IO [CI ByteString] -> m [CI ByteString]
forall a b. (a -> b) -> a -> b
$ InstanaContext -> IO [CI ByteString]
InternalContext.readExtraHeaders InstanaContext
context
  SecretsMatcher
secretsMatcher <- IO SecretsMatcher -> m SecretsMatcher
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO SecretsMatcher -> m SecretsMatcher)
-> IO SecretsMatcher -> m SecretsMatcher
forall a b. (a -> b) -> a -> b
$ InstanaContext -> IO SecretsMatcher
InternalContext.readSecretsMatcher InstanaContext
context
  let
    host :: String
    host :: String
host =
      Request -> Maybe ByteString
Wai.requestHeaderHost Request
request
      Maybe ByteString
-> (Maybe ByteString -> Maybe String) -> Maybe String
forall a b. a -> (a -> b) -> b
|> (ByteString -> String) -> Maybe ByteString -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> String
BSC8.unpack
      Maybe String -> (Maybe String -> String) -> String
forall a b. a -> (a -> b) -> b
|> String -> Maybe String -> String
forall a. a -> Maybe a -> a
Maybe.fromMaybe ""
    capturedHeaders :: Maybe [(String, String)]
capturedHeaders = [CI ByteString] -> [Header] -> Maybe [(String, String)]
collectHeaders [CI ByteString]
extraHeadersConfig ([Header] -> Maybe [(String, String)])
-> [Header] -> Maybe [(String, String)]
forall a b. (a -> b) -> a -> b
$ Request -> [Header]
Wai.requestHeaders Request
request
    httpAnnotations :: [Annotation]
httpAnnotations =
      [ Text -> String -> Annotation
forall a. ToJSON a => Text -> a -> Annotation
SpanData.simpleAnnotation "method" (String -> Annotation) -> String -> Annotation
forall a b. (a -> b) -> a -> b
$
          Request -> ByteString
Wai.requestMethod Request
request ByteString -> (ByteString -> String) -> String
forall a b. a -> (a -> b) -> b
|> ByteString -> String
BSC8.unpack
      , Text -> String -> Annotation
forall a. ToJSON a => Text -> a -> Annotation
SpanData.simpleAnnotation "url"    (String -> Annotation) -> String -> Annotation
forall a b. (a -> b) -> a -> b
$
          Request -> ByteString
Wai.rawPathInfo Request
request ByteString -> (ByteString -> String) -> String
forall a b. a -> (a -> b) -> b
|> ByteString -> String
BSC8.unpack
      , Text -> String -> Annotation
forall a. ToJSON a => Text -> a -> Annotation
SpanData.simpleAnnotation "host" (String -> Annotation) -> String -> Annotation
forall a b. (a -> b) -> a -> b
$ String
host
      , Text -> Maybe Text -> Annotation
forall a. ToJSON a => Text -> Maybe a -> Annotation
SpanData.optionalAnnotation "params" (Maybe Text -> Annotation) -> Maybe Text -> Annotation
forall a b. (a -> b) -> a -> b
$
           (SecretsMatcher -> ByteString -> Maybe Text
processQueryString SecretsMatcher
secretsMatcher (Request -> ByteString
Wai.rawQueryString Request
request))
      ]
    httpAnnotations' :: [Annotation]
httpAnnotations' =
      case Maybe [(String, String)]
capturedHeaders of
        Just headers :: [(String, String)]
headers ->
          [Annotation]
httpAnnotations [Annotation] -> [Annotation] -> [Annotation]
forall a. [a] -> [a] -> [a]
++ [Text -> [(String, String)] -> Annotation
forall a. ToJSON a => Text -> [a] -> Annotation
SpanData.listAnnotation "header" [(String, String)]
headers]
        Nothing ->
          [Annotation]
httpAnnotations

  InstanaContext -> Annotation -> m ()
forall (m :: * -> *).
MonadIO m =>
InstanaContext -> Annotation -> m ()
addAnnotation InstanaContext
context (Text -> [Annotation] -> Annotation
Object "http" [Annotation]
httpAnnotations')
  InstanaContext -> Bool -> m ()
forall (m :: * -> *). MonadIO m => InstanaContext -> Bool -> m ()
setSynthetic InstanaContext
context Bool
synthetic


collectHeaders ::
  [CI BSC8.ByteString]
  -> [HTTPTypes.Header]
  -> Maybe [(String, String)]
collectHeaders :: [CI ByteString] -> [Header] -> Maybe [(String, String)]
collectHeaders extraHeadersConfig :: [CI ByteString]
extraHeadersConfig allHeaders :: [Header]
allHeaders =
  let
    all2 :: [Header]
all2 = [Header]
allHeaders
    filtered :: [Header]
filtered = [CI ByteString] -> [Header] -> [Header]
filterHeaders [CI ByteString]
extraHeadersConfig [Header]
all2
    serialized :: [(String, String)]
serialized =
      (Header -> (String, String)) -> [Header] -> [(String, String)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
        (\(name :: CI ByteString
name, value :: ByteString
value) -> (ByteString -> String
BSC8.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ CI ByteString -> ByteString
forall s. CI s -> s
CI.original CI ByteString
name, ByteString -> String
BSC8.unpack ByteString
value))
        [Header]
filtered
  in
  if [(String, String)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(String, String)]
serialized then Maybe [(String, String)]
forall a. Maybe a
Nothing else [(String, String)] -> Maybe [(String, String)]
forall a. a -> Maybe a
Just [(String, String)]
serialized


filterHeaders :: [CI BSC8.ByteString] -> [HTTPTypes.Header] -> [HTTPTypes.Header]
filterHeaders :: [CI ByteString] -> [Header] -> [Header]
filterHeaders configuredList :: [CI ByteString]
configuredList allHeaders :: [Header]
allHeaders =
  let
    filterFn :: (CI ByteString, b) -> Bool
filterFn (name :: CI ByteString
name, _) =
      CI ByteString -> [CI ByteString] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem CI ByteString
name [CI ByteString]
configuredList
  in
  (Header -> Bool) -> [Header] -> [Header]
forall a. (a -> Bool) -> [a] -> [a]
filter Header -> Bool
forall b. (CI ByteString, b) -> Bool
filterFn [Header]
allHeaders


-- |Adds website correlation annotations to the HTTP entry span.
addCorrelationTypeAndIdToSpan ::
  MonadIO m =>
  InstanaContext
  -> TracingHeaders
  -> m ()
addCorrelationTypeAndIdToSpan :: InstanaContext -> TracingHeaders -> m ()
addCorrelationTypeAndIdToSpan context :: InstanaContext
context tracingHeaders :: TracingHeaders
tracingHeaders = do
  let
    correlationType :: Maybe String
correlationType = TracingHeaders -> Maybe String
TracingHeaders.correlationType TracingHeaders
tracingHeaders
    correlationId :: Maybe String
correlationId = TracingHeaders -> Maybe String
TracingHeaders.correlationId TracingHeaders
tracingHeaders
  case (Maybe String
correlationType, Maybe String
correlationId) of
    (Nothing, Nothing) ->
      () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    (Just crtp :: String
crtp, Nothing) -> do
      InstanaContext -> Text -> m ()
forall (m :: * -> *). MonadIO m => InstanaContext -> Text -> m ()
setCorrelationType InstanaContext
context (String -> Text
T.pack String
crtp)
      () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    (Nothing, Just crid :: String
crid) -> do
      InstanaContext -> Text -> m ()
forall (m :: * -> *). MonadIO m => InstanaContext -> Text -> m ()
setCorrelationId InstanaContext
context (String -> Text
T.pack String
crid)
      () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    (Just crtp :: String
crtp, Just crid :: String
crid) -> do
      InstanaContext -> Text -> m ()
forall (m :: * -> *). MonadIO m => InstanaContext -> Text -> m ()
setCorrelationType InstanaContext
context (String -> Text
T.pack String
crtp)
      InstanaContext -> Text -> m ()
forall (m :: * -> *). MonadIO m => InstanaContext -> Text -> m ()
setCorrelationId InstanaContext
context (String -> Text
T.pack String
crid)
      () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()


-- |Processes the response of an HTTP entry. This function needs be called while
-- the HTTP entry span is still active. It can be used inside a 'withHttpEntry_'
-- block or between 'startHttpEntry' and 'completeEntry'.
--
-- This function accomplishes two things:
-- * It captures the HTTP status code from the response and adds it as an
--   annotation to the currently active span.
-- * It adds an additional HTTP response header (Server-Timing) to the given HTTP
--   response that enables website monitoring back end correlation. In case the
--   response already has a Server-Timing header, a value is appended to the
--   existing Server-Timing list.
--
-- Client code should rarely have the need to call this directly. Instead,
-- capture incoming HTTP requests with 'withHttpEntry', which does
-- both of these things automatically.
--
-- Clients should make sure to call this in the context provided above, that is,
-- within 'withHttpEntry_' or between 'startHttpEntry' and 'completeEntry' but
-- outside of blocks that create an exit span, that is, outside of 'withExit',
-- 'withHttpExit' and not between 'startExit' and 'completeExit'.
postProcessHttpResponse ::
  MonadIO m =>
  InstanaContext
  -> Wai.Response
  -> m Wai.Response
postProcessHttpResponse :: InstanaContext -> Response -> m Response
postProcessHttpResponse context :: InstanaContext
context response :: Response
response = do
  IO Response -> m Response
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Response -> m Response) -> IO Response -> m Response
forall a b. (a -> b) -> a -> b
$ do
    InstanaContext -> Response -> IO ()
captureHttpStatusUnlifted InstanaContext
context Response
response
    InstanaContext -> Response -> IO ()
forall (m :: * -> *).
MonadIO m =>
InstanaContext -> Response -> m ()
captureResponseHeaders InstanaContext
context Response
response
    InstanaContext -> Response -> IO Response
addWebsiteMonitoringBackEndCorrelationUnlifted InstanaContext
context Response
response


-- |Captures the status code of the HTTP response and adds it to the currently
-- active span. If the status code is >= 500, the status message is also
-- captured. This function needs be called while the HTTP entry span is still
-- active. It can be used inside a 'withHttpEntry_' block or between
-- 'startHttpEntry' and 'completeEntry'.
--
-- Client code should rarely have the need to call this directly. Instead,
-- capture incoming HTTP requests with 'withHttpEntry', which captures the
-- status code automatically and also adds the Server-Timing header for back end
-- web site monitoring correlation. When not using 'withHttpEntry', the function
-- 'postProcessHttpResponse' should be preferred over this function, because it
-- does both (capture the status code and add the Server-Timing header).
captureHttpStatus ::
  MonadIO m =>
  InstanaContext
  -> Wai.Response
  -> m ()
captureHttpStatus :: InstanaContext -> Response -> m ()
captureHttpStatus context :: InstanaContext
context response :: Response
response = do
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ InstanaContext -> Response -> IO ()
captureHttpStatusUnlifted InstanaContext
context Response
response


-- |Captures the status code of the HTTP response and adds it to the currently
-- active span. If the status code is >= 500, the status message is also
-- captured.
captureHttpStatusUnlifted ::
  InstanaContext
  -> Wai.Response
  -> IO ()
captureHttpStatusUnlifted :: InstanaContext -> Response -> IO ()
captureHttpStatusUnlifted context :: InstanaContext
context response :: Response
response = do
  let
    (HTTPTypes.Status statusCode :: Int
statusCode statusMessage :: ByteString
statusMessage) =
      Response -> Status
Wai.responseStatus Response
response
  InstanaContext -> Text -> AnnotationValue -> IO ()
forall (m :: * -> *) a.
(MonadIO m, ToJSON a) =>
InstanaContext -> Text -> a -> m ()
addAnnotationToEntrySpanAt InstanaContext
context "http.status" (AnnotationValue -> IO ()) -> AnnotationValue -> IO ()
forall a b. (a -> b) -> a -> b
$
    Int -> AnnotationValue
forall a. ToJSON a => a -> AnnotationValue
SpanData.simpleValue Int
statusCode
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
    (Int
statusCode Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 500 )
    (InstanaContext -> Text -> AnnotationValue -> IO ()
forall (m :: * -> *) a.
(MonadIO m, ToJSON a) =>
InstanaContext -> Text -> a -> m ()
addAnnotationAt InstanaContext
context "http.message" (AnnotationValue -> IO ()) -> AnnotationValue -> IO ()
forall a b. (a -> b) -> a -> b
$
      String -> AnnotationValue
forall a. ToJSON a => a -> AnnotationValue
SpanData.simpleValue (String -> AnnotationValue) -> String -> AnnotationValue
forall a b. (a -> b) -> a -> b
$ ByteString -> String
BSC8.unpack ByteString
statusMessage
    )


-- |Captures the HTTP headers of the response, if extra headers for capture have
-- been configured. The captured header (if any) will be added to the currently
-- active span. This function needs be called while the HTTP entry span is still
-- active. It can be used inside a 'withHttpEntry_' block or between
-- 'startHttpEntry' and 'completeEntry'.
--
-- Client code should rarely have the need to call this directly. Instead,
-- capture incoming HTTP requests with 'withHttpEntry', which captures the
-- headers automatically. When not using 'withHttpEntry', the function
-- 'postProcessHttpResponse' should be preferred over this function.
captureResponseHeaders ::
  MonadIO m =>
  InstanaContext
  -> Wai.Response
  -> m ()
captureResponseHeaders :: InstanaContext -> Response -> m ()
captureResponseHeaders context :: InstanaContext
context response :: Response
response = do
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ InstanaContext -> Response -> IO ()
captureResponseHeadersUnlifted InstanaContext
context Response
response


-- |Captures the HTTP headers of the response, if extra headers for capture have
-- been configured. The captured header (if any) will be added to the currently
-- active span.
captureResponseHeadersUnlifted ::
  InstanaContext
  -> Wai.Response
  -> IO ()
captureResponseHeadersUnlifted :: InstanaContext -> Response -> IO ()
captureResponseHeadersUnlifted context :: InstanaContext
context response :: Response
response = do
  [CI ByteString]
extraHeadersConfig <- IO [CI ByteString] -> IO [CI ByteString]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [CI ByteString] -> IO [CI ByteString])
-> IO [CI ByteString] -> IO [CI ByteString]
forall a b. (a -> b) -> a -> b
$ InstanaContext -> IO [CI ByteString]
InternalContext.readExtraHeaders InstanaContext
context
  let
    capturedHeaders :: Maybe [(String, String)]
capturedHeaders =
      [CI ByteString] -> [Header] -> Maybe [(String, String)]
collectHeaders [CI ByteString]
extraHeadersConfig ([Header] -> Maybe [(String, String)])
-> [Header] -> Maybe [(String, String)]
forall a b. (a -> b) -> a -> b
$ Response -> [Header]
Wai.responseHeaders Response
response
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
    (Maybe [(String, String)] -> Bool
forall a. Maybe a -> Bool
Maybe.isJust Maybe [(String, String)]
capturedHeaders)
    (do
       let
         Just headers :: [(String, String)]
headers = Maybe [(String, String)]
capturedHeaders
       InstanaContext -> Text -> AnnotationValue -> IO ()
forall (m :: * -> *).
MonadIO m =>
InstanaContext -> Text -> AnnotationValue -> m ()
addAnnotationValueToEntrySpanAt InstanaContext
context "http.header" (AnnotationValue -> IO ()) -> AnnotationValue -> IO ()
forall a b. (a -> b) -> a -> b
$
         [(String, String)] -> AnnotationValue
forall a. ToJSON a => [a] -> AnnotationValue
SpanData.listValue [(String, String)]
headers
    )


-- |Adds an additional HTTP response header (Server-Timing) to the given HTTP
-- response that enables website monitoring back end correlation. In case the
-- response already has a Server-Timing header, a value is appended to the
-- existing Server-Timing list. This function needs be called while the HTTP
-- entry span is still active. It can be used inside a 'withHttpEntry_' block or
-- between 'startHttpEntry' and 'completeEntry'.
--
-- Client code should rarely have the need to call this directly. Instead,
-- capture incoming HTTP requests with 'withHttpEntry', which adds the
-- response header automatically and also captures the HTTP status code of the
-- response. When not using 'withHttpEntry', the function
-- 'postProcessHttpResponse' should be preferred over this function, because
-- it does both (capture the status code and add the Server-Timing header).
addWebsiteMonitoringBackEndCorrelation ::
  MonadIO m =>
  InstanaContext
  -> Wai.Response
  -> m Wai.Response
addWebsiteMonitoringBackEndCorrelation :: InstanaContext -> Response -> m Response
addWebsiteMonitoringBackEndCorrelation context :: InstanaContext
context response :: Response
response = do
  IO Response -> m Response
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Response -> m Response) -> IO Response -> m Response
forall a b. (a -> b) -> a -> b
$ InstanaContext -> Response -> IO Response
addWebsiteMonitoringBackEndCorrelationUnlifted InstanaContext
context Response
response


-- |Adds an additional HTTP response header (Server-Timing) to the given HTTP
-- response that enables website monitoring back end correlation. In case the
-- response already has a Server-Timing header, a value is appended to the
-- existing Server-Timing list.
addWebsiteMonitoringBackEndCorrelationUnlifted ::
  InstanaContext
  -> Wai.Response
  -> IO Wai.Response
addWebsiteMonitoringBackEndCorrelationUnlifted :: InstanaContext -> Response -> IO Response
addWebsiteMonitoringBackEndCorrelationUnlifted context :: InstanaContext
context response :: Response
response = do
  Maybe Id
traceIdMaybe <- InstanaContext -> IO (Maybe Id)
currentTraceIdInternal InstanaContext
context
  Bool
suppressed <- InstanaContext -> IO Bool
isSuppressed InstanaContext
context
  case (Maybe Id
traceIdMaybe, Bool
suppressed) of
    (Just traceId :: Id
traceId, False) ->
      Response -> IO Response
forall (m :: * -> *) a. Monad m => a -> m a
return (Response -> IO Response) -> Response -> IO Response
forall a b. (a -> b) -> a -> b
$
        ([Header] -> [Header]) -> Response -> Response
Wai.mapResponseHeaders
        (Id -> [Header] -> [Header]
ServerTiming.addTraceIdToServerTiming Id
traceId)
        Response
response
    _ ->
      Response -> IO Response
forall (m :: * -> *) a. Monad m => a -> m a
return Response
response


-- |Creates a preliminary/incomplete exit span, which should later be completed
-- with 'completeExit'.
startExit ::
  MonadIO m =>
  InstanaContext
  -> SpanType
  -> m ()
startExit :: InstanaContext -> SpanType -> m ()
startExit context :: InstanaContext
context spanType :: SpanType
spanType = do
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    Bool
suppressed <- InstanaContext -> IO Bool
isSuppressed InstanaContext
context
    if Bool
suppressed then
      () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    else do
      Maybe Span
entrySpan <- InstanaContext -> IO (Maybe Span)
peekSpan InstanaContext
context
      case Maybe Span
entrySpan of
        Just (Entry parent :: EntrySpan
parent) -> do
          Id
spanId <- IO Id
Id.generate
          Int
timestamp <- POSIXTime -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round (POSIXTime -> Int) -> (POSIXTime -> POSIXTime) -> POSIXTime -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (POSIXTime -> POSIXTime -> POSIXTime
forall a. Num a => a -> a -> a
* 1000) (POSIXTime -> Int) -> IO POSIXTime -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO POSIXTime
getPOSIXTime
          let
            parentW3cTraceContext :: Maybe W3CTraceContext
parentW3cTraceContext = EntrySpan -> Maybe W3CTraceContext
EntrySpan.w3cTraceContext EntrySpan
parent
            w3cTraceContext :: W3CTraceContext
w3cTraceContext =
              case Maybe W3CTraceContext
parentW3cTraceContext of
                Just w3cCtx :: W3CTraceContext
w3cCtx ->
                  W3CTraceContext -> Id -> Id -> W3CTraceContext
W3CTraceContext.inheritFrom
                    W3CTraceContext
w3cCtx
                    (EntrySpan -> Id
EntrySpan.traceId EntrySpan
parent)
                    Id
spanId
                Nothing ->
                  Id -> Id -> W3CTraceContext
W3CTraceContext.exitSpanContextFromIds
                    (EntrySpan -> Id
EntrySpan.traceId EntrySpan
parent)
                    Id
spanId
            newSpan :: ExitSpan
newSpan =
              ExitSpan :: EntrySpan
-> Id
-> SpanType
-> Int
-> Maybe Text
-> Int
-> SpanData
-> W3CTraceContext
-> ExitSpan
ExitSpan
                { parentSpan :: EntrySpan
ExitSpan.parentSpan      = EntrySpan
parent
                , spanId :: Id
ExitSpan.spanId          = Id
spanId
                , spanType :: SpanType
ExitSpan.spanType        = SpanType
spanType
                , timestamp :: Int
ExitSpan.timestamp       = Int
timestamp
                , errorCount :: Int
ExitSpan.errorCount      = 0
                , serviceName :: Maybe Text
ExitSpan.serviceName     = Maybe Text
forall a. Maybe a
Nothing
                , spanData :: SpanData
ExitSpan.spanData        = SpanKind -> SpanType -> SpanData
Span.initialData
                                               SpanKind
ExitKind
                                               SpanType
spanType
                , w3cTraceContext :: W3CTraceContext
ExitSpan.w3cTraceContext = W3CTraceContext
w3cTraceContext
                }
          InstanaContext -> (Maybe SpanStack -> SpanStack) -> IO ()
pushSpan
            InstanaContext
context
            (\stack :: Maybe SpanStack
stack ->
              case Maybe SpanStack
stack of
                Nothing        ->
                  -- No entry present, it is invalid to push an exit onto the
                  -- stack without an entry. But we can at least init a stack
                  -- for the current thread.
                  SpanStack
SpanStack.empty
                Just spanStack :: SpanStack
spanStack ->
                  SpanStack
spanStack
                  SpanStack -> (SpanStack -> SpanStack) -> SpanStack
forall a b. a -> (a -> b) -> b
|> Span -> SpanStack -> SpanStack
SpanStack.push (ExitSpan -> Span
Exit ExitSpan
newSpan)
            )
        Just (Exit ex :: ExitSpan
ex) -> do
          String -> String -> IO ()
warningM String
instanaLogger (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
            "Cannot start exit span \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ SpanType -> String
forall a. Show a => a -> String
show SpanType
spanType String -> String -> String
forall a. [a] -> [a] -> [a]
++
            "\" since there is already an active exit span " String -> String -> String
forall a. [a] -> [a] -> [a]
++
            "in progress: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ExitSpan -> String
forall a. Show a => a -> String
show ExitSpan
ex
        Nothing -> do
          String -> String -> IO ()
warningM String
instanaLogger (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
            "Cannot start exit span \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ SpanType -> String
forall a. Show a => a -> String
show SpanType
spanType String -> String -> String
forall a. [a] -> [a] -> [a]
++
            "\" since there is no active entry span " String -> String -> String
forall a. [a] -> [a] -> [a]
++
            "(actually, there is no active span at all)."
          () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()


-- |Creates a preliminary/incomplete http exit span, which should later be
-- completed with 'completeExit'. The Instana tracing headers are added to the
-- request and the modified request value is returned (use the return value of
-- this function to execute your request instead of the request value passed
-- into this function).
startHttpExit ::
  MonadIO m =>
  InstanaContext
  -> HTTP.Request
  -> m HTTP.Request
startHttpExit :: InstanaContext -> Request -> m Request
startHttpExit context :: InstanaContext
context request :: Request
request = do
  [CI ByteString]
extraHeadersConfig <- IO [CI ByteString] -> m [CI ByteString]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [CI ByteString] -> m [CI ByteString])
-> IO [CI ByteString] -> m [CI ByteString]
forall a b. (a -> b) -> a -> b
$ InstanaContext -> IO [CI ByteString]
InternalContext.readExtraHeaders InstanaContext
context
  SecretsMatcher
secretsMatcher <- IO SecretsMatcher -> m SecretsMatcher
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO SecretsMatcher -> m SecretsMatcher)
-> IO SecretsMatcher -> m SecretsMatcher
forall a b. (a -> b) -> a -> b
$ InstanaContext -> IO SecretsMatcher
InternalContext.readSecretsMatcher InstanaContext
context

  let
    originalCheckResponse :: Request -> Response BodyReader -> IO ()
originalCheckResponse = Request -> Request -> Response BodyReader -> IO ()
HTTP.checkResponse Request
request
    request' :: Request
request' =
      Request
request
        -- Inject a checkResponse hook to capture the response status and
        -- response headers.
        { checkResponse :: Request -> Response BodyReader -> IO ()
HTTP.checkResponse = (\req :: Request
req res :: Response BodyReader
res -> do
            let
              status :: Int
status =
                Response BodyReader
res
                  Response BodyReader -> (Response BodyReader -> Status) -> Status
forall a b. a -> (a -> b) -> b
|> Response BodyReader -> Status
forall body. Response body -> Status
HTTP.responseStatus
                  Status -> (Status -> Int) -> Int
forall a b. a -> (a -> b) -> b
|> Status -> Int
HTTPTypes.statusCode
              capturedResponseHeaders :: Maybe [(String, String)]
capturedResponseHeaders =
                [CI ByteString] -> [Header] -> Maybe [(String, String)]
collectHeaders [CI ByteString]
extraHeadersConfig ([Header] -> Maybe [(String, String)])
-> [Header] -> Maybe [(String, String)]
forall a b. (a -> b) -> a -> b
$
                  Response BodyReader -> [Header]
forall body. Response body -> [Header]
HTTP.responseHeaders Response BodyReader
res

            InstanaContext -> Text -> AnnotationValue -> IO ()
forall (m :: * -> *) a.
(MonadIO m, ToJSON a) =>
InstanaContext -> Text -> a -> m ()
addAnnotationAt InstanaContext
context "http.status" (AnnotationValue -> IO ()) -> AnnotationValue -> IO ()
forall a b. (a -> b) -> a -> b
$
              Int -> AnnotationValue
forall a. ToJSON a => a -> AnnotationValue
SpanData.simpleValue Int
status

            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
              (Maybe [(String, String)] -> Bool
forall a. Maybe a -> Bool
Maybe.isJust Maybe [(String, String)]
capturedResponseHeaders)
              (do
                 let
                   Just responseHeaders :: [(String, String)]
responseHeaders = Maybe [(String, String)]
capturedResponseHeaders
                 InstanaContext -> Text -> AnnotationValue -> IO ()
forall (m :: * -> *).
MonadIO m =>
InstanaContext -> Text -> AnnotationValue -> m ()
addAnnotationValueAt InstanaContext
context "http.header" (AnnotationValue -> IO ()) -> AnnotationValue -> IO ()
forall a b. (a -> b) -> a -> b
$
                   [(String, String)] -> AnnotationValue
forall a. ToJSON a => [a] -> AnnotationValue
SpanData.listValue [(String, String)]
responseHeaders
              )

            Request -> Response BodyReader -> IO ()
originalCheckResponse Request
req Response BodyReader
res
          )
        }
    port :: String
port = ":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ Request -> Int
HTTP.port Request
request)
    protocol :: String
protocol = if Request -> Bool
HTTP.secure Request
request then "https://" else "http://"
    host :: String
host = ByteString -> String
BSC8.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
HTTP.host Request
request
    path :: String
path = ByteString -> String
BSC8.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
HTTP.path Request
request
    url :: String
url = String
protocol String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
host String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
port String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
path
    capturedRequestHeaders :: Maybe [(String, String)]
capturedRequestHeaders = [CI ByteString] -> [Header] -> Maybe [(String, String)]
collectHeaders [CI ByteString]
extraHeadersConfig ([Header] -> Maybe [(String, String)])
-> [Header] -> Maybe [(String, String)]
forall a b. (a -> b) -> a -> b
$ Request -> [Header]
HTTP.requestHeaders Request
request
    httpAnnotations :: [Annotation]
httpAnnotations =
      [ Text -> String -> Annotation
forall a. ToJSON a => Text -> a -> Annotation
SpanData.simpleAnnotation "method" (String -> Annotation) -> String -> Annotation
forall a b. (a -> b) -> a -> b
$ ByteString -> String
BSC8.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
HTTP.method Request
request
      , Text -> String -> Annotation
forall a. ToJSON a => Text -> a -> Annotation
SpanData.simpleAnnotation "url"    String
url
      , Text -> Maybe Text -> Annotation
forall a. ToJSON a => Text -> Maybe a -> Annotation
SpanData.optionalAnnotation "params"
          (SecretsMatcher -> ByteString -> Maybe Text
processQueryString SecretsMatcher
secretsMatcher (Request -> ByteString
HTTP.queryString Request
request))
      ]
    httpAnnotations' :: [Annotation]
httpAnnotations' =
      case Maybe [(String, String)]
capturedRequestHeaders of
        Just requestHeaders :: [(String, String)]
requestHeaders ->
          [Annotation]
httpAnnotations [Annotation] -> [Annotation] -> [Annotation]
forall a. [a] -> [a] -> [a]
++ [Text -> [(String, String)] -> Annotation
forall a. ToJSON a => Text -> [a] -> Annotation
SpanData.listAnnotation "header" [(String, String)]
requestHeaders]
        Nothing ->
          [Annotation]
httpAnnotations

  InstanaContext -> SpanType -> m ()
forall (m :: * -> *).
MonadIO m =>
InstanaContext -> SpanType -> m ()
startExit InstanaContext
context (RegisteredSpanType -> SpanType
RegisteredSpan RegisteredSpanType
SpanType.HaskellHttpClient)
  Request
request'' <- InstanaContext -> Request -> m Request
forall (m :: * -> *).
MonadIO m =>
InstanaContext -> Request -> m Request
addHttpTracingHeaders InstanaContext
context Request
request'
  InstanaContext -> Annotation -> m ()
forall (m :: * -> *).
MonadIO m =>
InstanaContext -> Annotation -> m ()
addAnnotation InstanaContext
context (Text -> [Annotation] -> Annotation
Object "http" [Annotation]
httpAnnotations')
  Request -> m Request
forall (m :: * -> *) a. Monad m => a -> m a
return Request
request''


processQueryString :: Secrets.SecretsMatcher -> BSC8.ByteString -> Maybe Text
processQueryString :: SecretsMatcher -> ByteString -> Maybe Text
processQueryString secretsMatcher :: SecretsMatcher
secretsMatcher queryString :: ByteString
queryString =
  ByteString
queryString
    ByteString -> (ByteString -> String) -> String
forall a b. a -> (a -> b) -> b
|> ByteString -> String
BSC8.unpack
    String -> (String -> Text) -> Text
forall a b. a -> (a -> b) -> b
|> String -> Text
T.pack
    -- drop leading "?" character
    Text -> (Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
|> (\t :: Text
t -> if (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
T.null) Text
t Bool -> Bool -> Bool
&& Text -> Char
T.head Text
t Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '?' then Text -> Text
T.tail Text
t else Text
t)
    -- split on "&" delimiter
    Text -> (Text -> [Text]) -> [Text]
forall a b. a -> (a -> b) -> b
|> Text -> Text -> [Text]
T.splitOn "&"
    -- splitOn can yield "" elements, drop them
    [Text] -> ([Text] -> [Text]) -> [Text]
forall a b. a -> (a -> b) -> b
|> (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
List.filter (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
T.null)
    -- convert to pairs of query string name and value
    [Text] -> ([Text] -> [(Text, Text)]) -> [(Text, Text)]
forall a b. a -> (a -> b) -> b
|> (Text -> (Text, Text)) -> [Text] -> [(Text, Text)]
forall a b. (a -> b) -> [a] -> [b]
List.map (Text -> Text -> (Text, Text)
T.breakOn "=")
    -- drop leading "=" from value (breakOn includes the delimiter if present)
    [(Text, Text)]
-> ([(Text, Text)] -> [(Text, Text)]) -> [(Text, Text)]
forall a b. a -> (a -> b) -> b
|> ((Text, Text) -> (Text, Text)) -> [(Text, Text)] -> [(Text, Text)]
forall a b. (a -> b) -> [a] -> [b]
List.map (\tuple :: (Text, Text)
tuple ->
         if Text -> Text -> Bool
T.isPrefixOf "=" ((Text, Text) -> Text
forall a b. (a, b) -> b
snd (Text, Text)
tuple)
           then
             ((Text, Text) -> Text
forall a b. (a, b) -> a
fst (Text, Text)
tuple, Text -> Text
T.tail (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ (Text, Text) -> Text
forall a b. (a, b) -> b
snd (Text, Text)
tuple)
           else
             (Text, Text)
tuple
       )
    -- redact secrets
    [(Text, Text)]
-> ([(Text, Text)] -> [(Text, Text)]) -> [(Text, Text)]
forall a b. a -> (a -> b) -> b
|> ((Text, Text) -> (Text, Text)) -> [(Text, Text)] -> [(Text, Text)]
forall a b. (a -> b) -> [a] -> [b]
List.map (\tuple :: (Text, Text)
tuple ->
         if (SecretsMatcher -> Text -> Bool
Secrets.isSecret SecretsMatcher
secretsMatcher) ((Text, Text) -> Text
forall a b. (a, b) -> a
fst (Text, Text)
tuple)
           then
             ((Text, Text) -> Text
forall a b. (a, b) -> a
fst (Text, Text)
tuple, "<redacted>")
           else
             (Text, Text)
tuple
       )
    -- put pairs back together
    [(Text, Text)] -> ([(Text, Text)] -> [Text]) -> [Text]
forall a b. a -> (a -> b) -> b
|> ((Text, Text) -> Text) -> [(Text, Text)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
List.map (\tuple :: (Text, Text)
tuple -> [Text] -> Text
T.concat [(Text, Text) -> Text
forall a b. (a, b) -> a
fst (Text, Text)
tuple, "=", (Text, Text) -> Text
forall a b. (a, b) -> b
snd (Text, Text)
tuple])
    -- concat into one string again
    [Text] -> ([Text] -> Text) -> Text
forall a b. a -> (a -> b) -> b
|> Text -> [Text] -> Text
T.intercalate "&"
    -- drop param if there were no query parameters
    Text -> (Text -> Maybe Text) -> Maybe Text
forall a b. a -> (a -> b) -> b
|> (\t :: Text
t -> if Text
t Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "" then Maybe Text
forall a. Maybe a
Nothing else Text -> Maybe Text
forall a. a -> Maybe a
Just Text
t)


-- |Completes an entry span, to be called at the last possible moment before the
-- call has been processed completely.
completeEntry ::
  MonadIO m =>
  InstanaContext
  -> m ()
completeEntry :: InstanaContext -> m ()
completeEntry context :: InstanaContext
context = do
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    (poppedSpan :: Maybe Span
poppedSpan, warning :: Maybe String
warning) <- InstanaContext -> SpanKind -> IO (Maybe Span, Maybe String)
popSpan InstanaContext
context SpanKind
EntryKind
    case (Maybe Span
poppedSpan, Maybe String
warning) of
      (Just (Entry entrySpan :: EntrySpan
entrySpan), _) ->
        InstanaContext -> Command -> IO ()
enqueueCommand
          InstanaContext
context
          (EntrySpan -> Command
Command.CompleteEntry EntrySpan
entrySpan)
      (_, Just warnMessage :: String
warnMessage) -> do
        String -> String -> IO ()
warningM String
instanaLogger (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
          "Cannot complete entry span due to a span stack mismatch: " String -> String -> String
forall a. [a] -> [a] -> [a]
++
          String
warnMessage
        () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      _ -> do
        String -> String -> IO ()
warningM String
instanaLogger (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
          "Cannot complete entry span due to a span stack mismatch - there " String -> String -> String
forall a. [a] -> [a] -> [a]
++
          "is no active span or the currently active span is not an entry."
        () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()


-- |Completes an exit span, to be called as soon as the remote call has
-- returned.
completeExit ::
  MonadIO m =>
  InstanaContext
  -> m ()
completeExit :: InstanaContext -> m ()
completeExit context :: InstanaContext
context = do
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    Bool
suppressed <- InstanaContext -> IO Bool
isSuppressed InstanaContext
context
    if Bool
suppressed then
      () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    else do
      (poppedSpan :: Maybe Span
poppedSpan, warning :: Maybe String
warning) <- InstanaContext -> SpanKind -> IO (Maybe Span, Maybe String)
popSpan InstanaContext
context SpanKind
ExitKind
      case (Maybe Span
poppedSpan, Maybe String
warning) of
        (Just (Exit exitSpan :: ExitSpan
exitSpan), _) ->
          InstanaContext -> Command -> IO ()
enqueueCommand
            InstanaContext
context
            (ExitSpan -> Command
Command.CompleteExit ExitSpan
exitSpan)
        (_, Just warnMessage :: String
warnMessage) -> do
          String -> String -> IO ()
warningM String
instanaLogger (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
            "Cannot complete exit span due to a span stack mismatch: " String -> String -> String
forall a. [a] -> [a] -> [a]
++
            String
warnMessage
        _ -> do
          String -> String -> IO ()
warningM String
instanaLogger (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
            "Cannot complete exit span due to a span stack mismatch - there " String -> String -> String
forall a. [a] -> [a] -> [a]
++
            "is no active span or the currently active span is not an exit."
          () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()


-- |Increments the error count for the currently active span by one. Call this
-- between startEntry/startRootEntry/startExit and completeEntry/completeExit or
-- inside the IO action given to with withEntry/withExit/withRootEntry if an
-- error happens while processing the entry/exit.
--
-- This is an alias for `addToErrorCount instanaContext 1`.
incrementErrorCount :: MonadIO m => InstanaContext -> m ()
incrementErrorCount :: InstanaContext -> m ()
incrementErrorCount context :: InstanaContext
context =
  InstanaContext -> Int -> m ()
forall (m :: * -> *). MonadIO m => InstanaContext -> Int -> m ()
addToErrorCount InstanaContext
context 1


-- |Increments the error count for the currently active span by one. Call this
-- between startEntry/startRootEntry/startExit and completeEntry/completeExit or
-- inside the IO action given to with withEntry/withExit/withRootEntry if an
-- error happens while processing the entry/exit.
addToErrorCount :: MonadIO m => InstanaContext -> Int -> m ()
addToErrorCount :: InstanaContext -> Int -> m ()
addToErrorCount context :: InstanaContext
context increment :: Int
increment =
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ InstanaContext -> (Span -> Span) -> IO ()
modifyCurrentSpan InstanaContext
context
    (\span_ :: Span
span_ -> Int -> Span -> Span
Span.addToErrorCount Int
increment Span
span_)


-- |Override the name of the service for the associated call in Instana.
setServiceName :: MonadIO m => InstanaContext -> Text -> m ()
setServiceName :: InstanaContext -> Text -> m ()
setServiceName context :: InstanaContext
context serviceName_ :: Text
serviceName_ =
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ InstanaContext -> (Span -> Span) -> IO ()
modifyCurrentSpan InstanaContext
context
    (\span_ :: Span
span_ -> Text -> Span -> Span
Span.setServiceName Text
serviceName_ Span
span_)


-- |Set the website monitoring correlation type. This should only be set on
-- root entry spans. It will be silently ignored for other types of spans.
setCorrelationType :: MonadIO m => InstanaContext -> Text -> m ()
setCorrelationType :: InstanaContext -> Text -> m ()
setCorrelationType context :: InstanaContext
context correlationType_ :: Text
correlationType_ =
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ InstanaContext -> (Span -> Span) -> IO ()
modifyCurrentSpan InstanaContext
context
    (\span_ :: Span
span_ -> Text -> Span -> Span
Span.setCorrelationType Text
correlationType_ Span
span_)


-- |Set the website monitoring correlation ID. This should only be set on
-- root entry spans. It will be silently ignored for other types of spans.
setCorrelationId :: MonadIO m => InstanaContext -> Text -> m ()
setCorrelationId :: InstanaContext -> Text -> m ()
setCorrelationId context :: InstanaContext
context correlationId_ :: Text
correlationId_ =
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ InstanaContext -> (Span -> Span) -> IO ()
modifyCurrentSpan InstanaContext
context
    (\span_ :: Span
span_ -> Text -> Span -> Span
Span.setCorrelationId Text
correlationId_ Span
span_)


-- |Attaches a W3C trace context to the currently active span.
setW3cTraceContext ::
  MonadIO m =>
  InstanaContext ->
  Maybe W3CTraceContext ->
  m ()
setW3cTraceContext :: InstanaContext -> Maybe W3CTraceContext -> m ()
setW3cTraceContext context :: InstanaContext
context w3cTraceContext :: Maybe W3CTraceContext
w3cTraceContext =
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    case Maybe W3CTraceContext
w3cTraceContext of
      Just w3cCtx :: W3CTraceContext
w3cCtx ->
        InstanaContext -> (Span -> Span) -> IO ()
modifyCurrentSpan InstanaContext
context
          (\span_ :: Span
span_ -> W3CTraceContext -> Span -> Span
Span.setW3cTraceContext W3CTraceContext
w3cCtx Span
span_)
      Nothing ->
        () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()


-- |Sets the tp flag on the current span to mark it as a span that has
-- inherited the trace ID/parent ID from W3C trace context instead of Instana
-- headers.
setSpanTpFlag :: MonadIO m => InstanaContext -> m ()
setSpanTpFlag :: InstanaContext -> m ()
setSpanTpFlag context :: InstanaContext
context =
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ InstanaContext -> (Span -> Span) -> IO ()
modifyCurrentSpan InstanaContext
context
    (\span_ :: Span
span_ -> Span -> Span
Span.setTpFlag Span
span_)


-- |Set the synthetic flag. This should only be set on entry spans. It will be
-- silently ignored for other types of spans.
setSynthetic :: MonadIO m => InstanaContext -> Bool -> m ()
setSynthetic :: InstanaContext -> Bool -> m ()
setSynthetic context :: InstanaContext
context synthetic :: Bool
synthetic =
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ InstanaContext -> (Span -> Span) -> IO ()
modifyCurrentSpan InstanaContext
context
    (\span_ :: Span
span_ -> Bool -> Span -> Span
Span.setSynthetic Bool
synthetic Span
span_)


-- |Adds an annotation to the currently active span. Call this between
-- startEntry/startRootEntry/startExit and completeEntry/completeExit or
-- inside the IO action given to withEntry/withExit/withRootEntry.
-- The given path can be a nested path, with path fragments separated by dots,
-- like "http.url". This will result in
-- "data": {
--   ...
--   "http": {
--     "url": "..."
--   },
--   ...
-- }
addAnnotationAt ::
  (MonadIO m, ToJSON a) =>
  InstanaContext
  -> Text
  -> a
  -> m ()
addAnnotationAt :: InstanaContext -> Text -> a -> m ()
addAnnotationAt context :: InstanaContext
context path :: Text
path value :: a
value =
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ InstanaContext -> (Span -> Span) -> IO ()
modifyCurrentSpan InstanaContext
context
    (\span_ :: Span
span_ -> Text -> a -> Span -> Span
forall a. ToJSON a => Text -> a -> Span -> Span
Span.addAnnotationAt Text
path a
value Span
span_)


-- |Adds an annotation to the currently active span. Call this between
-- startEntry/startRootEntry/startExit and completeEntry/completeExit or
-- inside the IO action given to with withEntry/withExit/withRootEntry. Can be
-- called multiple times, data from multiple calls will be merged.
addAnnotation :: MonadIO m => InstanaContext -> Annotation -> m ()
addAnnotation :: InstanaContext -> Annotation -> m ()
addAnnotation context :: InstanaContext
context annotation :: Annotation
annotation =
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ InstanaContext -> (Span -> Span) -> IO ()
modifyCurrentSpan InstanaContext
context
    (\span_ :: Span
span_ -> Annotation -> Span -> Span
Span.addAnnotation Annotation
annotation Span
span_)


-- |Adds an annotation with the given value to the currently active span. Call
-- this between startEntry/startRootEntry/startExit and
-- completeEntry/completeExit or inside the IO action given to with
-- withEntry/withExit/withRootEntry. The given path can be a nested path, with
-- path fragments separated by dots, like "http.url". This will result in
-- "data": {
--   ...
--   "http": {
--     "url": "..."
--   },
--   ...
-- }
addAnnotationValueAt ::
  (MonadIO m) =>
  InstanaContext
  -> Text
  -> AnnotationValue
  -> m ()
addAnnotationValueAt :: InstanaContext -> Text -> AnnotationValue -> m ()
addAnnotationValueAt context :: InstanaContext
context path :: Text
path value :: AnnotationValue
value =
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ InstanaContext -> (Span -> Span) -> IO ()
modifyCurrentSpan InstanaContext
context
    (\span_ :: Span
span_ -> Text -> AnnotationValue -> Span -> Span
Span.addAnnotationValueAt Text
path AnnotationValue
value Span
span_)


-- |Adds an additional annotation to the currently active entry span, even if
-- the currently active span is an exit child of that entry span.
addAnnotationToEntrySpanAt ::
  (MonadIO m, ToJSON a) =>
  InstanaContext
  -> Text
  -> a
  -> m ()
addAnnotationToEntrySpanAt :: InstanaContext -> Text -> a -> m ()
addAnnotationToEntrySpanAt context :: InstanaContext
context path :: Text
path value :: a
value =
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ InstanaContext -> (Span -> Span) -> IO ()
modifyCurrentEntrySpan InstanaContext
context
    (\span_ :: Span
span_ -> Text -> a -> Span -> Span
forall a. ToJSON a => Text -> a -> Span -> Span
Span.addAnnotationAt Text
path a
value Span
span_)


-- |Adds an additional annotation to the currently active entry span, even if
-- the currently active span is an exit child of that entry span.
addAnnotationValueToEntrySpanAt ::
  (MonadIO m) =>
  InstanaContext
  -> Text
  -> AnnotationValue
  -> m ()
addAnnotationValueToEntrySpanAt :: InstanaContext -> Text -> AnnotationValue -> m ()
addAnnotationValueToEntrySpanAt context :: InstanaContext
context path :: Text
path value :: AnnotationValue
value =
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ InstanaContext -> (Span -> Span) -> IO ()
modifyCurrentEntrySpan InstanaContext
context
    (\span_ :: Span
span_ -> Text -> AnnotationValue -> Span -> Span
Span.addAnnotationValueAt Text
path AnnotationValue
value Span
span_)


-- |Adds the Instana tracing headers
-- (https://docs.instana.io/core_concepts/tracing/#http-tracing-headers)
-- from the currently active span to the given HTTP client request.
addHttpTracingHeaders ::
  MonadIO m =>
  InstanaContext
  -> HTTP.Request
  -> m HTTP.Request
addHttpTracingHeaders :: InstanaContext -> Request -> m Request
addHttpTracingHeaders context :: InstanaContext
context request :: Request
request =
  IO Request -> m Request
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Request -> m Request) -> IO Request -> m Request
forall a b. (a -> b) -> a -> b
$ do
    Bool
suppressed <- InstanaContext -> IO Bool
isSuppressed InstanaContext
context
    Maybe Id
traceId <- InstanaContext -> IO (Maybe Id)
currentTraceIdInternal InstanaContext
context
    Maybe Id
spanId <- InstanaContext -> IO (Maybe Id)
currentSpanIdInternal InstanaContext
context
    Maybe W3CTraceContext
w3cTraceContext <- InstanaContext -> IO (Maybe W3CTraceContext)
currentW3cTraceContext InstanaContext
context
    let
      originalHeaders :: [Header]
originalHeaders = Request -> [Header]
HTTP.requestHeaders Request
request
    case (Maybe Id
traceId, Maybe Id
spanId, Bool
suppressed) of
      (_, _, True) -> do
          W3CTraceContext
suppressedW3cTraceContext <-
            case Maybe W3CTraceContext
w3cTraceContext of
              Just w3cCtx :: W3CTraceContext
w3cCtx -> do
                Id
bogusParentId <- IO Id
Id.generate
                W3CTraceContext -> IO W3CTraceContext
forall (m :: * -> *) a. Monad m => a -> m a
return (W3CTraceContext -> IO W3CTraceContext)
-> W3CTraceContext -> IO W3CTraceContext
forall a b. (a -> b) -> a -> b
$
                  W3CTraceContext -> Id -> W3CTraceContext
W3CTraceContext.inheritFromForSuppressed
                    W3CTraceContext
w3cCtx
                    Id
bogusParentId
              Nothing -> do
                Maybe Id
bogusTraceIdFromStack <- InstanaContext -> IO (Maybe Id)
currentTraceIdInternal InstanaContext
context
                Id
bogusTraceId <-
                  case Maybe Id
bogusTraceIdFromStack of
                    Just tId :: Id
tId -> Id -> IO Id
forall (m :: * -> *) a. Monad m => a -> m a
return Id
tId
                    Nothing  -> IO Id
Id.generate
                Id
bogusParentId <- IO Id
Id.generate
                W3CTraceContext -> IO W3CTraceContext
forall (m :: * -> *) a. Monad m => a -> m a
return (W3CTraceContext -> IO W3CTraceContext)
-> W3CTraceContext -> IO W3CTraceContext
forall a b. (a -> b) -> a -> b
$ Id -> Id -> W3CTraceContext
W3CTraceContext.createExitContextForSuppressed Id
bogusTraceId Id
bogusParentId
          Request -> IO Request
forall (m :: * -> *) a. Monad m => a -> m a
return (Request -> IO Request) -> Request -> IO Request
forall a b. (a -> b) -> a -> b
$ Request
request {
            requestHeaders :: [Header]
HTTP.requestHeaders =
              ((CI ByteString
TracingHeaders.levelHeaderName, "0") Header -> [Header] -> [Header]
forall a. a -> [a] -> [a]
: [Header]
originalHeaders)
              [Header] -> [Header] -> [Header]
forall a. [a] -> [a] -> [a]
++ (Maybe W3CTraceContext -> [Header]
w3cTraceContextToHeaders (Maybe W3CTraceContext -> [Header])
-> Maybe W3CTraceContext -> [Header]
forall a b. (a -> b) -> a -> b
$ W3CTraceContext -> Maybe W3CTraceContext
forall a. a -> Maybe a
Just W3CTraceContext
suppressedW3cTraceContext)
          }

      (Just tId :: Id
tId, Just sId :: Id
sId, False) ->
        Request -> IO Request
forall (m :: * -> *) a. Monad m => a -> m a
return (Request -> IO Request) -> Request -> IO Request
forall a b. (a -> b) -> a -> b
$ Request
request {
          requestHeaders :: [Header]
HTTP.requestHeaders =
            ([Header]
originalHeaders [Header] -> [Header] -> [Header]
forall a. [a] -> [a] -> [a]
++
              [ (CI ByteString
TracingHeaders.traceIdHeaderName, Id -> ByteString
Id.toByteString Id
tId)
              , (CI ByteString
TracingHeaders.spanIdHeaderName, Id -> ByteString
Id.toByteString Id
sId)
              ]
              [Header] -> [Header] -> [Header]
forall a. [a] -> [a] -> [a]
++ Maybe W3CTraceContext -> [Header]
w3cTraceContextToHeaders Maybe W3CTraceContext
w3cTraceContext
            )
        }
      (Just tId :: Id
tId, Nothing, False) ->
        Request -> IO Request
forall (m :: * -> *) a. Monad m => a -> m a
return (Request -> IO Request) -> Request -> IO Request
forall a b. (a -> b) -> a -> b
$ Request
request {
          requestHeaders :: [Header]
HTTP.requestHeaders =
            ([Header]
originalHeaders [Header] -> [Header] -> [Header]
forall a. [a] -> [a] -> [a]
++
              [ (CI ByteString
TracingHeaders.traceIdHeaderName, Id -> ByteString
Id.toByteString Id
tId)
              ]
              [Header] -> [Header] -> [Header]
forall a. [a] -> [a] -> [a]
++ Maybe W3CTraceContext -> [Header]
w3cTraceContextToHeaders Maybe W3CTraceContext
w3cTraceContext
            )
        }
      (Nothing, Just sId :: Id
sId, False) ->
        Request -> IO Request
forall (m :: * -> *) a. Monad m => a -> m a
return (Request -> IO Request) -> Request -> IO Request
forall a b. (a -> b) -> a -> b
$ Request
request {
          requestHeaders :: [Header]
HTTP.requestHeaders =
            ([Header]
originalHeaders [Header] -> [Header] -> [Header]
forall a. [a] -> [a] -> [a]
++
              [ (CI ByteString
TracingHeaders.spanIdHeaderName, Id -> ByteString
Id.toByteString Id
sId)
              ]
              [Header] -> [Header] -> [Header]
forall a. [a] -> [a] -> [a]
++ Maybe W3CTraceContext -> [Header]
w3cTraceContextToHeaders Maybe W3CTraceContext
w3cTraceContext
            )
        }
      _ ->
        Request -> IO Request
forall (m :: * -> *) a. Monad m => a -> m a
return Request
request


w3cTraceContextToHeaders :: Maybe W3CTraceContext -> [HTTPTypes.Header]
w3cTraceContextToHeaders :: Maybe W3CTraceContext -> [Header]
w3cTraceContextToHeaders w3cTraceContext :: Maybe W3CTraceContext
w3cTraceContext =
  case Maybe W3CTraceContext
w3cTraceContext of
    Just w3cCtx :: W3CTraceContext
w3cCtx -> W3CTraceContext -> [Header]
W3CTraceContext.toHeaders W3CTraceContext
w3cCtx
    Nothing     -> []


-- |Sends a command to the worker thread.
enqueueCommand :: InstanaContext -> Command -> IO ()
enqueueCommand :: InstanaContext -> Command -> IO ()
enqueueCommand context :: InstanaContext
context command :: Command
command = do
  -- TODO Maybe we better should use a bounded queue and drop stuff if we can't
  -- keep up. For now, this is an unbounded queue that might turn into a memory
  -- leak if a lot of spans are written and the HTTP requests to the agent can't
  -- keep up.
  let
    commandQueue :: TQueue Command
commandQueue = InstanaContext -> TQueue Command
InternalContext.commandQueue InstanaContext
context
  STM () -> IO ()
forall a. STM a -> IO a
STM.atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TQueue Command -> Command -> STM ()
forall a. TQueue a -> a -> STM ()
STM.writeTQueue TQueue Command
commandQueue Command
command


-- |Makes the given span the currently active span.
pushSpan ::
  InstanaContext
  -> (Maybe SpanStack -> SpanStack)
  -> IO ()
pushSpan :: InstanaContext -> (Maybe SpanStack -> SpanStack) -> IO ()
pushSpan context :: InstanaContext
context fn :: Maybe SpanStack -> SpanStack
fn = do
  ThreadId
threadId <- IO ThreadId
Concurrent.myThreadId
  STM () -> IO ()
forall a. STM a -> IO a
STM.atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$
    TVar (Map ThreadId SpanStack)
-> (Map ThreadId SpanStack -> Map ThreadId SpanStack) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
STM.modifyTVar'
      (InstanaContext -> TVar (Map ThreadId SpanStack)
InternalContext.currentSpans InstanaContext
context)
      (\currentSpansPerThread :: Map ThreadId SpanStack
currentSpansPerThread ->
        let
          modifiedStack :: SpanStack
modifiedStack = Maybe SpanStack -> SpanStack
fn (Maybe SpanStack -> SpanStack) -> Maybe SpanStack -> SpanStack
forall a b. (a -> b) -> a -> b
$ ThreadId -> Map ThreadId SpanStack -> Maybe SpanStack
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ThreadId
threadId Map ThreadId SpanStack
currentSpansPerThread
        in
        ThreadId
-> SpanStack -> Map ThreadId SpanStack -> Map ThreadId SpanStack
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ThreadId
threadId SpanStack
modifiedStack Map ThreadId SpanStack
currentSpansPerThread
      )


-- |Yields the currently active span, taking it of the stack. The span below
-- that will become the new active span (if there is any).
popSpan :: InstanaContext -> SpanKind -> IO (Maybe Span, Maybe String)
popSpan :: InstanaContext -> SpanKind -> IO (Maybe Span, Maybe String)
popSpan context :: InstanaContext
context expectedKind :: SpanKind
expectedKind = do
  ThreadId
threadId <- IO ThreadId
Concurrent.myThreadId
  STM (Maybe Span, Maybe String) -> IO (Maybe Span, Maybe String)
forall a. STM a -> IO a
STM.atomically (STM (Maybe Span, Maybe String) -> IO (Maybe Span, Maybe String))
-> STM (Maybe Span, Maybe String) -> IO (Maybe Span, Maybe String)
forall a b. (a -> b) -> a -> b
$ InstanaContext
-> ThreadId -> SpanKind -> STM (Maybe Span, Maybe String)
popSpanStm InstanaContext
context ThreadId
threadId SpanKind
expectedKind


-- |Yields the currently active span, taking it of the stack. The span below
-- that will become the new active span (if there is any).
popSpanStm ::
  InstanaContext
  -> ThreadId
  -> SpanKind
  -> STM (Maybe Span, Maybe String)
popSpanStm :: InstanaContext
-> ThreadId -> SpanKind -> STM (Maybe Span, Maybe String)
popSpanStm context :: InstanaContext
context threadId :: ThreadId
threadId expectedKind :: SpanKind
expectedKind = do
  Map ThreadId SpanStack
currentSpansPerThread <- TVar (Map ThreadId SpanStack) -> STM (Map ThreadId SpanStack)
forall a. TVar a -> STM a
STM.readTVar (TVar (Map ThreadId SpanStack) -> STM (Map ThreadId SpanStack))
-> TVar (Map ThreadId SpanStack) -> STM (Map ThreadId SpanStack)
forall a b. (a -> b) -> a -> b
$ InstanaContext -> TVar (Map ThreadId SpanStack)
InternalContext.currentSpans InstanaContext
context
  let
    oldStack :: Maybe SpanStack
oldStack = ThreadId -> Map ThreadId SpanStack -> Maybe SpanStack
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ThreadId
threadId Map ThreadId SpanStack
currentSpansPerThread
    (modifiedStack :: SpanStack
modifiedStack, poppedSpan :: Maybe Span
poppedSpan, warning :: Maybe String
warning) =
      case Maybe SpanStack
oldStack of
        Nothing        ->
          -- invalid state, there should be a stack with at least one span on it
          ( SpanStack
SpanStack.empty
          , Maybe Span
forall a. Maybe a
Nothing
          , String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ "Invalid state: Trying to pop the span stack while there " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                   "is no span stack for this thread yet."
          )
        Just spanStack :: SpanStack
spanStack ->
          SpanKind -> SpanStack -> (SpanStack, Maybe Span, Maybe String)
SpanStack.popWhenMatches SpanKind
expectedKind SpanStack
spanStack
    updatedSpansPerThread :: Map ThreadId SpanStack
updatedSpansPerThread =
      ThreadId
-> SpanStack -> Map ThreadId SpanStack -> Map ThreadId SpanStack
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ThreadId
threadId SpanStack
modifiedStack Map ThreadId SpanStack
currentSpansPerThread
  TVar (Map ThreadId SpanStack) -> Map ThreadId SpanStack -> STM ()
forall a. TVar a -> a -> STM ()
STM.writeTVar (InstanaContext -> TVar (Map ThreadId SpanStack)
InternalContext.currentSpans InstanaContext
context) Map ThreadId SpanStack
updatedSpansPerThread
  (Maybe Span, Maybe String) -> STM (Maybe Span, Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Span
poppedSpan, Maybe String
warning)


-- |Yields the currently active span without modifying the span stack.
peekSpan :: InstanaContext -> IO (Maybe Span)
peekSpan :: InstanaContext -> IO (Maybe Span)
peekSpan context :: InstanaContext
context = do
  Maybe (Maybe Span)
spanMaybe <- InstanaContext
-> (SpanStack -> Maybe Span) -> IO (Maybe (Maybe Span))
forall a. InstanaContext -> (SpanStack -> a) -> IO (Maybe a)
readFromSpanStack InstanaContext
context SpanStack -> Maybe Span
SpanStack.peek
  Maybe Span -> IO (Maybe Span)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Span -> IO (Maybe Span)) -> Maybe Span -> IO (Maybe Span)
forall a b. (a -> b) -> a -> b
$ Maybe (Maybe Span) -> Maybe Span
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join Maybe (Maybe Span)
spanMaybe


-- |Checks whether the SDK has a connection to an Instana agent.
isConnected :: InstanaContext -> IO Bool
isConnected :: InstanaContext -> IO Bool
isConnected =
  InstanaContext -> IO Bool
InternalContext.isAgentConnectionEstablished


-- |Provides the currently active span in a simple format fit for external use.
currentSpan :: InstanaContext -> IO (Maybe SimpleSpan)
currentSpan :: InstanaContext -> IO (Maybe SimpleSpan)
currentSpan context :: InstanaContext
context = do
  Maybe Span
span_ <- InstanaContext -> IO (Maybe Span)
peekSpan InstanaContext
context
  Maybe SimpleSpan -> IO (Maybe SimpleSpan)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SimpleSpan -> IO (Maybe SimpleSpan))
-> Maybe SimpleSpan -> IO (Maybe SimpleSpan)
forall a b. (a -> b) -> a -> b
$ Span -> SimpleSpan
SimpleSpan.convert (Span -> SimpleSpan) -> Maybe Span -> Maybe SimpleSpan
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Span
span_


-- |Retrieves the trace ID of the currently active trace in the current thread.
currentTraceId :: InstanaContext -> IO (Maybe String)
currentTraceId :: InstanaContext -> IO (Maybe String)
currentTraceId context :: InstanaContext
context = do
  Maybe Id
traceIdMaybe <- InstanaContext -> IO (Maybe Id)
currentTraceIdInternal InstanaContext
context
  Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ Id -> String
Id.toString (Id -> String) -> Maybe Id -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Id
traceIdMaybe


-- |Retrieves the trace ID of the currently active trace in the current thread.
currentTraceIdInternal :: InstanaContext -> IO (Maybe Id)
currentTraceIdInternal :: InstanaContext -> IO (Maybe Id)
currentTraceIdInternal context :: InstanaContext
context = do
  Maybe (Maybe Id)
traceIdMaybe <- InstanaContext -> (SpanStack -> Maybe Id) -> IO (Maybe (Maybe Id))
forall a. InstanaContext -> (SpanStack -> a) -> IO (Maybe a)
readFromSpanStack InstanaContext
context SpanStack -> Maybe Id
SpanStack.readTraceId
  Maybe Id -> IO (Maybe Id)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Id -> IO (Maybe Id)) -> Maybe Id -> IO (Maybe Id)
forall a b. (a -> b) -> a -> b
$ Maybe (Maybe Id) -> Maybe Id
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join Maybe (Maybe Id)
traceIdMaybe


-- |Retrieves the span ID of the currently active span in the current thread.
currentSpanId :: InstanaContext -> IO (Maybe String)
currentSpanId :: InstanaContext -> IO (Maybe String)
currentSpanId context :: InstanaContext
context = do
  Maybe Id
spanIdMaybe <- InstanaContext -> IO (Maybe Id)
currentSpanIdInternal InstanaContext
context
  Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ Id -> String
Id.toString (Id -> String) -> Maybe Id -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Id
spanIdMaybe


-- |Retrieves the span ID of the currently active span in the current thread.
currentSpanIdInternal :: InstanaContext -> IO (Maybe Id)
currentSpanIdInternal :: InstanaContext -> IO (Maybe Id)
currentSpanIdInternal context :: InstanaContext
context = do
  Maybe Span
span_ <- InstanaContext -> IO (Maybe Span)
peekSpan InstanaContext
context
  Maybe Id -> IO (Maybe Id)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Id -> IO (Maybe Id)) -> Maybe Id -> IO (Maybe Id)
forall a b. (a -> b) -> a -> b
$ Span -> Id
Span.spanId (Span -> Id) -> Maybe Span -> Maybe Id
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Span
span_


-- |Retrieves the parent ID of the currently active span in the current thread.
currentParentId :: InstanaContext -> IO (Maybe String)
currentParentId :: InstanaContext -> IO (Maybe String)
currentParentId context :: InstanaContext
context = do
  Maybe Id
parentIdMaybe <- InstanaContext -> IO (Maybe Id)
currentParentIdInternal InstanaContext
context
  Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ Id -> String
Id.toString (Id -> String) -> Maybe Id -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Id
parentIdMaybe


-- |Retrieves the parent ID of the currently active span in the current thread.
currentParentIdInternal :: InstanaContext -> IO (Maybe Id)
currentParentIdInternal :: InstanaContext -> IO (Maybe Id)
currentParentIdInternal context :: InstanaContext
context = do
  Maybe Span
span_ <- InstanaContext -> IO (Maybe Span)
peekSpan InstanaContext
context
  Maybe Id -> IO (Maybe Id)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Id -> IO (Maybe Id)) -> Maybe Id -> IO (Maybe Id)
forall a b. (a -> b) -> a -> b
$ Maybe (Maybe Id) -> Maybe Id
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe Id) -> Maybe Id) -> Maybe (Maybe Id) -> Maybe Id
forall a b. (a -> b) -> a -> b
$ Span -> Maybe Id
Span.parentId (Span -> Maybe Id) -> Maybe Span -> Maybe (Maybe Id)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Span
span_


-- |Checks if tracing is suppressed for the current thread.
isSuppressed :: InstanaContext -> IO Bool
isSuppressed :: InstanaContext -> IO Bool
isSuppressed context :: InstanaContext
context = do
  Maybe Bool
suppressedMaybe <- InstanaContext -> (SpanStack -> Bool) -> IO (Maybe Bool)
forall a. InstanaContext -> (SpanStack -> a) -> IO (Maybe a)
readFromSpanStack InstanaContext
context SpanStack -> Bool
SpanStack.isSuppressed
  Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
Maybe.fromMaybe Bool
False Maybe Bool
suppressedMaybe


-- |Retrieves the W3C trace context attached to currently active span in the
-- current thread.
currentW3cTraceContext :: InstanaContext -> IO (Maybe W3CTraceContext)
currentW3cTraceContext :: InstanaContext -> IO (Maybe W3CTraceContext)
currentW3cTraceContext context :: InstanaContext
context = do
  Maybe (Maybe W3CTraceContext)
w3cTraceContextMaybe <-
    InstanaContext
-> (SpanStack -> Maybe W3CTraceContext)
-> IO (Maybe (Maybe W3CTraceContext))
forall a. InstanaContext -> (SpanStack -> a) -> IO (Maybe a)
readFromSpanStack InstanaContext
context SpanStack -> Maybe W3CTraceContext
SpanStack.readW3cTraceContext
  Maybe W3CTraceContext -> IO (Maybe W3CTraceContext)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe W3CTraceContext -> IO (Maybe W3CTraceContext))
-> Maybe W3CTraceContext -> IO (Maybe W3CTraceContext)
forall a b. (a -> b) -> a -> b
$ Maybe (Maybe W3CTraceContext) -> Maybe W3CTraceContext
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join Maybe (Maybe W3CTraceContext)
w3cTraceContextMaybe


-- |Reads a value from the currently active span stack.
readFromSpanStack :: InstanaContext -> (SpanStack -> a) -> IO (Maybe a)
readFromSpanStack :: InstanaContext -> (SpanStack -> a) -> IO (Maybe a)
readFromSpanStack context :: InstanaContext
context accessor :: SpanStack -> a
accessor = do
  ThreadId
threadId <- IO ThreadId
Concurrent.myThreadId
  STM (Maybe a) -> IO (Maybe a)
forall a. STM a -> IO a
STM.atomically (STM (Maybe a) -> IO (Maybe a)) -> STM (Maybe a) -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ InstanaContext -> ThreadId -> (SpanStack -> a) -> STM (Maybe a)
forall a.
InstanaContext -> ThreadId -> (SpanStack -> a) -> STM (Maybe a)
readFromSpanStackStm InstanaContext
context ThreadId
threadId SpanStack -> a
accessor


-- |Reads a value from the currently active span stack in the given thread.
readFromSpanStackStm ::
  InstanaContext
  -> ThreadId
  -> (SpanStack -> a)
  -> STM (Maybe a)
readFromSpanStackStm :: InstanaContext -> ThreadId -> (SpanStack -> a) -> STM (Maybe a)
readFromSpanStackStm context :: InstanaContext
context threadId :: ThreadId
threadId accessor :: SpanStack -> a
accessor = do
  Map ThreadId SpanStack
currentSpansPerThread <- TVar (Map ThreadId SpanStack) -> STM (Map ThreadId SpanStack)
forall a. TVar a -> STM a
STM.readTVar (TVar (Map ThreadId SpanStack) -> STM (Map ThreadId SpanStack))
-> TVar (Map ThreadId SpanStack) -> STM (Map ThreadId SpanStack)
forall a b. (a -> b) -> a -> b
$ InstanaContext -> TVar (Map ThreadId SpanStack)
InternalContext.currentSpans InstanaContext
context
  let
    maybeStack :: Maybe SpanStack
maybeStack = ThreadId -> Map ThreadId SpanStack -> Maybe SpanStack
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ThreadId
threadId Map ThreadId SpanStack
currentSpansPerThread
  case Maybe SpanStack
maybeStack of
    Nothing ->
      Maybe a -> STM (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
    Just stack :: SpanStack
stack ->
      Maybe a -> STM (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> STM (Maybe a)) -> Maybe a -> STM (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> a -> Maybe a
forall a b. (a -> b) -> a -> b
$ SpanStack -> a
accessor SpanStack
stack


-- |Applies the given function to the currently active span, replacing it in
-- place with the result of the given function.
modifyCurrentSpan ::
  InstanaContext
  -> (Span -> Span)
  -> IO ()
modifyCurrentSpan :: InstanaContext -> (Span -> Span) -> IO ()
modifyCurrentSpan context :: InstanaContext
context fn :: Span -> Span
fn = do
  ThreadId
threadId <- IO ThreadId
Concurrent.myThreadId
  STM () -> IO ()
forall a. STM a -> IO a
STM.atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$
    TVar (Map ThreadId SpanStack)
-> (Map ThreadId SpanStack -> Map ThreadId SpanStack) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
STM.modifyTVar' (InstanaContext -> TVar (Map ThreadId SpanStack)
InternalContext.currentSpans InstanaContext
context)
      (\currentSpansPerThread :: Map ThreadId SpanStack
currentSpansPerThread ->
        let
          stack :: Maybe SpanStack
stack = ThreadId -> Map ThreadId SpanStack -> Maybe SpanStack
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ThreadId
threadId Map ThreadId SpanStack
currentSpansPerThread
          modifiedStack :: SpanStack
modifiedStack = (Span -> Span) -> Maybe SpanStack -> SpanStack
mapCurrentSpan Span -> Span
fn Maybe SpanStack
stack
        in
        ThreadId
-> SpanStack -> Map ThreadId SpanStack -> Map ThreadId SpanStack
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ThreadId
threadId SpanStack
modifiedStack Map ThreadId SpanStack
currentSpansPerThread
      )


-- |Applies the given function to the top item on the given span stack.
mapCurrentSpan :: (Span -> Span) -> Maybe SpanStack -> SpanStack
mapCurrentSpan :: (Span -> Span) -> Maybe SpanStack -> SpanStack
mapCurrentSpan fn :: Span -> Span
fn stack :: Maybe SpanStack
stack =
  SpanStack -> Maybe SpanStack -> SpanStack
forall a. a -> Maybe a -> a
Maybe.fromMaybe
    SpanStack
SpanStack.empty
    (((Span -> Span) -> SpanStack -> SpanStack
SpanStack.mapTop Span -> Span
fn) (SpanStack -> SpanStack) -> Maybe SpanStack -> Maybe SpanStack
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe SpanStack
stack)


-- |Applies the given function to the currently active entry span, even if the
-- currently active span is an exit child of that entry span. The entry span
-- will be replaced with the result of the given function.
modifyCurrentEntrySpan ::
  InstanaContext
  -> (Span -> Span)
  -> IO ()
modifyCurrentEntrySpan :: InstanaContext -> (Span -> Span) -> IO ()
modifyCurrentEntrySpan context :: InstanaContext
context fn :: Span -> Span
fn = do
  ThreadId
threadId <- IO ThreadId
Concurrent.myThreadId
  STM () -> IO ()
forall a. STM a -> IO a
STM.atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$
    TVar (Map ThreadId SpanStack)
-> (Map ThreadId SpanStack -> Map ThreadId SpanStack) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
STM.modifyTVar' (InstanaContext -> TVar (Map ThreadId SpanStack)
InternalContext.currentSpans InstanaContext
context)
      (\currentSpansPerThread :: Map ThreadId SpanStack
currentSpansPerThread ->
        let
          stack :: Maybe SpanStack
stack = ThreadId -> Map ThreadId SpanStack -> Maybe SpanStack
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ThreadId
threadId Map ThreadId SpanStack
currentSpansPerThread
          modifiedStack :: SpanStack
modifiedStack = (Span -> Span) -> Maybe SpanStack -> SpanStack
mapCurrentEntrySpan Span -> Span
fn Maybe SpanStack
stack
        in
        ThreadId
-> SpanStack -> Map ThreadId SpanStack -> Map ThreadId SpanStack
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ThreadId
threadId SpanStack
modifiedStack Map ThreadId SpanStack
currentSpansPerThread
      )


-- |Applies the given function to the entry span (if present) on the given span
-- stack, even if there is already an exit span on top of it.
mapCurrentEntrySpan :: (Span -> Span) -> Maybe SpanStack -> SpanStack
mapCurrentEntrySpan :: (Span -> Span) -> Maybe SpanStack -> SpanStack
mapCurrentEntrySpan fn :: Span -> Span
fn stack :: Maybe SpanStack
stack =
  SpanStack -> Maybe SpanStack -> SpanStack
forall a. a -> Maybe a -> a
Maybe.fromMaybe
    SpanStack
SpanStack.empty
    (((Span -> Span) -> SpanStack -> SpanStack
SpanStack.mapEntry Span -> Span
fn) (SpanStack -> SpanStack) -> Maybe SpanStack -> Maybe SpanStack
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe SpanStack
stack)