{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
module AutoInstrument.Internal.Types
  ( AutoInstrument(..)
  ) where

import qualified Data.Text as T
import           UnliftIO

import qualified OpenTelemetry.Propagator as Otel
import qualified OpenTelemetry.Trace.Core as Otel

class AutoInstrument a where
  autoInstrument
    :: String -- function name
    -> String -- module name
    -> String -- file path
    -> String -- line number
    -> String -- package name
    -> a -> a

instance {-# INCOHERENT #-} AutoInstrument b => AutoInstrument (a -> b) where
  autoInstrument :: String
-> String -> String -> String -> String -> (a -> b) -> a -> b
autoInstrument String
funName String
modName String
filePath String
lineNum String
pkgName a -> b
f =
    String -> String -> String -> String -> String -> b -> b
forall a.
AutoInstrument a =>
String -> String -> String -> String -> String -> a -> a
autoInstrument String
funName String
modName String
filePath String
lineNum String
pkgName (b -> b) -> (a -> b) -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f

instance MonadUnliftIO m
    => AutoInstrument (m a) where
  autoInstrument :: String -> String -> String -> String -> String -> m a -> m a
autoInstrument String
funName String
modName String
filePath String
lineNum String
pkgName m a
body = do
    TracerProvider
tp <- m TracerProvider
forall (m :: * -> *). MonadIO m => m TracerProvider
Otel.getGlobalTracerProvider
    -- If the global tracer provider hasn't been initialized then there will
    -- be no propagators. Don't create a span if this is the case because if
    -- the function that initializes the tracer provider gets auto instrumented
    -- then its span will not emit traces and nor will its child spans.
    if [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Text] -> Bool) -> [Text] -> Bool
forall a b. (a -> b) -> a -> b
$ Propagator Context RequestHeaders RequestHeaders -> [Text]
forall context inboundCarrier outboundCarrier.
Propagator context inboundCarrier outboundCarrier -> [Text]
Otel.propagatorNames (TracerProvider -> Propagator Context RequestHeaders RequestHeaders
Otel.getTracerProviderPropagators TracerProvider
tp)
    then m a
body -- no providers - don't create a span
    else
      -- TODO store this in a global var as an optimization? might not want to
      -- since the global tracer provider can potentially change.
      let tracer :: Tracer
tracer = TracerProvider -> InstrumentationLibrary -> TracerOptions -> Tracer
Otel.makeTracer TracerProvider
tp InstrumentationLibrary
"hs-opentelemetry-instrumentation-auto" TracerOptions
Otel.tracerOptions

          attrs :: HashMap Text Attribute
attrs =
            [ (String -> Text
T.pack String
"code.function", Text -> Attribute
forall a. ToAttribute a => a -> Attribute
Otel.toAttribute (Text -> Attribute) -> Text -> Attribute
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
funName)
            , (String -> Text
T.pack String
"code.namespace", Text -> Attribute
forall a. ToAttribute a => a -> Attribute
Otel.toAttribute (Text -> Attribute) -> Text -> Attribute
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
modName)
            , (String -> Text
T.pack String
"code.filepath", Text -> Attribute
forall a. ToAttribute a => a -> Attribute
Otel.toAttribute (Text -> Attribute) -> Text -> Attribute
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
filePath)
            , (String -> Text
T.pack String
"code.lineno", Text -> Attribute
forall a. ToAttribute a => a -> Attribute
Otel.toAttribute (Text -> Attribute) -> Text -> Attribute
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
lineNum)
            , (String -> Text
T.pack String
"code.package", Text -> Attribute
forall a. ToAttribute a => a -> Attribute
Otel.toAttribute (Text -> Attribute) -> Text -> Attribute
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
pkgName)
            ]
#if MIN_VERSION_hs_opentelemetry_api(0,1,0)
          spanArgs :: SpanArguments
spanArgs = HashMap Text Attribute -> SpanArguments -> SpanArguments
Otel.addAttributesToSpanArguments HashMap Text Attribute
attrs SpanArguments
Otel.defaultSpanArguments
       in Tracer -> Text -> SpanArguments -> m a -> m a
forall (m :: * -> *) a.
(MonadUnliftIO m, HasCallStack) =>
Tracer -> Text -> SpanArguments -> m a -> m a
Otel.inSpan Tracer
tracer (String -> Text
T.pack String
funName) SpanArguments
spanArgs m a
body
#else
          spanArgs = Otel.defaultSpanArguments { Otel.attributes = attrs }
       in Otel.inSpan'' tracer [] (T.pack funName) spanArgs (const body)
#endif