{-# LANGUAGE OverloadedStrings #-}
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
type InstanaContext = InternalContext
httpServerSpan :: SpanType
httpServerSpan :: SpanType
httpServerSpan = RegisteredSpanType -> SpanType
RegisteredSpan RegisteredSpanType
SpanType.HaskellWaiServer
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
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
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
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
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 :: 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
}
InstanaContext -> IO ()
Worker.spawnWorker InstanaContext
context
InstanaContext -> IO InstanaContext
forall (m :: * -> *) a. Monad m => a -> m a
return InstanaContext
context
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
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
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
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
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
withHttpEntryContinueFromInstanaHeaders ::
MonadIO m
=> InstanaContext
-> String
-> String
-> m a
-> m a
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
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)
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
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
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
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
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 ->
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)
)
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
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 ->
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 ()
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 ())
startHttpEntryContinueFromInstanaHeaders ::
MonadIO m
=> InstanaContext
-> String
-> String
-> m a
-> m a
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
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)
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
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
data HttpTracingHandlers m a = HttpTracingHandlers
{ ::
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
}
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
(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
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'
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 ->
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)]
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]
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
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 ()
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
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
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
)
captureResponseHeaders ::
MonadIO m =>
InstanaContext
-> Wai.Response
-> m ()
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
captureResponseHeadersUnlifted ::
InstanaContext
-> Wai.Response
-> IO ()
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
)
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
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
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 ->
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 ()
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
{ 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
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)
Text -> (Text -> [Text]) -> [Text]
forall a b. a -> (a -> b) -> b
|> Text -> Text -> [Text]
T.splitOn "&"
[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)
[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 "=")
[(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
)
[(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
)
[(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])
[Text] -> ([Text] -> Text) -> Text
forall a b. a -> (a -> b) -> b
|> Text -> [Text] -> Text
T.intercalate "&"
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)
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 ()
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 ()
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
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_)
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_)
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_)
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_)
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 ()
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_)
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_)
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_)
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_)
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_)
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_)
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_)
addHttpTracingHeaders ::
MonadIO m =>
InstanaContext
-> HTTP.Request
-> m HTTP.Request
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]
w3cTraceContext :: Maybe W3CTraceContext
w3cTraceContext =
case Maybe W3CTraceContext
w3cTraceContext of
Just w3cCtx :: W3CTraceContext
w3cCtx -> W3CTraceContext -> [Header]
W3CTraceContext.toHeaders W3CTraceContext
w3cCtx
Nothing -> []
enqueueCommand :: InstanaContext -> Command -> IO ()
enqueueCommand :: InstanaContext -> Command -> IO ()
enqueueCommand context :: InstanaContext
context command :: Command
command = do
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
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
)
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
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 ->
( 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)
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
isConnected :: InstanaContext -> IO Bool
isConnected :: InstanaContext -> IO Bool
isConnected =
InstanaContext -> IO Bool
InternalContext.isAgentConnectionEstablished
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_
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
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
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
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_
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
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_
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
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
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
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
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
)
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)
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
)
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)