{-# LANGUAGE OverloadedStrings #-}
module Instana.SDK.SDK
( Config
, InstanaContext
, addRegisteredData
, addRegisteredDataAt
, addHttpTracingHeaders
, addTag
, addTagAt
, addToErrorCount
, agentHost
, agentPort
, completeEntry
, completeExit
, defaultConfig
, forceTransmissionAfter
, forceTransmissionStartingAt
, incrementErrorCount
, initConfiguredInstana
, initInstana
, maxBufferedSpans
, readHttpTracingHeaders
, serviceName
, setServiceName
, startEntry
, startExit
, startHttpEntry
, startHttpExit
, startRootEntry
, withConfiguredInstana
, withEntry
, withExit
, 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.IO.Class (MonadIO, liftIO)
import Data.Aeson (Value, (.=))
import qualified Data.Aeson as Aeson
import qualified Data.ByteString.Char8 as BSC8
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 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 Instana.SDK.Internal.SpanStack (SpanStack)
import qualified Instana.SDK.Internal.SpanStack as SpanStack
import Instana.SDK.Internal.Util ((|>))
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.Span (Span (..), SpanKind (..))
import qualified Instana.SDK.Span.Span as Span
import Instana.SDK.Span.SpanType (SpanType (RegisteredSpan))
import qualified Instana.SDK.Span.SpanType as SpanType
import Instana.SDK.TracingHeaders (TracingHeaders (TracingHeaders))
import qualified Instana.SDK.TracingHeaders as TracingHeaders
type InstanaContext = InternalContext
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.unsafeFdSocket 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
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 = do
let
spanType :: SpanType
spanType = (Registered -> SpanType
RegisteredSpan Registered
SpanType.HaskellWaiServer)
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
case TracingLevel
level of
TracingHeaders.Trace -> do
let
io' :: m a
io' = InstanaContext -> Request -> m a -> m a
forall (m :: * -> *) a.
MonadIO m =>
InstanaContext -> Request -> m a -> m a
addDataFromRequest InstanaContext
context Request
request m a
io
case (Maybe String
traceId, Maybe String
spanId) of
(Just t :: String
t, Just s :: String
s) ->
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
spanType m a
io'
_ ->
InstanaContext -> SpanType -> m a -> m a
forall (m :: * -> *) a.
MonadIO m =>
InstanaContext -> SpanType -> m a -> m a
withRootEntry InstanaContext
context SpanType
spanType m a
io'
TracingHeaders.Suppress -> 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 -> (Maybe SpanStack -> SpanStack) -> IO ()
pushSpan
InstanaContext
context
(\stack :: Maybe SpanStack
stack ->
case Maybe SpanStack
stack of
Nothing ->
SpanStack
SpanStack.suppress
Just spanStack :: SpanStack
spanStack ->
SpanStack -> SpanStack
SpanStack.pushSuppress SpanStack
spanStack
)
m a
io
addDataFromRequest :: MonadIO m => InstanaContext -> Wai.Request -> m a -> m a
addDataFromRequest :: InstanaContext -> Request -> m a -> m a
addDataFromRequest context :: InstanaContext
context request :: Request
request originalIO :: m a
originalIO =
m a
originalIO m a -> (a -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= InstanaContext -> Request -> a -> m a
forall (m :: * -> *) a.
MonadIO m =>
InstanaContext -> Request -> a -> m a
addHttpDataInIO InstanaContext
context Request
request
addHttpDataInIO :: MonadIO m => InstanaContext -> Wai.Request -> a -> m a
addHttpDataInIO :: InstanaContext -> Request -> a -> m a
addHttpDataInIO context :: InstanaContext
context request :: Request
request ioResult :: a
ioResult = do
InstanaContext -> Request -> m ()
forall (m :: * -> *).
MonadIO m =>
InstanaContext -> Request -> m ()
addHttpData InstanaContext
context Request
request
a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
ioResult
addHttpData :: MonadIO m => InstanaContext -> Wai.Request -> m ()
addHttpData :: InstanaContext -> Request -> m ()
addHttpData context :: InstanaContext
context request :: Request
request = do
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 ""
InstanaContext -> Value -> m ()
forall (m :: * -> *). MonadIO m => InstanaContext -> Value -> m ()
addRegisteredData
InstanaContext
context
([Pair] -> Value
Aeson.object [ "http" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.=
[Pair] -> Value
Aeson.object
[ "method" Text -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Request -> ByteString
Wai.requestMethod Request
request ByteString -> (ByteString -> String) -> String
forall a b. a -> (a -> b) -> b
|> ByteString -> String
BSC8.unpack
, "url" Text -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Request -> ByteString
Wai.rawPathInfo Request
request ByteString -> (ByteString -> String) -> String
forall a b. a -> (a -> b) -> b
|> ByteString -> String
BSC8.unpack
, "host" Text -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= String
host
, "params" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (ByteString -> Text
processQueryString (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
Wai.rawQueryString Request
request)
]
]
)
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 -> Text -> Int -> Int -> Maybe Text -> Value -> RootEntry
RootEntry
{ spanAndTraceId :: Id
RootEntry.spanAndTraceId = Id
traceId
, spanName :: Text
RootEntry.spanName = SpanType -> Text
SpanType.spanName 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
, spanData :: Value
RootEntry.spanData = SpanKind -> SpanType -> Value
SpanType.initialData SpanKind
EntryKind SpanType
spanType
}
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
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
-> Text
-> Int
-> Int
-> Maybe Text
-> Value
-> NonRootEntry
NonRootEntry
{ traceId :: Id
NonRootEntry.traceId = String -> Id
Id.fromString String
traceId
, spanId :: Id
NonRootEntry.spanId = Id
spanId
, parentId :: Id
NonRootEntry.parentId = String -> Id
Id.fromString String
parentId
, spanName :: Text
NonRootEntry.spanName = SpanType -> Text
SpanType.spanName 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
, spanData :: Value
NonRootEntry.spanData = SpanKind -> SpanType -> Value
SpanType.initialData SpanKind
EntryKind SpanType
spanType
}
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
let
spanType :: SpanType
spanType = (Registered -> SpanType
RegisteredSpan Registered
SpanType.HaskellWaiServer)
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
case TracingLevel
level of
TracingHeaders.Trace ->
case (Maybe String
traceId, Maybe String
spanId) of
(Just t :: String
t, Just s :: String
s) -> do
InstanaContext -> String -> String -> SpanType -> m ()
forall (m :: * -> *).
MonadIO m =>
InstanaContext -> String -> String -> SpanType -> m ()
startEntry InstanaContext
context String
t String
s SpanType
spanType
InstanaContext -> Request -> m ()
forall (m :: * -> *).
MonadIO m =>
InstanaContext -> Request -> m ()
addHttpData InstanaContext
context Request
request
_ -> do
InstanaContext -> SpanType -> m ()
forall (m :: * -> *).
MonadIO m =>
InstanaContext -> SpanType -> m ()
startRootEntry InstanaContext
context SpanType
spanType
InstanaContext -> Request -> m ()
forall (m :: * -> *).
MonadIO m =>
InstanaContext -> Request -> m ()
addHttpData InstanaContext
context Request
request
TracingHeaders.Suppress -> 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 -> (Maybe SpanStack -> SpanStack) -> IO ()
pushSpan
InstanaContext
context
(\stack :: Maybe SpanStack
stack ->
case Maybe SpanStack
stack of
Nothing ->
SpanStack
SpanStack.suppress
Just spanStack :: SpanStack
spanStack ->
SpanStack -> SpanStack
SpanStack.pushSuppress SpanStack
spanStack
)
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
newSpan :: ExitSpan
newSpan =
ExitSpan :: EntrySpan
-> Id -> Text -> Int -> Maybe Text -> Int -> Value -> ExitSpan
ExitSpan
{ parentSpan :: EntrySpan
ExitSpan.parentSpan = EntrySpan
parent
, spanId :: Id
ExitSpan.spanId = Id
spanId
, spanName :: Text
ExitSpan.spanName = SpanType -> Text
SpanType.spanName 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 :: Value
ExitSpan.spanData = SpanKind -> SpanType -> Value
SpanType.initialData SpanKind
ExitKind SpanType
spanType
}
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
Request
request' <- InstanaContext -> Request -> m Request
forall (m :: * -> *).
MonadIO m =>
InstanaContext -> Request -> m Request
addHttpTracingHeaders InstanaContext
context Request
request
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
InstanaContext -> Value -> IO ()
forall (m :: * -> *). MonadIO m => InstanaContext -> Value -> m ()
addRegisteredData InstanaContext
context
([Pair] -> Value
Aeson.object [ "http" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.=
[Pair] -> Value
Aeson.object
[ "status" Text -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Int
status
]
]
)
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
InstanaContext -> SpanType -> m ()
forall (m :: * -> *).
MonadIO m =>
InstanaContext -> SpanType -> m ()
startExit InstanaContext
context (Registered -> SpanType
RegisteredSpan Registered
SpanType.HaskellHttpClient)
InstanaContext -> Value -> m ()
forall (m :: * -> *). MonadIO m => InstanaContext -> Value -> m ()
addRegisteredData
InstanaContext
context
([Pair] -> Value
Aeson.object [ "http" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.=
[Pair] -> Value
Aeson.object
[ "method" Text -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (ByteString -> String
BSC8.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
HTTP.method Request
request)
, "url" Text -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= String
url
, "params" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (ByteString -> Text
processQueryString (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
HTTP.queryString Request
request)
]
]
)
Request -> m Request
forall (m :: * -> *) a. Monad m => a -> m a
return Request
request''
processQueryString :: BSC8.ByteString -> Text
processQueryString :: ByteString -> Text
processQueryString queryString :: ByteString
queryString =
let
matcher :: SecretsMatcher
matcher = SecretsMatcher
Secrets.defaultSecretsMatcher
in
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 -> [Text]) -> [Text] -> [[Text]]
forall a b. (a -> b) -> [a] -> [b]
List.map (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
(\pair :: [Text]
pair ->
[Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
List.length [Text]
pair Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 2 Bool -> Bool -> Bool
&&
(Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SecretsMatcher -> Text -> Bool
Secrets.isSecret SecretsMatcher
matcher) ([Text] -> Text
forall a. [a] -> a
List.head [Text]
pair)
)
[[Text]] -> ([[Text]] -> [Text]) -> [Text]
forall a b. a -> (a -> b) -> b
|> ([Text] -> Text) -> [[Text]] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
List.map (Text -> [Text] -> Text
T.intercalate "=")
[Text] -> ([Text] -> Text) -> Text
forall a b. a -> (a -> b) -> b
|> Text -> [Text] -> Text
T.intercalate "&"
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_)
addTagAt :: (MonadIO m, Aeson.ToJSON a) => InstanaContext -> Text -> a -> m ()
addTagAt :: InstanaContext -> Text -> a -> m ()
addTagAt 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.addTagAt Text
path a
value Span
span_)
addTag :: MonadIO m => InstanaContext -> Value -> m ()
addTag :: InstanaContext -> Value -> m ()
addTag context :: InstanaContext
context value :: Value
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_ -> Value -> Span -> Span
Span.addTag Value
value Span
span_)
addRegisteredDataAt ::
(MonadIO m, Aeson.ToJSON a) =>
InstanaContext
-> Text
-> a
-> m ()
addRegisteredDataAt :: InstanaContext -> Text -> a -> m ()
addRegisteredDataAt 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.addRegisteredDataAt Text
path a
value Span
span_)
addRegisteredData :: MonadIO m => InstanaContext -> Value -> m ()
addRegisteredData :: InstanaContext -> Value -> m ()
addRegisteredData context :: InstanaContext
context value :: Value
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_ -> Value -> Span -> Span
Span.addRegisteredData Value
value Span
span_)
readHttpTracingHeaders :: Wai.Request -> TracingHeaders
request :: Request
request =
let
headers :: RequestHeaders
headers = Request -> RequestHeaders
Wai.requestHeaders Request
request
traceId :: Maybe String
traceId =
RequestHeaders
headers
RequestHeaders
-> (RequestHeaders -> Maybe ByteString) -> Maybe ByteString
forall a b. a -> (a -> b) -> b
|> HeaderName -> RequestHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
List.lookup HeaderName
TracingHeaders.traceIdHeaderName
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
(<$>) ByteString -> String
BSC8.unpack
spanId :: Maybe String
spanId =
RequestHeaders
headers
RequestHeaders
-> (RequestHeaders -> Maybe ByteString) -> Maybe ByteString
forall a b. a -> (a -> b) -> b
|> HeaderName -> RequestHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
List.lookup HeaderName
TracingHeaders.spanIdHeaderName
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
(<$>) ByteString -> String
BSC8.unpack
level :: Maybe String
level =
RequestHeaders
headers
RequestHeaders
-> (RequestHeaders -> Maybe ByteString) -> Maybe ByteString
forall a b. a -> (a -> b) -> b
|> HeaderName -> RequestHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
List.lookup HeaderName
TracingHeaders.levelHeaderName
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
(<$>) ByteString -> String
BSC8.unpack
in
TracingHeaders :: Maybe String -> Maybe String -> TracingLevel -> TracingHeaders
TracingHeaders
{ traceId :: Maybe String
TracingHeaders.traceId = Maybe String
traceId
, spanId :: Maybe String
TracingHeaders.spanId = Maybe String
spanId
, level :: TracingLevel
TracingHeaders.level = Maybe String -> TracingLevel
TracingHeaders.maybeStringToTracingLevel Maybe String
level
}
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 Span
entrySpan <- InstanaContext -> IO (Maybe Span)
peekSpan InstanaContext
context
let
originalHeaders :: RequestHeaders
originalHeaders = Request -> RequestHeaders
HTTP.requestHeaders Request
request
updatedRequest :: Request
updatedRequest =
case (Maybe Span
entrySpan, Bool
suppressed) of
(_, True) ->
Request
request {
requestHeaders :: RequestHeaders
HTTP.requestHeaders =
((HeaderName
TracingHeaders.levelHeaderName, "0") (HeaderName, ByteString) -> RequestHeaders -> RequestHeaders
forall a. a -> [a] -> [a]
: RequestHeaders
originalHeaders)
}
(Just (Entry currentEntrySpan :: EntrySpan
currentEntrySpan), _) ->
Request
request {
requestHeaders :: RequestHeaders
HTTP.requestHeaders =
(RequestHeaders
originalHeaders RequestHeaders -> RequestHeaders -> RequestHeaders
forall a. [a] -> [a] -> [a]
++
[ (HeaderName
TracingHeaders.traceIdHeaderName, Id -> ByteString
Id.toByteString (Id -> ByteString) -> Id -> ByteString
forall a b. (a -> b) -> a -> b
$
EntrySpan -> Id
EntrySpan.traceId EntrySpan
currentEntrySpan)
, (HeaderName
TracingHeaders.spanIdHeaderName, Id -> ByteString
Id.toByteString (Id -> ByteString) -> Id -> ByteString
forall a b. (a -> b) -> a -> b
$
EntrySpan -> Id
EntrySpan.spanId EntrySpan
currentEntrySpan)
]
)
}
_ ->
Request
request
Request -> IO Request
forall (m :: * -> *) a. Monad m => a -> m a
return Request
updatedRequest
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
ThreadId
threadId <- IO ThreadId
Concurrent.myThreadId
STM (Maybe Span) -> IO (Maybe Span)
forall a. STM a -> IO a
STM.atomically (STM (Maybe Span) -> IO (Maybe Span))
-> STM (Maybe Span) -> IO (Maybe Span)
forall a b. (a -> b) -> a -> b
$ InstanaContext -> ThreadId -> STM (Maybe Span)
peekSpanStm InstanaContext
context ThreadId
threadId
peekSpanStm :: InstanaContext -> ThreadId -> STM (Maybe Span)
peekSpanStm :: InstanaContext -> ThreadId -> STM (Maybe Span)
peekSpanStm context :: InstanaContext
context threadId :: ThreadId
threadId = 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
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
case Maybe SpanStack
stack of
Nothing ->
Maybe Span -> STM (Maybe Span)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Span
forall a. Maybe a
Nothing
Just s :: SpanStack
s ->
Maybe Span -> STM (Maybe Span)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Span -> STM (Maybe Span)) -> Maybe Span -> STM (Maybe Span)
forall a b. (a -> b) -> a -> b
$ SpanStack -> Maybe Span
SpanStack.peek SpanStack
s
isSuppressed :: InstanaContext -> IO Bool
isSuppressed :: InstanaContext -> IO Bool
isSuppressed context :: InstanaContext
context = do
ThreadId
threadId <- IO ThreadId
Concurrent.myThreadId
STM Bool -> IO Bool
forall a. STM a -> IO a
STM.atomically (STM Bool -> IO Bool) -> STM Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ InstanaContext -> ThreadId -> STM Bool
isSuppressedStm InstanaContext
context ThreadId
threadId
isSuppressedStm :: InstanaContext -> ThreadId -> STM Bool
isSuppressedStm :: InstanaContext -> ThreadId -> STM Bool
isSuppressedStm context :: InstanaContext
context threadId :: ThreadId
threadId = 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
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
case Maybe SpanStack
stack of
Nothing ->
Bool -> STM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
Just s :: SpanStack
s ->
Bool -> STM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> STM Bool) -> Bool -> STM Bool
forall a b. (a -> b) -> a -> b
$ SpanStack -> Bool
SpanStack.isSuppressed SpanStack
s
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)