{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

-----------------------------------------------------------------------------

-----------------------------------------------------------------------------

{- |
 Module      :  OpenTelemetry.Exporter.OTLP
 Copyright   :  (c) Ian Duncan, 2021
 License     :  BSD-3
 Description :  OTLP Exporter
 Maintainer  :  Ian Duncan
 Stability   :  experimental
 Portability :  non-portable (GHC extensions)

 The OTLP Exporter is the recommend exporter format to use where possible.

 A number of vendors offer support for exporting traces, logs, and metrics using the vendor-agnostic OTLP protocol.

 Additionally, the OTLP format is supported by the <https://opentelemetry.io/docs/collector/ OpenTelemetry Collector>.

 The OpenTelemetry Collector offers a vendor-agnostic implementation of how to receive, process and export telemetry data.
 It removes the need to run, operate, and maintain multiple agents/collectors.
 This works with improved scalability and supports open-source observability data formats (e.g. Jaeger, Prometheus, Fluent Bit, etc.) sending to
 one or more open-source or commercial back-ends. The local Collector agent is the default location to which instrumentation libraries export
 their telemetry data.
-}
module OpenTelemetry.Exporter.OTLP (
  -- * Initializing the exporter
  otlpExporter,

  -- * Configuring the exporter
  OTLPExporterConfig (..),
  CompressionFormat (..),
  Protocol (..),
  loadExporterEnvironmentVariables,

  -- * Default local endpoints
  otlpExporterHttpEndpoint,
  otlpExporterGRpcEndpoint,
) where

import Codec.Compression.GZip
import Control.Applicative ((<|>))
import Control.Concurrent (threadDelay)
import Control.Exception (SomeAsyncException (..), SomeException (..), fromException, throwIO, try)
import Control.Monad.IO.Class
import Data.Bits (shiftL)
import qualified Data.ByteString.Char8 as C
import qualified Data.ByteString.Lazy as L
import qualified Data.CaseInsensitive as CI
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as H
import Data.Maybe
import Data.ProtoLens.Encoding
import Data.ProtoLens.Message
import Data.Text (Text)
import qualified Data.Text.Encoding as T
import Data.Vector (Vector)
import qualified Data.Vector as V
import qualified Data.Vector as Vector
import Lens.Micro
import Network.HTTP.Client
import Network.HTTP.Simple (httpBS)
import Network.HTTP.Types.Header
import Network.HTTP.Types.Status
import OpenTelemetry.Attributes
import qualified OpenTelemetry.Baggage as Baggage
import OpenTelemetry.Exporter
import OpenTelemetry.Resource
import OpenTelemetry.Trace.Core (timestampNanoseconds)
import qualified OpenTelemetry.Trace.Core as OT
import OpenTelemetry.Trace.Id (spanIdBytes, traceIdBytes)
import OpenTelemetry.Util
import Proto.Opentelemetry.Proto.Collector.Trace.V1.TraceService (ExportTraceServiceRequest)
import Proto.Opentelemetry.Proto.Common.V1.Common
import Proto.Opentelemetry.Proto.Common.V1.Common_Fields
import Proto.Opentelemetry.Proto.Trace.V1.Trace (InstrumentationLibrarySpans, Span, Span'Event, Span'Link, Span'SpanKind (Span'SPAN_KIND_CLIENT, Span'SPAN_KIND_CONSUMER, Span'SPAN_KIND_INTERNAL, Span'SPAN_KIND_PRODUCER, Span'SPAN_KIND_SERVER), Status'StatusCode (Status'STATUS_CODE_ERROR, Status'STATUS_CODE_OK, Status'STATUS_CODE_UNSET))
import Proto.Opentelemetry.Proto.Trace.V1.Trace_Fields
import System.Environment
import Text.Read (readMaybe)


data CompressionFormat = None | GZip


data Protocol {- GRpc | HttpJson | -}
  = -- | Note: grpc and http/json will likely be supported eventually,
    -- but not yet.
    HttpProtobuf


otlpExporterHttpEndpoint :: C.ByteString
otlpExporterHttpEndpoint :: ByteString
otlpExporterHttpEndpoint = ByteString
"http://localhost:4318"


otlpExporterGRpcEndpoint :: C.ByteString
otlpExporterGRpcEndpoint :: ByteString
otlpExporterGRpcEndpoint = ByteString
"http://localhost:4317"


data OTLPExporterConfig = OTLPExporterConfig
  { OTLPExporterConfig -> Maybe String
otlpEndpoint :: Maybe String
  , OTLPExporterConfig -> Maybe String
otlpTracesEndpoint :: Maybe String
  , OTLPExporterConfig -> Maybe String
otlpMetricsEndpoint :: Maybe String
  , OTLPExporterConfig -> Maybe Bool
otlpInsecure :: Maybe Bool
  , OTLPExporterConfig -> Maybe Bool
otlpSpanInsecure :: Maybe Bool
  , OTLPExporterConfig -> Maybe Bool
otlpMetricInsecure :: Maybe Bool
  , OTLPExporterConfig -> Maybe String
otlpCertificate :: Maybe FilePath
  , OTLPExporterConfig -> Maybe String
otlpTracesCertificate :: Maybe FilePath
  , OTLPExporterConfig -> Maybe String
otlpMetricCertificate :: Maybe FilePath
  , OTLPExporterConfig -> Maybe [Header]
otlpHeaders :: Maybe [Header]
  , OTLPExporterConfig -> Maybe [Header]
otlpTracesHeaders :: Maybe [Header]
  , OTLPExporterConfig -> Maybe [Header]
otlpMetricsHeaders :: Maybe [Header]
  , OTLPExporterConfig -> Maybe CompressionFormat
otlpCompression :: Maybe CompressionFormat
  , OTLPExporterConfig -> Maybe CompressionFormat
otlpTracesCompression :: Maybe CompressionFormat
  , OTLPExporterConfig -> Maybe CompressionFormat
otlpMetricsCompression :: Maybe CompressionFormat
  , OTLPExporterConfig -> Maybe Int
otlpTimeout :: Maybe Int
  -- ^ Measured in seconds
  , OTLPExporterConfig -> Maybe Int
otlpTracesTimeout :: Maybe Int
  , OTLPExporterConfig -> Maybe Int
otlpMetricsTimeout :: Maybe Int
  , OTLPExporterConfig -> Maybe Protocol
otlpProtocol :: Maybe Protocol
  , OTLPExporterConfig -> Maybe Protocol
otlpTracesProtocol :: Maybe Protocol
  , OTLPExporterConfig -> Maybe Protocol
otlpMetricsProtocol :: Maybe Protocol
  }


loadExporterEnvironmentVariables :: (MonadIO m) => m OTLPExporterConfig
loadExporterEnvironmentVariables :: forall (m :: * -> *). MonadIO m => m OTLPExporterConfig
loadExporterEnvironmentVariables = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
  Maybe String
-> Maybe String
-> Maybe String
-> Maybe Bool
-> Maybe Bool
-> Maybe Bool
-> Maybe String
-> Maybe String
-> Maybe String
-> Maybe [Header]
-> Maybe [Header]
-> Maybe [Header]
-> Maybe CompressionFormat
-> Maybe CompressionFormat
-> Maybe CompressionFormat
-> Maybe Int
-> Maybe Int
-> Maybe Int
-> Maybe Protocol
-> Maybe Protocol
-> Maybe Protocol
-> OTLPExporterConfig
OTLPExporterConfig
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
"OTEL_EXPORTER_OTLP_ENDPOINT"
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> IO (Maybe String)
lookupEnv String
"OTEL_EXPORTER_OTLP_TRACES_ENDPOINT"
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> IO (Maybe String)
lookupEnv String
"OTEL_EXPORTER_OTLP_METRICS_ENDPOINT"
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Eq a => a -> a -> Bool
== String
"true") forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
"OTEL_EXPORTER_OTLP_INSECURE")
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Eq a => a -> a -> Bool
== String
"true") forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
"OTEL_EXPORTER_OTLP_SPAN_INSECURE")
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Eq a => a -> a -> Bool
== String
"true") forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
"OTEL_EXPORTER_OTLP_METRIC_INSECURE")
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> IO (Maybe String)
lookupEnv String
"OTEL_EXPORTER_OTLP_CERTIFICATE"
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> IO (Maybe String)
lookupEnv String
"OTEL_EXPORTER_OTLP_TRACES_CERTIFICATE"
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> IO (Maybe String)
lookupEnv String
"OTEL_EXPORTER_OTLP_METRICS_CERTIFICATE"
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> [Header]
decodeHeaders forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
"OTEL_EXPORTER_OTLP_HEADERS")
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
    -- TODO lookupEnv "OTEL_EXPORTER_OTLP_TRACES_HEADERS" <*>
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
    -- TODO lookupEnv "OTEL_EXPORTER_OTLP_METRICS_HEADERS" <*>
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
    -- TODO lookupEnv  <*>
    ( forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
        ( \case
            String
"gzip" -> CompressionFormat
GZip
            String
"none" -> CompressionFormat
None
            -- TODO
            String
_ -> CompressionFormat
None
        )
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
"OTEL_EXPORTER_OTLP_COMPRESSION"
    )
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
    -- TODO lookupEnv "OTEL_EXPORTER_OTLP_TRACES_COMPRESSION" <*>
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
    -- TODO lookupEnv "OTEL_EXPORTER_OTLP_METRICS_COMPRESSION" <*>
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
    -- TODO lookupEnv "OTEL_EXPORTER_OTLP_TIMEOUT" <*>
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
    -- TODO lookupEnv "OTEL_EXPORTER_OTLP_TRACES_TIMEOUT" <*>
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
    -- TODO lookupEnv "OTEL_EXPORTER_OTLP_METRICS_TIMEOUT" <*>
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
    -- TODO lookupEnv "OTEL_EXPORTER_OTLP_PROTOCOL" <*>
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
    -- TODO lookupEnv "OTEL_EXPORTER_OTLP_TRACES_PROTOCOL" <*>
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
    -- TODO lookupEnv "OTEL_EXPORTER_OTLP_METRICS_PROTOCOL"
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
  where
    decodeHeaders :: String -> [Header]
decodeHeaders String
hsString = case ByteString -> Either String Baggage
Baggage.decodeBaggageHeader forall a b. (a -> b) -> a -> b
$ String -> ByteString
C.pack String
hsString of
      Left String
_ -> forall a. Monoid a => a
mempty
      Right Baggage
baggageFmt ->
        (\(Token
k, Element
v) -> (forall s. FoldCase s => s -> CI s
CI.mk forall a b. (a -> b) -> a -> b
$ Token -> ByteString
Baggage.tokenValue Token
k, Text -> ByteString
T.encodeUtf8 forall a b. (a -> b) -> a -> b
$ Element -> Text
Baggage.value Element
v)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k v. HashMap k v -> [(k, v)]
H.toList (Baggage -> HashMap Token Element
Baggage.values Baggage
baggageFmt)


protobufMimeType :: C.ByteString
protobufMimeType :: ByteString
protobufMimeType = ByteString
"application/x-protobuf"


-- | Initial the OTLP 'Exporter'
otlpExporter :: (MonadIO m) => OTLPExporterConfig -> m (Exporter OT.ImmutableSpan)
otlpExporter :: forall (m :: * -> *).
MonadIO m =>
OTLPExporterConfig -> m (Exporter ImmutableSpan)
otlpExporter OTLPExporterConfig
conf = do
  -- TODO, url parsing is janky
  -- TODO configurable retryDelay, maximum retry counts
  Request
req <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest (forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"http://localhost:4318/v1/traces" (forall a. Semigroup a => a -> a -> a
<> String
"/v1/traces") (OTLPExporterConfig -> Maybe String
otlpEndpoint OTLPExporterConfig
conf))

  let ([Header] -> [Header]
encodingHeader, ByteString -> ByteString
encoder) =
        forall b a. b -> (a -> b) -> Maybe a -> b
maybe
          (forall a. a -> a
id, forall a. a -> a
id)
          ( \case
              CompressionFormat
None -> (forall a. a -> a
id, forall a. a -> a
id)
              CompressionFormat
GZip -> (((CI ByteString
hContentEncoding, ByteString
"gzip") forall a. a -> [a] -> [a]
:), ByteString -> ByteString
compress)
          )
          (OTLPExporterConfig -> Maybe CompressionFormat
otlpTracesCompression OTLPExporterConfig
conf forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> OTLPExporterConfig -> Maybe CompressionFormat
otlpCompression OTLPExporterConfig
conf)

      baseReqHeaders :: [Header]
baseReqHeaders =
        [Header] -> [Header]
encodingHeader forall a b. (a -> b) -> a -> b
$
          (CI ByteString
hContentType, ByteString
protobufMimeType)
            forall a. a -> [a] -> [a]
: (CI ByteString
hAcceptEncoding, ByteString
protobufMimeType)
            forall a. a -> [a] -> [a]
: forall a. a -> Maybe a -> a
fromMaybe [] (OTLPExporterConfig -> Maybe [Header]
otlpHeaders OTLPExporterConfig
conf)
            forall a. [a] -> [a] -> [a]
++ forall a. a -> Maybe a -> a
fromMaybe [] (OTLPExporterConfig -> Maybe [Header]
otlpTracesHeaders OTLPExporterConfig
conf)
            forall a. [a] -> [a] -> [a]
++ Request -> [Header]
requestHeaders Request
req
      baseReq :: Request
baseReq =
        Request
req
          { method :: ByteString
method = ByteString
"POST"
          , requestHeaders :: [Header]
requestHeaders = [Header]
baseReqHeaders
          }
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    Exporter
      { exporterExport :: HashMap InstrumentationLibrary (Vector ImmutableSpan)
-> IO ExportResult
exporterExport = \HashMap InstrumentationLibrary (Vector ImmutableSpan)
spans_ -> do
          let anySpansToExport :: Bool
anySpansToExport = forall k v. HashMap k v -> Int
H.size HashMap InstrumentationLibrary (Vector ImmutableSpan)
spans_ forall a. Eq a => a -> a -> Bool
/= Int
0 Bool -> Bool -> Bool
&& Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all forall a. Vector a -> Bool
V.null forall a b. (a -> b) -> a -> b
$ forall k v. HashMap k v -> [v]
H.elems HashMap InstrumentationLibrary (Vector ImmutableSpan)
spans_)
          if Bool
anySpansToExport
            then do
              Either SomeException ExportResult
result <- forall e a. Exception e => IO a -> IO (Either e a)
try forall a b. (a -> b) -> a -> b
$ (ByteString -> ByteString)
-> Request
-> HashMap InstrumentationLibrary (Vector ImmutableSpan)
-> IO ExportResult
exporterExportCall ByteString -> ByteString
encoder Request
baseReq HashMap InstrumentationLibrary (Vector ImmutableSpan)
spans_
              case Either SomeException ExportResult
result of
                Left SomeException
err -> do
                  -- If the exception is async, then we need to rethrow it
                  -- here. Otherwise, there's a good chance that the
                  -- calling code will swallow the exception and cause
                  -- a problem.
                  case forall e. Exception e => SomeException -> Maybe e
fromException SomeException
err of
                    Just (SomeAsyncException e
_) ->
                      forall e a. Exception e => e -> IO a
throwIO SomeException
err
                    Maybe SomeAsyncException
Nothing ->
                      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Maybe SomeException -> ExportResult
Failure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just SomeException
err
                Right ExportResult
ok -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ExportResult
ok
            else forall (f :: * -> *) a. Applicative f => a -> f a
pure ExportResult
Success
      , exporterShutdown :: IO ()
exporterShutdown = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      }
  where
    retryDelay :: Int
retryDelay = Int
100_000 -- 100ms
    maxRetryCount :: Int
maxRetryCount = Int
5
    isRetryableStatusCode :: Status -> Bool
isRetryableStatusCode Status
status_ =
      Status
status_ forall a. Eq a => a -> a -> Bool
== Status
status408 Bool -> Bool -> Bool
|| Status
status_ forall a. Eq a => a -> a -> Bool
== Status
status429 Bool -> Bool -> Bool
|| (Status -> Int
statusCode Status
status_ forall a. Ord a => a -> a -> Bool
>= Int
500 Bool -> Bool -> Bool
&& Status -> Int
statusCode Status
status_ forall a. Ord a => a -> a -> Bool
< Int
600)
    isRetryableException :: HttpExceptionContent -> Bool
isRetryableException = \case
      HttpExceptionContent
ResponseTimeout -> Bool
True
      HttpExceptionContent
ConnectionTimeout -> Bool
True
      ConnectionFailure SomeException
_ -> Bool
True
      HttpExceptionContent
ConnectionClosed -> Bool
True
      HttpExceptionContent
_ -> Bool
False

    exporterExportCall :: (ByteString -> ByteString)
-> Request
-> HashMap InstrumentationLibrary (Vector ImmutableSpan)
-> IO ExportResult
exporterExportCall ByteString -> ByteString
encoder Request
baseReq HashMap InstrumentationLibrary (Vector ImmutableSpan)
spans_ = do
      ByteString
msg <- forall msg. Message msg => msg -> ByteString
encodeMessage forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
MonadIO m =>
HashMap InstrumentationLibrary (Vector ImmutableSpan)
-> m ExportTraceServiceRequest
immutableSpansToProtobuf HashMap InstrumentationLibrary (Vector ImmutableSpan)
spans_
      -- TODO handle server disconnect
      let req :: Request
req =
            Request
baseReq
              { requestBody :: RequestBody
requestBody =
                  ByteString -> RequestBody
RequestBodyLBS forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
encoder forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
L.fromStrict ByteString
msg
              }
      Request -> Int -> IO ExportResult
sendReq Request
req Int
0 -- TODO =<< getTime for maximum cutoff
    sendReq :: Request -> Int -> IO ExportResult
sendReq Request
req Int
backoffCount = do
      Either HttpException (Response ByteString)
eResp <- forall e a. Exception e => IO a -> IO (Either e a)
try forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
Request -> m (Response ByteString)
httpBS Request
req

      let exponentialBackoff :: IO ExportResult
exponentialBackoff =
            if Int
backoffCount forall a. Eq a => a -> a -> Bool
== Int
maxRetryCount
              then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Maybe SomeException -> ExportResult
Failure forall a. Maybe a
Nothing
              else do
                Int -> IO ()
threadDelay (Int
retryDelay forall a. Bits a => a -> Int -> a
`shiftL` Int
backoffCount)
                Request -> Int -> IO ExportResult
sendReq Request
req (Int
backoffCount forall a. Num a => a -> a -> a
+ Int
1)

      forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. Show a => a -> IO ()
print (\Response ByteString
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) Either HttpException (Response ByteString)
eResp

      case Either HttpException (Response ByteString)
eResp of
        Left err :: HttpException
err@(HttpExceptionRequest Request
_ HttpExceptionContent
e) ->
          if HttpExceptionContent -> Bool
isRetryableException HttpExceptionContent
e
            then IO ExportResult
exponentialBackoff
            else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Maybe SomeException -> ExportResult
Failure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall e. Exception e => e -> SomeException
SomeException HttpException
err
        Left HttpException
err -> do
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Maybe SomeException -> ExportResult
Failure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall e. Exception e => e -> SomeException
SomeException HttpException
err
        Right Response ByteString
resp ->
          if Status -> Bool
isRetryableStatusCode (forall body. Response body -> Status
responseStatus Response ByteString
resp)
            then case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup CI ByteString
hRetryAfter forall a b. (a -> b) -> a -> b
$ forall body. Response body -> [Header]
responseHeaders Response ByteString
resp of
              Maybe ByteString
Nothing -> IO ExportResult
exponentialBackoff
              Just ByteString
retryAfter -> do
                -- TODO support date in retry-after header
                case forall a. Read a => String -> Maybe a
readMaybe forall a b. (a -> b) -> a -> b
$ ByteString -> String
C.unpack ByteString
retryAfter of
                  Maybe Int
Nothing -> IO ExportResult
exponentialBackoff
                  Just Int
seconds -> do
                    Int -> IO ()
threadDelay (Int
seconds forall a. Num a => a -> a -> a
* Int
1_000_000)
                    Request -> Int -> IO ExportResult
sendReq Request
req (Int
backoffCount forall a. Num a => a -> a -> a
+ Int
1)
            else
              if Status -> Int
statusCode (forall body. Response body -> Status
responseStatus Response ByteString
resp) forall a. Ord a => a -> a -> Bool
>= Int
300
                then do
                  forall a. Show a => a -> IO ()
print Response ByteString
resp
                  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Maybe SomeException -> ExportResult
Failure forall a. Maybe a
Nothing
                else forall (f :: * -> *) a. Applicative f => a -> f a
pure ExportResult
Success


attributesToProto :: Attributes -> Vector KeyValue
attributesToProto :: Attributes -> Vector KeyValue
attributesToProto =
  forall a. [a] -> Vector a
V.fromList
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text, Attribute) -> KeyValue
attributeToKeyValue
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k v. HashMap k v -> [(k, v)]
H.toList
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. Attributes -> (Int, HashMap Text Attribute)
getAttributes
  where
    primAttributeToAnyValue :: PrimitiveAttribute -> AnyValue
primAttributeToAnyValue = \case
      TextAttribute Text
t -> forall msg. Message msg => msg
defMessage forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) s a.
(Functor f, HasField s "stringValue" a) =>
LensLike' f s a
stringValue forall s t a b. ASetter s t a b -> b -> s -> t
.~ Text
t
      BoolAttribute Bool
b -> forall msg. Message msg => msg
defMessage forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) s a.
(Functor f, HasField s "boolValue" a) =>
LensLike' f s a
boolValue forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
b
      DoubleAttribute Double
d -> forall msg. Message msg => msg
defMessage forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) s a.
(Functor f, HasField s "doubleValue" a) =>
LensLike' f s a
doubleValue forall s t a b. ASetter s t a b -> b -> s -> t
.~ Double
d
      IntAttribute Int64
i -> forall msg. Message msg => msg
defMessage forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) s a.
(Functor f, HasField s "intValue" a) =>
LensLike' f s a
intValue forall s t a b. ASetter s t a b -> b -> s -> t
.~ Int64
i
    attributeToKeyValue :: (Text, Attribute) -> KeyValue
    attributeToKeyValue :: (Text, Attribute) -> KeyValue
attributeToKeyValue (Text
k, Attribute
v) =
      forall msg. Message msg => msg
defMessage
        forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) s a.
(Functor f, HasField s "key" a) =>
LensLike' f s a
key forall s t a b. ASetter s t a b -> b -> s -> t
.~ Text
k
        forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) s a.
(Functor f, HasField s "value" a) =>
LensLike' f s a
value
          forall s t a b. ASetter s t a b -> b -> s -> t
.~ ( case Attribute
v of
                AttributeValue PrimitiveAttribute
a -> PrimitiveAttribute -> AnyValue
primAttributeToAnyValue PrimitiveAttribute
a
                AttributeArray [PrimitiveAttribute]
a ->
                  forall msg. Message msg => msg
defMessage
                    forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) s a.
(Functor f, HasField s "arrayValue" a) =>
LensLike' f s a
arrayValue forall s t a b. ASetter s t a b -> b -> s -> t
.~ (forall msg. Message msg => msg
defMessage forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) s a.
(Functor f, HasField s "values" a) =>
LensLike' f s a
values forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PrimitiveAttribute -> AnyValue
primAttributeToAnyValue [PrimitiveAttribute]
a)
             )


immutableSpansToProtobuf :: (MonadIO m) => HashMap OT.InstrumentationLibrary (Vector OT.ImmutableSpan) -> m ExportTraceServiceRequest
immutableSpansToProtobuf :: forall (m :: * -> *).
MonadIO m =>
HashMap InstrumentationLibrary (Vector ImmutableSpan)
-> m ExportTraceServiceRequest
immutableSpansToProtobuf HashMap InstrumentationLibrary (Vector ImmutableSpan)
completedSpans = do
  [InstrumentationLibrarySpans]
spansByLibrary <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *).
MonadIO m =>
(InstrumentationLibrary, Vector ImmutableSpan)
-> m InstrumentationLibrarySpans
makeInstrumentationLibrarySpans [(InstrumentationLibrary, Vector ImmutableSpan)]
spanGroupList
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    forall msg. Message msg => msg
defMessage
      forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) s a.
(Functor f, HasField s "vec'resourceSpans" a) =>
LensLike' f s a
vec'resourceSpans
        forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> Vector a
Vector.singleton
          ( forall msg. Message msg => msg
defMessage
              forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) s a.
(Functor f, HasField s "resource" a) =>
LensLike' f s a
resource
                forall s t a b. ASetter s t a b -> b -> s -> t
.~ ( forall msg. Message msg => msg
defMessage
                      forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) s a.
(Functor f, HasField s "vec'attributes" a) =>
LensLike' f s a
vec'attributes forall s t a b. ASetter s t a b -> b -> s -> t
.~ Attributes -> Vector KeyValue
attributesToProto (MaterializedResources -> Attributes
getMaterializedResourcesAttributes MaterializedResources
someResourceGroup)
                      -- TODO
                      forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) s a.
(Functor f, HasField s "droppedAttributesCount" a) =>
LensLike' f s a
droppedAttributesCount forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word32
0
                   )
              -- TODO, seems like spans need to be emitted via an API
              -- that lets us keep them grouped by instrumentation originator
              forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) s a.
(Functor f, HasField s "instrumentationLibrarySpans" a) =>
LensLike' f s a
instrumentationLibrarySpans forall s t a b. ASetter s t a b -> b -> s -> t
.~ [InstrumentationLibrarySpans]
spansByLibrary
          )
  where
    -- TODO this won't work right if multiple TracerProviders are exporting to a single OTLP exporter with different resources
    someResourceGroup :: MaterializedResources
someResourceGroup = case [(InstrumentationLibrary, Vector ImmutableSpan)]
spanGroupList of
      [] -> MaterializedResources
emptyMaterializedResources
      ((InstrumentationLibrary
_, Vector ImmutableSpan
r) : [(InstrumentationLibrary, Vector ImmutableSpan)]
_) -> case Vector ImmutableSpan
r forall a. Vector a -> Int -> Maybe a
V.!? Int
0 of
        Maybe ImmutableSpan
Nothing -> MaterializedResources
emptyMaterializedResources
        Just ImmutableSpan
s -> TracerProvider -> MaterializedResources
OT.getTracerProviderResources forall a b. (a -> b) -> a -> b
$ Tracer -> TracerProvider
OT.getTracerTracerProvider forall a b. (a -> b) -> a -> b
$ ImmutableSpan -> Tracer
OT.spanTracer ImmutableSpan
s

    spanGroupList :: [(InstrumentationLibrary, Vector ImmutableSpan)]
spanGroupList = forall k v. HashMap k v -> [(k, v)]
H.toList HashMap InstrumentationLibrary (Vector ImmutableSpan)
completedSpans

    makeInstrumentationLibrarySpans :: (MonadIO m) => (OT.InstrumentationLibrary, Vector OT.ImmutableSpan) -> m InstrumentationLibrarySpans
    makeInstrumentationLibrarySpans :: forall (m :: * -> *).
MonadIO m =>
(InstrumentationLibrary, Vector ImmutableSpan)
-> m InstrumentationLibrarySpans
makeInstrumentationLibrarySpans (InstrumentationLibrary
library, Vector ImmutableSpan
completedSpans_) = do
      Vector Span
spans_ <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *). MonadIO m => ImmutableSpan -> m Span
makeSpan Vector ImmutableSpan
completedSpans_
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
        forall msg. Message msg => msg
defMessage
          forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) s a.
(Functor f, HasField s "instrumentationLibrary" a) =>
LensLike' f s a
instrumentationLibrary
            forall s t a b. ASetter s t a b -> b -> s -> t
.~ ( forall msg. Message msg => msg
defMessage
                  forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) s a.
(Functor f, HasField s "name" a) =>
LensLike' f s a
Proto.Opentelemetry.Proto.Trace.V1.Trace_Fields.name forall s t a b. ASetter s t a b -> b -> s -> t
.~ InstrumentationLibrary -> Text
OT.libraryName InstrumentationLibrary
library
                  forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) s a.
(Functor f, HasField s "version" a) =>
LensLike' f s a
version forall s t a b. ASetter s t a b -> b -> s -> t
.~ InstrumentationLibrary -> Text
OT.libraryVersion InstrumentationLibrary
library
               )
          forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) s a.
(Functor f, HasField s "vec'spans" a) =>
LensLike' f s a
vec'spans forall s t a b. ASetter s t a b -> b -> s -> t
.~ Vector Span
spans_


-- & schemaUrl .~ "" -- TODO

makeSpan :: (MonadIO m) => OT.ImmutableSpan -> m Span
makeSpan :: forall (m :: * -> *). MonadIO m => ImmutableSpan -> m Span
makeSpan ImmutableSpan
completedSpan = do
  let startTime :: Word64
startTime = Timestamp -> Word64
timestampNanoseconds (ImmutableSpan -> Timestamp
OT.spanStart ImmutableSpan
completedSpan)
  Span -> Span
parentSpanF <- do
    case ImmutableSpan -> Maybe Span
OT.spanParent ImmutableSpan
completedSpan of
      Maybe Span
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. a -> a
id
      Just Span
s -> do
        SpanId
spanCtxt <- SpanContext -> SpanId
OT.spanId forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadIO m => Span -> m SpanContext
OT.getSpanContext Span
s
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (\Span
otlpSpan -> Span
otlpSpan forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) s a.
(Functor f, HasField s "parentSpanId" a) =>
LensLike' f s a
parentSpanId forall s t a b. ASetter s t a b -> b -> s -> t
.~ SpanId -> ByteString
spanIdBytes SpanId
spanCtxt)

  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    forall msg. Message msg => msg
defMessage
      forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) s a.
(Functor f, HasField s "traceId" a) =>
LensLike' f s a
traceId forall s t a b. ASetter s t a b -> b -> s -> t
.~ TraceId -> ByteString
traceIdBytes (SpanContext -> TraceId
OT.traceId forall a b. (a -> b) -> a -> b
$ ImmutableSpan -> SpanContext
OT.spanContext ImmutableSpan
completedSpan)
      forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) s a.
(Functor f, HasField s "spanId" a) =>
LensLike' f s a
spanId forall s t a b. ASetter s t a b -> b -> s -> t
.~ SpanId -> ByteString
spanIdBytes (SpanContext -> SpanId
OT.spanId forall a b. (a -> b) -> a -> b
$ ImmutableSpan -> SpanContext
OT.spanContext ImmutableSpan
completedSpan)
      forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) s a.
(Functor f, HasField s "traceState" a) =>
LensLike' f s a
traceState forall s t a b. ASetter s t a b -> b -> s -> t
.~ Text
"" -- TODO (_ $ OT.traceState $ OT.spanContext completedSpan)
      forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) s a.
(Functor f, HasField s "name" a) =>
LensLike' f s a
Proto.Opentelemetry.Proto.Trace.V1.Trace_Fields.name forall s t a b. ASetter s t a b -> b -> s -> t
.~ ImmutableSpan -> Text
OT.spanName ImmutableSpan
completedSpan
      forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) s a.
(Functor f, HasField s "kind" a) =>
LensLike' f s a
kind
        forall s t a b. ASetter s t a b -> b -> s -> t
.~ ( case ImmutableSpan -> SpanKind
OT.spanKind ImmutableSpan
completedSpan of
              SpanKind
OT.Server -> Span'SpanKind
Span'SPAN_KIND_SERVER
              SpanKind
OT.Client -> Span'SpanKind
Span'SPAN_KIND_CLIENT
              SpanKind
OT.Producer -> Span'SpanKind
Span'SPAN_KIND_PRODUCER
              SpanKind
OT.Consumer -> Span'SpanKind
Span'SPAN_KIND_CONSUMER
              SpanKind
OT.Internal -> Span'SpanKind
Span'SPAN_KIND_INTERNAL
           )
      forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) s a.
(Functor f, HasField s "startTimeUnixNano" a) =>
LensLike' f s a
startTimeUnixNano forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word64
startTime
      forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) s a.
(Functor f, HasField s "endTimeUnixNano" a) =>
LensLike' f s a
endTimeUnixNano forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall b a. b -> (a -> b) -> Maybe a -> b
maybe Word64
startTime Timestamp -> Word64
timestampNanoseconds (ImmutableSpan -> Maybe Timestamp
OT.spanEnd ImmutableSpan
completedSpan)
      forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) s a.
(Functor f, HasField s "vec'attributes" a) =>
LensLike' f s a
vec'attributes forall s t a b. ASetter s t a b -> b -> s -> t
.~ Attributes -> Vector KeyValue
attributesToProto (ImmutableSpan -> Attributes
OT.spanAttributes ImmutableSpan
completedSpan)
      forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) s a.
(Functor f, HasField s "droppedAttributesCount" a) =>
LensLike' f s a
droppedAttributesCount forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a b. (a, b) -> a
fst (Attributes -> (Int, HashMap Text Attribute)
getAttributes forall a b. (a -> b) -> a -> b
$ ImmutableSpan -> Attributes
OT.spanAttributes ImmutableSpan
completedSpan))
      forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) s a.
(Functor f, HasField s "vec'events" a) =>
LensLike' f s a
vec'events forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Event -> Span'Event
makeEvent (forall a. AppendOnlyBoundedCollection a -> Vector a
appendOnlyBoundedCollectionValues forall a b. (a -> b) -> a -> b
$ ImmutableSpan -> AppendOnlyBoundedCollection Event
OT.spanEvents ImmutableSpan
completedSpan)
      forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) s a.
(Functor f, HasField s "droppedEventsCount" a) =>
LensLike' f s a
droppedEventsCount forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. AppendOnlyBoundedCollection a -> Int
appendOnlyBoundedCollectionDroppedElementCount (ImmutableSpan -> AppendOnlyBoundedCollection Event
OT.spanEvents ImmutableSpan
completedSpan))
      forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) s a.
(Functor f, HasField s "vec'links" a) =>
LensLike' f s a
vec'links forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Link -> Span'Link
makeLink (forall a. FrozenBoundedCollection a -> Vector a
frozenBoundedCollectionValues forall a b. (a -> b) -> a -> b
$ ImmutableSpan -> FrozenBoundedCollection Link
OT.spanLinks ImmutableSpan
completedSpan)
      forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) s a.
(Functor f, HasField s "droppedLinksCount" a) =>
LensLike' f s a
droppedLinksCount forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. FrozenBoundedCollection a -> Int
frozenBoundedCollectionDroppedElementCount (ImmutableSpan -> FrozenBoundedCollection Link
OT.spanLinks ImmutableSpan
completedSpan))
      forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) s a.
(Functor f, HasField s "status" a) =>
LensLike' f s a
status
        forall s t a b. ASetter s t a b -> b -> s -> t
.~ ( case ImmutableSpan -> SpanStatus
OT.spanStatus ImmutableSpan
completedSpan of
              SpanStatus
OT.Unset ->
                forall msg. Message msg => msg
defMessage
                  forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) s a.
(Functor f, HasField s "code" a) =>
LensLike' f s a
code forall s t a b. ASetter s t a b -> b -> s -> t
.~ Status'StatusCode
Status'STATUS_CODE_UNSET
              SpanStatus
OT.Ok ->
                forall msg. Message msg => msg
defMessage
                  forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) s a.
(Functor f, HasField s "code" a) =>
LensLike' f s a
code forall s t a b. ASetter s t a b -> b -> s -> t
.~ Status'StatusCode
Status'STATUS_CODE_OK
              (OT.Error Text
e) ->
                forall msg. Message msg => msg
defMessage
                  forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) s a.
(Functor f, HasField s "code" a) =>
LensLike' f s a
code forall s t a b. ASetter s t a b -> b -> s -> t
.~ Status'StatusCode
Status'STATUS_CODE_ERROR
                  forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) s a.
(Functor f, HasField s "message" a) =>
LensLike' f s a
message forall s t a b. ASetter s t a b -> b -> s -> t
.~ Text
e
           )
      forall a b. a -> (a -> b) -> b
& Span -> Span
parentSpanF


makeEvent :: OT.Event -> Span'Event
makeEvent :: Event -> Span'Event
makeEvent Event
e =
  forall msg. Message msg => msg
defMessage
    forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) s a.
(Functor f, HasField s "timeUnixNano" a) =>
LensLike' f s a
timeUnixNano forall s t a b. ASetter s t a b -> b -> s -> t
.~ Timestamp -> Word64
timestampNanoseconds (Event -> Timestamp
OT.eventTimestamp Event
e)
    forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) s a.
(Functor f, HasField s "name" a) =>
LensLike' f s a
Proto.Opentelemetry.Proto.Trace.V1.Trace_Fields.name forall s t a b. ASetter s t a b -> b -> s -> t
.~ Event -> Text
OT.eventName Event
e
    forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) s a.
(Functor f, HasField s "vec'attributes" a) =>
LensLike' f s a
vec'attributes forall s t a b. ASetter s t a b -> b -> s -> t
.~ Attributes -> Vector KeyValue
attributesToProto (Event -> Attributes
OT.eventAttributes Event
e)
    forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) s a.
(Functor f, HasField s "droppedAttributesCount" a) =>
LensLike' f s a
droppedAttributesCount forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a b. (a, b) -> a
fst (Attributes -> (Int, HashMap Text Attribute)
getAttributes forall a b. (a -> b) -> a -> b
$ Event -> Attributes
OT.eventAttributes Event
e))


makeLink :: OT.Link -> Span'Link
makeLink :: Link -> Span'Link
makeLink Link
l =
  forall msg. Message msg => msg
defMessage
    forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) s a.
(Functor f, HasField s "traceId" a) =>
LensLike' f s a
traceId forall s t a b. ASetter s t a b -> b -> s -> t
.~ TraceId -> ByteString
traceIdBytes (SpanContext -> TraceId
OT.traceId forall a b. (a -> b) -> a -> b
$ Link -> SpanContext
OT.frozenLinkContext Link
l)
    forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) s a.
(Functor f, HasField s "spanId" a) =>
LensLike' f s a
spanId forall s t a b. ASetter s t a b -> b -> s -> t
.~ SpanId -> ByteString
spanIdBytes (SpanContext -> SpanId
OT.spanId forall a b. (a -> b) -> a -> b
$ Link -> SpanContext
OT.frozenLinkContext Link
l)
    forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) s a.
(Functor f, HasField s "vec'attributes" a) =>
LensLike' f s a
vec'attributes forall s t a b. ASetter s t a b -> b -> s -> t
.~ Attributes -> Vector KeyValue
attributesToProto (Link -> Attributes
OT.frozenLinkAttributes Link
l)
    forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) s a.
(Functor f, HasField s "droppedAttributesCount" a) =>
LensLike' f s a
droppedAttributesCount forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a b. (a, b) -> a
fst (Attributes -> (Int, HashMap Text Attribute)
getAttributes forall a b. (a -> b) -> a -> b
$ Link -> Attributes
OT.frozenLinkAttributes Link
l))