module Freckle.App.OpenTelemetry
( HasTracer (..)
, Tracer
, MonadTracer (..)
, inSpan
, defaultSpanArguments
, serverSpanArguments
, clientSpanArguments
, producerSpanArguments
, consumerSpanArguments
, withTraceIdContext
, getCurrentTraceId
, getCurrentTraceIdAsDatadog
, getCurrentSpanContext
, withTracerProvider
, makeTracer
, tracerOptions
, byteStringToAttribute
, attributeValueLimit
) where
import Freckle.App.Prelude
import Blammo.Logging (withThreadContext, (.=))
import Control.Monad.Catch (MonadMask)
import Data.ByteString (ByteString)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
import Data.Word (Word64)
import OpenTelemetry.Context (lookupSpan)
import OpenTelemetry.Context.ThreadLocal (getContext)
import OpenTelemetry.Propagator.Datadog
( convertOpenTelemetryTraceIdToDatadogTraceId
)
import OpenTelemetry.Trace hiding (inSpan)
import OpenTelemetry.Trace.Core (getSpanContext)
import qualified OpenTelemetry.Trace.Core as Trace (SpanContext (..))
import OpenTelemetry.Trace.Id (TraceId)
import OpenTelemetry.Trace.Monad
import UnliftIO.Exception (bracket)
serverSpanArguments :: SpanArguments
serverSpanArguments :: SpanArguments
serverSpanArguments = SpanArguments
defaultSpanArguments {kind :: SpanKind
kind = SpanKind
Server}
clientSpanArguments :: SpanArguments
clientSpanArguments :: SpanArguments
clientSpanArguments = SpanArguments
defaultSpanArguments {kind :: SpanKind
kind = SpanKind
Client}
producerSpanArguments :: SpanArguments
producerSpanArguments :: SpanArguments
producerSpanArguments = SpanArguments
defaultSpanArguments {kind :: SpanKind
kind = SpanKind
Producer}
consumerSpanArguments :: SpanArguments
consumerSpanArguments :: SpanArguments
consumerSpanArguments = SpanArguments
defaultSpanArguments {kind :: SpanKind
kind = SpanKind
Consumer}
withTracerProvider :: MonadUnliftIO m => (TracerProvider -> m a) -> m a
withTracerProvider :: forall (m :: * -> *) a.
MonadUnliftIO m =>
(TracerProvider -> m a) -> m a
withTracerProvider =
m TracerProvider
-> (TracerProvider -> m ()) -> (TracerProvider -> m a) -> m a
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket
(IO TracerProvider -> m TracerProvider
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO TracerProvider
initializeGlobalTracerProvider)
(IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ())
-> (TracerProvider -> IO ()) -> TracerProvider -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TracerProvider -> IO ()
forall (m :: * -> *). MonadIO m => TracerProvider -> m ()
shutdownTracerProvider)
getCurrentTraceId :: MonadIO m => m (Maybe TraceId)
getCurrentTraceId :: forall (m :: * -> *). MonadIO m => m (Maybe TraceId)
getCurrentTraceId = (SpanContext -> TraceId) -> Maybe SpanContext -> Maybe TraceId
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SpanContext -> TraceId
Trace.traceId (Maybe SpanContext -> Maybe TraceId)
-> m (Maybe SpanContext) -> m (Maybe TraceId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Maybe SpanContext)
forall (m :: * -> *). MonadIO m => m (Maybe SpanContext)
getCurrentSpanContext
getCurrentTraceIdAsDatadog :: MonadIO m => m (Maybe Word64)
getCurrentTraceIdAsDatadog :: forall (m :: * -> *). MonadIO m => m (Maybe Word64)
getCurrentTraceIdAsDatadog =
(TraceId -> Word64) -> Maybe TraceId -> Maybe Word64
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TraceId -> Word64
convertOpenTelemetryTraceIdToDatadogTraceId (Maybe TraceId -> Maybe Word64)
-> m (Maybe TraceId) -> m (Maybe Word64)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Maybe TraceId)
forall (m :: * -> *). MonadIO m => m (Maybe TraceId)
getCurrentTraceId
getCurrentSpanContext :: MonadIO m => m (Maybe SpanContext)
getCurrentSpanContext :: forall (m :: * -> *). MonadIO m => m (Maybe SpanContext)
getCurrentSpanContext = do
Maybe Span
mSpan <- Context -> Maybe Span
lookupSpan (Context -> Maybe Span) -> m Context -> m (Maybe Span)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Context
forall (m :: * -> *). MonadIO m => m Context
getContext
(Span -> m SpanContext) -> Maybe Span -> m (Maybe SpanContext)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse Span -> m SpanContext
forall (m :: * -> *). MonadIO m => Span -> m SpanContext
getSpanContext Maybe Span
mSpan
withTraceIdContext :: (MonadIO m, MonadMask m) => m a -> m a
withTraceIdContext :: forall (m :: * -> *) a. (MonadIO m, MonadMask m) => m a -> m a
withTraceIdContext m a
f = do
Maybe Word64
mTraceId <- m (Maybe Word64)
forall (m :: * -> *). MonadIO m => m (Maybe Word64)
getCurrentTraceIdAsDatadog
m a -> (Word64 -> m a) -> Maybe Word64 -> m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m a
f (\Word64
traceId -> [Pair] -> m a -> m a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
[Pair] -> m a -> m a
withThreadContext [Key
"trace_id" Key -> Word64 -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Word64
traceId] m a
f) Maybe Word64
mTraceId
byteStringToAttribute :: ByteString -> Attribute
byteStringToAttribute :: ByteString -> Attribute
byteStringToAttribute =
Text -> Attribute
forall a. ToAttribute a => a -> Attribute
toAttribute
(Text -> Attribute)
-> (ByteString -> Text) -> ByteString -> Attribute
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text -> Text
truncateText Int
attributeValueLimit
(Text -> Text) -> (ByteString -> Text) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode
attributeValueLimit :: Int
attributeValueLimit :: Int
attributeValueLimit = Int
4095
truncateText :: Int -> Text -> Text
truncateText :: Int -> Text -> Text
truncateText Int
l Text
t
| Text -> Int
T.length Text
t Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
l = Text
t
| Bool
otherwise = Int -> Text -> Text
T.take (Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
3) Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"..."