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

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

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 :: m OTLPExporterConfig
loadExporterEnvironmentVariables = IO OTLPExporterConfig -> m OTLPExporterConfig
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO OTLPExporterConfig -> m OTLPExporterConfig)
-> IO OTLPExporterConfig -> m OTLPExporterConfig
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 (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)
-> IO (Maybe String)
-> IO
     (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)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    String -> IO (Maybe String)
lookupEnv String
"OTEL_EXPORTER_OTLP_ENDPOINT" IO
  (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)
-> IO (Maybe String)
-> IO
     (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)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
    String -> IO (Maybe String)
lookupEnv String
"OTEL_EXPORTER_OTLP_TRACES_ENDPOINT" IO
  (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)
-> IO (Maybe String)
-> IO
     (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)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
    String -> IO (Maybe String)
lookupEnv String
"OTEL_EXPORTER_OTLP_METRICS_ENDPOINT" IO
  (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)
-> IO (Maybe Bool)
-> IO
     (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)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
    ((String -> Bool) -> Maybe String -> Maybe Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"true") (Maybe String -> Maybe Bool)
-> IO (Maybe String) -> IO (Maybe Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
"OTEL_EXPORTER_OTLP_INSECURE") IO
  (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)
-> IO (Maybe Bool)
-> IO
     (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)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
    ((String -> Bool) -> Maybe String -> Maybe Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"true") (Maybe String -> Maybe Bool)
-> IO (Maybe String) -> IO (Maybe Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
"OTEL_EXPORTER_OTLP_SPAN_INSECURE") IO
  (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)
-> IO (Maybe Bool)
-> IO
     (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)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
    ((String -> Bool) -> Maybe String -> Maybe Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"true") (Maybe String -> Maybe Bool)
-> IO (Maybe String) -> IO (Maybe Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
"OTEL_EXPORTER_OTLP_METRIC_INSECURE") IO
  (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)
-> IO (Maybe String)
-> IO
     (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)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
    String -> IO (Maybe String)
lookupEnv String
"OTEL_EXPORTER_OTLP_CERTIFICATE" IO
  (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)
-> IO (Maybe String)
-> IO
     (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)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
    String -> IO (Maybe String)
lookupEnv String
"OTEL_EXPORTER_OTLP_TRACES_CERTIFICATE" IO
  (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)
-> IO (Maybe String)
-> IO
     (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)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
    String -> IO (Maybe String)
lookupEnv String
"OTEL_EXPORTER_OTLP_METRICS_CERTIFICATE" IO
  (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)
-> IO (Maybe [Header])
-> IO
     (Maybe [Header]
      -> Maybe [Header]
      -> Maybe CompressionFormat
      -> Maybe CompressionFormat
      -> Maybe CompressionFormat
      -> Maybe Int
      -> Maybe Int
      -> Maybe Int
      -> Maybe Protocol
      -> Maybe Protocol
      -> Maybe Protocol
      -> OTLPExporterConfig)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
    ((String -> [Header]) -> Maybe String -> Maybe [Header]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> [Header]
decodeHeaders (Maybe String -> Maybe [Header])
-> IO (Maybe String) -> IO (Maybe [Header])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
"OTEL_EXPORTER_OTLP_HEADERS") IO
  (Maybe [Header]
   -> Maybe [Header]
   -> Maybe CompressionFormat
   -> Maybe CompressionFormat
   -> Maybe CompressionFormat
   -> Maybe Int
   -> Maybe Int
   -> Maybe Int
   -> Maybe Protocol
   -> Maybe Protocol
   -> Maybe Protocol
   -> OTLPExporterConfig)
-> IO (Maybe [Header])
-> IO
     (Maybe [Header]
      -> Maybe CompressionFormat
      -> Maybe CompressionFormat
      -> Maybe CompressionFormat
      -> Maybe Int
      -> Maybe Int
      -> Maybe Int
      -> Maybe Protocol
      -> Maybe Protocol
      -> Maybe Protocol
      -> OTLPExporterConfig)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
    -- TODO lookupEnv "OTEL_EXPORTER_OTLP_TRACES_HEADERS" <*>
    Maybe [Header] -> IO (Maybe [Header])
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [Header]
forall a. Maybe a
Nothing IO
  (Maybe [Header]
   -> Maybe CompressionFormat
   -> Maybe CompressionFormat
   -> Maybe CompressionFormat
   -> Maybe Int
   -> Maybe Int
   -> Maybe Int
   -> Maybe Protocol
   -> Maybe Protocol
   -> Maybe Protocol
   -> OTLPExporterConfig)
-> IO (Maybe [Header])
-> IO
     (Maybe CompressionFormat
      -> Maybe CompressionFormat
      -> Maybe CompressionFormat
      -> Maybe Int
      -> Maybe Int
      -> Maybe Int
      -> Maybe Protocol
      -> Maybe Protocol
      -> Maybe Protocol
      -> OTLPExporterConfig)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
    -- TODO lookupEnv "OTEL_EXPORTER_OTLP_METRICS_HEADERS" <*>
    Maybe [Header] -> IO (Maybe [Header])
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [Header]
forall a. Maybe a
Nothing IO
  (Maybe CompressionFormat
   -> Maybe CompressionFormat
   -> Maybe CompressionFormat
   -> Maybe Int
   -> Maybe Int
   -> Maybe Int
   -> Maybe Protocol
   -> Maybe Protocol
   -> Maybe Protocol
   -> OTLPExporterConfig)
-> IO (Maybe CompressionFormat)
-> IO
     (Maybe CompressionFormat
      -> Maybe CompressionFormat
      -> Maybe Int
      -> Maybe Int
      -> Maybe Int
      -> Maybe Protocol
      -> Maybe Protocol
      -> Maybe Protocol
      -> OTLPExporterConfig)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
    -- TODO lookupEnv  <*>
    ((String -> CompressionFormat)
-> Maybe String -> Maybe CompressionFormat
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
      ) (Maybe String -> Maybe CompressionFormat)
-> IO (Maybe String) -> IO (Maybe CompressionFormat)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
"OTEL_EXPORTER_OTLP_COMPRESSION") IO
  (Maybe CompressionFormat
   -> Maybe CompressionFormat
   -> Maybe Int
   -> Maybe Int
   -> Maybe Int
   -> Maybe Protocol
   -> Maybe Protocol
   -> Maybe Protocol
   -> OTLPExporterConfig)
-> IO (Maybe CompressionFormat)
-> IO
     (Maybe CompressionFormat
      -> Maybe Int
      -> Maybe Int
      -> Maybe Int
      -> Maybe Protocol
      -> Maybe Protocol
      -> Maybe Protocol
      -> OTLPExporterConfig)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
    -- TODO lookupEnv "OTEL_EXPORTER_OTLP_TRACES_COMPRESSION" <*>
    Maybe CompressionFormat -> IO (Maybe CompressionFormat)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe CompressionFormat
forall a. Maybe a
Nothing IO
  (Maybe CompressionFormat
   -> Maybe Int
   -> Maybe Int
   -> Maybe Int
   -> Maybe Protocol
   -> Maybe Protocol
   -> Maybe Protocol
   -> OTLPExporterConfig)
-> IO (Maybe CompressionFormat)
-> IO
     (Maybe Int
      -> Maybe Int
      -> Maybe Int
      -> Maybe Protocol
      -> Maybe Protocol
      -> Maybe Protocol
      -> OTLPExporterConfig)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
    -- TODO lookupEnv "OTEL_EXPORTER_OTLP_METRICS_COMPRESSION" <*>
    Maybe CompressionFormat -> IO (Maybe CompressionFormat)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe CompressionFormat
forall a. Maybe a
Nothing IO
  (Maybe Int
   -> Maybe Int
   -> Maybe Int
   -> Maybe Protocol
   -> Maybe Protocol
   -> Maybe Protocol
   -> OTLPExporterConfig)
-> IO (Maybe Int)
-> IO
     (Maybe Int
      -> Maybe Int
      -> Maybe Protocol
      -> Maybe Protocol
      -> Maybe Protocol
      -> OTLPExporterConfig)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
    -- TODO lookupEnv "OTEL_EXPORTER_OTLP_TIMEOUT" <*>
    Maybe Int -> IO (Maybe Int)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Int
forall a. Maybe a
Nothing IO
  (Maybe Int
   -> Maybe Int
   -> Maybe Protocol
   -> Maybe Protocol
   -> Maybe Protocol
   -> OTLPExporterConfig)
-> IO (Maybe Int)
-> IO
     (Maybe Int
      -> Maybe Protocol
      -> Maybe Protocol
      -> Maybe Protocol
      -> OTLPExporterConfig)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
    -- TODO lookupEnv "OTEL_EXPORTER_OTLP_TRACES_TIMEOUT" <*>
    Maybe Int -> IO (Maybe Int)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Int
forall a. Maybe a
Nothing IO
  (Maybe Int
   -> Maybe Protocol
   -> Maybe Protocol
   -> Maybe Protocol
   -> OTLPExporterConfig)
-> IO (Maybe Int)
-> IO
     (Maybe Protocol
      -> Maybe Protocol -> Maybe Protocol -> OTLPExporterConfig)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
    -- TODO lookupEnv "OTEL_EXPORTER_OTLP_METRICS_TIMEOUT" <*>
    Maybe Int -> IO (Maybe Int)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Int
forall a. Maybe a
Nothing IO
  (Maybe Protocol
   -> Maybe Protocol -> Maybe Protocol -> OTLPExporterConfig)
-> IO (Maybe Protocol)
-> IO (Maybe Protocol -> Maybe Protocol -> OTLPExporterConfig)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
    -- TODO lookupEnv "OTEL_EXPORTER_OTLP_PROTOCOL" <*>
    Maybe Protocol -> IO (Maybe Protocol)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Protocol
forall a. Maybe a
Nothing IO (Maybe Protocol -> Maybe Protocol -> OTLPExporterConfig)
-> IO (Maybe Protocol) -> IO (Maybe Protocol -> OTLPExporterConfig)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
    -- TODO lookupEnv "OTEL_EXPORTER_OTLP_TRACES_PROTOCOL" <*>
    Maybe Protocol -> IO (Maybe Protocol)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Protocol
forall a. Maybe a
Nothing IO (Maybe Protocol -> OTLPExporterConfig)
-> IO (Maybe Protocol) -> IO OTLPExporterConfig
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
    -- TODO lookupEnv "OTEL_EXPORTER_OTLP_METRICS_PROTOCOL"
    Maybe Protocol -> IO (Maybe Protocol)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Protocol
forall a. Maybe a
Nothing
  where
    decodeHeaders :: String -> [Header]
decodeHeaders String
hsString = case ByteString -> Either String Baggage
Baggage.decodeBaggageHeader (ByteString -> Either String Baggage)
-> ByteString -> Either String Baggage
forall a b. (a -> b) -> a -> b
$ String -> ByteString
C.pack String
hsString of
      Left String
_ -> [Header]
forall a. Monoid a => a
mempty
      Right Baggage
baggageFmt ->
        (\(Token
k, Element
v) -> (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk (ByteString -> CI ByteString) -> ByteString -> CI ByteString
forall a b. (a -> b) -> a -> b
$ Token -> ByteString
Baggage.tokenValue Token
k, Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ Element -> Text
Baggage.value Element
v)) ((Token, Element) -> Header) -> [(Token, Element)] -> [Header]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HashMap Token Element -> [(Token, Element)]
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 :: OTLPExporterConfig -> m (Exporter ImmutableSpan)
otlpExporter OTLPExporterConfig
conf = do
  -- TODO, url parsing is janky
-- TODO configurable retryDelay, maximum retry counts
  Request
req <- 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
$ String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest (String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"http://localhost:4318/v1/traces" (String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/v1/traces") (OTLPExporterConfig -> Maybe String
otlpEndpoint OTLPExporterConfig
conf))

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

      baseReqHeaders :: [Header]
baseReqHeaders = [Header] -> [Header]
encodingHeader ([Header] -> [Header]) -> [Header] -> [Header]
forall a b. (a -> b) -> a -> b
$
        (CI ByteString
hContentType, ByteString
protobufMimeType) Header -> [Header] -> [Header]
forall a. a -> [a] -> [a]
:
        (CI ByteString
hAcceptEncoding, ByteString
protobufMimeType) Header -> [Header] -> [Header]
forall a. a -> [a] -> [a]
:
        [Header] -> Maybe [Header] -> [Header]
forall a. a -> Maybe a -> a
fromMaybe [] (OTLPExporterConfig -> Maybe [Header]
otlpHeaders OTLPExporterConfig
conf) [Header] -> [Header] -> [Header]
forall a. [a] -> [a] -> [a]
++
        [Header] -> Maybe [Header] -> [Header]
forall a. a -> Maybe a -> a
fromMaybe [] (OTLPExporterConfig -> Maybe [Header]
otlpTracesHeaders OTLPExporterConfig
conf) [Header] -> [Header] -> [Header]
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
        }
  Exporter ImmutableSpan -> m (Exporter ImmutableSpan)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exporter ImmutableSpan -> m (Exporter ImmutableSpan))
-> Exporter ImmutableSpan -> m (Exporter ImmutableSpan)
forall a b. (a -> b) -> a -> b
$ Exporter :: forall a.
(HashMap InstrumentationLibrary (Vector a) -> IO ExportResult)
-> IO () -> Exporter a
Exporter
    { exporterExport :: HashMap InstrumentationLibrary (Vector ImmutableSpan)
-> IO ExportResult
exporterExport = \HashMap InstrumentationLibrary (Vector ImmutableSpan)
spans_ -> do
        let anySpansToExport :: Bool
anySpansToExport = HashMap InstrumentationLibrary (Vector ImmutableSpan) -> Int
forall k v. HashMap k v -> Int
H.size HashMap InstrumentationLibrary (Vector ImmutableSpan)
spans_ Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0 Bool -> Bool -> Bool
&& Bool -> Bool
not ((Vector ImmutableSpan -> Bool) -> [Vector ImmutableSpan] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Vector ImmutableSpan -> Bool
forall a. Vector a -> Bool
V.null ([Vector ImmutableSpan] -> Bool) -> [Vector ImmutableSpan] -> Bool
forall a b. (a -> b) -> a -> b
$ HashMap InstrumentationLibrary (Vector ImmutableSpan)
-> [Vector ImmutableSpan]
forall k v. HashMap k v -> [v]
H.elems HashMap InstrumentationLibrary (Vector ImmutableSpan)
spans_)
        if Bool
anySpansToExport
          then do
            Either SomeException ExportResult
result <- IO ExportResult -> IO (Either SomeException ExportResult)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO ExportResult -> IO (Either SomeException ExportResult))
-> IO ExportResult -> IO (Either SomeException ExportResult)
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
                SomeException -> IO ()
forall a. Show a => a -> IO ()
print SomeException
err
                ExportResult -> IO ExportResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ExportResult -> IO ExportResult)
-> ExportResult -> IO ExportResult
forall a b. (a -> b) -> a -> b
$ Maybe SomeException -> ExportResult
Failure (Maybe SomeException -> ExportResult)
-> Maybe SomeException -> ExportResult
forall a b. (a -> b) -> a -> b
$ SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just SomeException
err
              Right ExportResult
ok -> ExportResult -> IO ExportResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure ExportResult
ok
          else ExportResult -> IO ExportResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure ExportResult
Success
    , exporterShutdown :: IO ()
exporterShutdown = () -> IO ()
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_ Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
status408 Bool -> Bool -> Bool
|| Status
status_ Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
status429 Bool -> Bool -> Bool
|| (Status -> Int
statusCode Status
status_ Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
500 Bool -> Bool -> Bool
&& Status -> Int
statusCode Status
status_ Int -> Int -> Bool
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 <- ExportTraceServiceRequest -> ByteString
forall msg. Message msg => msg -> ByteString
encodeMessage (ExportTraceServiceRequest -> ByteString)
-> IO ExportTraceServiceRequest -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HashMap InstrumentationLibrary (Vector ImmutableSpan)
-> IO ExportTraceServiceRequest
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 (ByteString -> RequestBody) -> ByteString -> RequestBody
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
encoder (ByteString -> ByteString) -> ByteString -> ByteString
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 <- IO (Response ByteString)
-> IO (Either HttpException (Response ByteString))
forall e a. Exception e => IO a -> IO (Either e a)
try (IO (Response ByteString)
 -> IO (Either HttpException (Response ByteString)))
-> IO (Response ByteString)
-> IO (Either HttpException (Response ByteString))
forall a b. (a -> b) -> a -> b
$ Request -> IO (Response ByteString)
forall (m :: * -> *).
MonadIO m =>
Request -> m (Response ByteString)
httpBS Request
req

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

      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 ExportResult -> IO ExportResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ExportResult -> IO ExportResult)
-> ExportResult -> IO ExportResult
forall a b. (a -> b) -> a -> b
$ Maybe SomeException -> ExportResult
Failure (Maybe SomeException -> ExportResult)
-> Maybe SomeException -> ExportResult
forall a b. (a -> b) -> a -> b
$ SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just (SomeException -> Maybe SomeException)
-> SomeException -> Maybe SomeException
forall a b. (a -> b) -> a -> b
$ HttpException -> SomeException
forall e. Exception e => e -> SomeException
SomeException HttpException
err
        Left HttpException
err -> ExportResult -> IO ExportResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ExportResult -> IO ExportResult)
-> ExportResult -> IO ExportResult
forall a b. (a -> b) -> a -> b
$ Maybe SomeException -> ExportResult
Failure (Maybe SomeException -> ExportResult)
-> Maybe SomeException -> ExportResult
forall a b. (a -> b) -> a -> b
$ SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just (SomeException -> Maybe SomeException)
-> SomeException -> Maybe SomeException
forall a b. (a -> b) -> a -> b
$ HttpException -> SomeException
forall e. Exception e => e -> SomeException
SomeException HttpException
err
        Right Response ByteString
resp -> if Status -> Bool
isRetryableStatusCode (Response ByteString -> Status
forall body. Response body -> Status
responseStatus Response ByteString
resp)
          then case CI ByteString -> [Header] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup CI ByteString
hRetryAfter ([Header] -> Maybe ByteString) -> [Header] -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Response ByteString -> [Header]
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 String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe Int) -> String -> Maybe Int
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1_000_000)
                  Request -> Int -> IO ExportResult
sendReq Request
req (Int
backoffCount Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)

          else ExportResult -> IO ExportResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ExportResult -> IO ExportResult)
-> ExportResult -> IO ExportResult
forall a b. (a -> b) -> a -> b
$! if Status -> Int
statusCode (Response ByteString -> Status
forall body. Response body -> Status
responseStatus Response ByteString
resp) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
300
            then Maybe SomeException -> ExportResult
Failure Maybe SomeException
forall a. Maybe a
Nothing
            else ExportResult
Success

attributesToProto :: Attributes -> Vector KeyValue
attributesToProto :: Attributes -> Vector KeyValue
attributesToProto =
  [KeyValue] -> Vector KeyValue
forall a. [a] -> Vector a
V.fromList ([KeyValue] -> Vector KeyValue)
-> (Attributes -> [KeyValue]) -> Attributes -> Vector KeyValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  ((Text, Attribute) -> KeyValue)
-> [(Text, Attribute)] -> [KeyValue]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text, Attribute) -> KeyValue
attributeToKeyValue ([(Text, Attribute)] -> [KeyValue])
-> (Attributes -> [(Text, Attribute)]) -> Attributes -> [KeyValue]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  HashMap Text Attribute -> [(Text, Attribute)]
forall k v. HashMap k v -> [(k, v)]
H.toList (HashMap Text Attribute -> [(Text, Attribute)])
-> (Attributes -> HashMap Text Attribute)
-> Attributes
-> [(Text, Attribute)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  (Int, HashMap Text Attribute) -> HashMap Text Attribute
forall a b. (a, b) -> b
snd ((Int, HashMap Text Attribute) -> HashMap Text Attribute)
-> (Attributes -> (Int, HashMap Text Attribute))
-> Attributes
-> HashMap Text Attribute
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 -> AnyValue
forall msg. Message msg => msg
defMessage AnyValue -> (AnyValue -> AnyValue) -> AnyValue
forall a b. a -> (a -> b) -> b
& LensLike' Identity AnyValue Text
forall (f :: * -> *) s a.
(Functor f, HasField s "stringValue" a) =>
LensLike' f s a
stringValue LensLike' Identity AnyValue Text -> Text -> AnyValue -> AnyValue
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Text
t
      BoolAttribute Bool
b -> AnyValue
forall msg. Message msg => msg
defMessage AnyValue -> (AnyValue -> AnyValue) -> AnyValue
forall a b. a -> (a -> b) -> b
& LensLike' Identity AnyValue Bool
forall (f :: * -> *) s a.
(Functor f, HasField s "boolValue" a) =>
LensLike' f s a
boolValue LensLike' Identity AnyValue Bool -> Bool -> AnyValue -> AnyValue
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
b
      DoubleAttribute Double
d -> AnyValue
forall msg. Message msg => msg
defMessage AnyValue -> (AnyValue -> AnyValue) -> AnyValue
forall a b. a -> (a -> b) -> b
& LensLike' Identity AnyValue Double
forall (f :: * -> *) s a.
(Functor f, HasField s "doubleValue" a) =>
LensLike' f s a
doubleValue LensLike' Identity AnyValue Double
-> Double -> AnyValue -> AnyValue
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Double
d
      IntAttribute Int64
i -> AnyValue
forall msg. Message msg => msg
defMessage AnyValue -> (AnyValue -> AnyValue) -> AnyValue
forall a b. a -> (a -> b) -> b
& LensLike' Identity AnyValue Int64
forall (f :: * -> *) s a.
(Functor f, HasField s "intValue" a) =>
LensLike' f s a
intValue LensLike' Identity AnyValue Int64 -> Int64 -> AnyValue -> AnyValue
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) = KeyValue
forall msg. Message msg => msg
defMessage
      KeyValue -> (KeyValue -> KeyValue) -> KeyValue
forall a b. a -> (a -> b) -> b
& LensLike' Identity KeyValue Text
forall (f :: * -> *) s a.
(Functor f, HasField s "key" a) =>
LensLike' f s a
key LensLike' Identity KeyValue Text -> Text -> KeyValue -> KeyValue
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Text
k
      KeyValue -> (KeyValue -> KeyValue) -> KeyValue
forall a b. a -> (a -> b) -> b
& LensLike' Identity KeyValue AnyValue
forall (f :: * -> *) s a.
(Functor f, HasField s "value" a) =>
LensLike' f s a
value LensLike' Identity KeyValue AnyValue
-> AnyValue -> KeyValue -> KeyValue
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 -> AnyValue
forall msg. Message msg => msg
defMessage
          AnyValue -> (AnyValue -> AnyValue) -> AnyValue
forall a b. a -> (a -> b) -> b
& LensLike' Identity AnyValue ArrayValue
forall (f :: * -> *) s a.
(Functor f, HasField s "arrayValue" a) =>
LensLike' f s a
arrayValue LensLike' Identity AnyValue ArrayValue
-> ArrayValue -> AnyValue -> AnyValue
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (ArrayValue
forall msg. Message msg => msg
defMessage ArrayValue -> (ArrayValue -> ArrayValue) -> ArrayValue
forall a b. a -> (a -> b) -> b
& LensLike' Identity ArrayValue [AnyValue]
forall (f :: * -> *) s a.
(Functor f, HasField s "values" a) =>
LensLike' f s a
values LensLike' Identity ArrayValue [AnyValue]
-> [AnyValue] -> ArrayValue -> ArrayValue
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (PrimitiveAttribute -> AnyValue)
-> [PrimitiveAttribute] -> [AnyValue]
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 :: HashMap InstrumentationLibrary (Vector ImmutableSpan)
-> m ExportTraceServiceRequest
immutableSpansToProtobuf HashMap InstrumentationLibrary (Vector ImmutableSpan)
completedSpans = do
  [InstrumentationLibrarySpans]
spansByLibrary <- ((InstrumentationLibrary, Vector ImmutableSpan)
 -> m InstrumentationLibrarySpans)
-> [(InstrumentationLibrary, Vector ImmutableSpan)]
-> m [InstrumentationLibrarySpans]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (InstrumentationLibrary, Vector ImmutableSpan)
-> m InstrumentationLibrarySpans
forall (m :: * -> *).
MonadIO m =>
(InstrumentationLibrary, Vector ImmutableSpan)
-> m InstrumentationLibrarySpans
makeInstrumentationLibrarySpans [(InstrumentationLibrary, Vector ImmutableSpan)]
spanGroupList
  ExportTraceServiceRequest -> m ExportTraceServiceRequest
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ExportTraceServiceRequest -> m ExportTraceServiceRequest)
-> ExportTraceServiceRequest -> m ExportTraceServiceRequest
forall a b. (a -> b) -> a -> b
$ ExportTraceServiceRequest
forall msg. Message msg => msg
defMessage
    ExportTraceServiceRequest
-> (ExportTraceServiceRequest -> ExportTraceServiceRequest)
-> ExportTraceServiceRequest
forall a b. a -> (a -> b) -> b
& LensLike' Identity ExportTraceServiceRequest (Vector ResourceSpans)
forall (f :: * -> *) s a.
(Functor f, HasField s "vec'resourceSpans" a) =>
LensLike' f s a
vec'resourceSpans LensLike' Identity ExportTraceServiceRequest (Vector ResourceSpans)
-> Vector ResourceSpans
-> ExportTraceServiceRequest
-> ExportTraceServiceRequest
forall s t a b. ASetter s t a b -> b -> s -> t
.~
      ResourceSpans -> Vector ResourceSpans
forall a. a -> Vector a
Vector.singleton
        ( ResourceSpans
forall msg. Message msg => msg
defMessage
            ResourceSpans -> (ResourceSpans -> ResourceSpans) -> ResourceSpans
forall a b. a -> (a -> b) -> b
& LensLike' Identity ResourceSpans Resource
forall (f :: * -> *) s a.
(Functor f, HasField s "resource" a) =>
LensLike' f s a
resource LensLike' Identity ResourceSpans Resource
-> Resource -> ResourceSpans -> ResourceSpans
forall s t a b. ASetter s t a b -> b -> s -> t
.~
              ( Resource
forall msg. Message msg => msg
defMessage
                  Resource -> (Resource -> Resource) -> Resource
forall a b. a -> (a -> b) -> b
& LensLike' Identity Resource (Vector KeyValue)
forall (f :: * -> *) s a.
(Functor f, HasField s "vec'attributes" a) =>
LensLike' f s a
vec'attributes LensLike' Identity Resource (Vector KeyValue)
-> Vector KeyValue -> Resource -> Resource
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Attributes -> Vector KeyValue
attributesToProto (MaterializedResources -> Attributes
getMaterializedResourcesAttributes MaterializedResources
someResourceGroup)
                  -- TODO
                  Resource -> (Resource -> Resource) -> Resource
forall a b. a -> (a -> b) -> b
& LensLike' Identity Resource Word32
forall (f :: * -> *) s a.
(Functor f, HasField s "droppedAttributesCount" a) =>
LensLike' f s a
droppedAttributesCount LensLike' Identity Resource Word32
-> Word32 -> Resource -> Resource
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
            ResourceSpans -> (ResourceSpans -> ResourceSpans) -> ResourceSpans
forall a b. a -> (a -> b) -> b
& LensLike' Identity ResourceSpans [InstrumentationLibrarySpans]
forall (f :: * -> *) s a.
(Functor f, HasField s "instrumentationLibrarySpans" a) =>
LensLike' f s a
instrumentationLibrarySpans LensLike' Identity ResourceSpans [InstrumentationLibrarySpans]
-> [InstrumentationLibrarySpans] -> ResourceSpans -> ResourceSpans
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 Vector ImmutableSpan -> Int -> Maybe ImmutableSpan
forall a. Vector a -> Int -> Maybe a
V.!? Int
0 of
        Maybe ImmutableSpan
Nothing -> MaterializedResources
emptyMaterializedResources
        Just ImmutableSpan
s -> TracerProvider -> MaterializedResources
OT.getTracerProviderResources (TracerProvider -> MaterializedResources)
-> TracerProvider -> MaterializedResources
forall a b. (a -> b) -> a -> b
$ Tracer -> TracerProvider
OT.getTracerTracerProvider (Tracer -> TracerProvider) -> Tracer -> TracerProvider
forall a b. (a -> b) -> a -> b
$ ImmutableSpan -> Tracer
OT.spanTracer ImmutableSpan
s

    spanGroupList :: [(InstrumentationLibrary, Vector ImmutableSpan)]
spanGroupList = HashMap InstrumentationLibrary (Vector ImmutableSpan)
-> [(InstrumentationLibrary, Vector ImmutableSpan)]
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 :: (InstrumentationLibrary, Vector ImmutableSpan)
-> m InstrumentationLibrarySpans
makeInstrumentationLibrarySpans (InstrumentationLibrary
library, Vector ImmutableSpan
completedSpans_) = do
      Vector Span
spans_ <- (ImmutableSpan -> m Span)
-> Vector ImmutableSpan -> m (Vector Span)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ImmutableSpan -> m Span
forall (m :: * -> *). MonadIO m => ImmutableSpan -> m Span
makeSpan Vector ImmutableSpan
completedSpans_
      InstrumentationLibrarySpans -> m InstrumentationLibrarySpans
forall (f :: * -> *) a. Applicative f => a -> f a
pure (InstrumentationLibrarySpans -> m InstrumentationLibrarySpans)
-> InstrumentationLibrarySpans -> m InstrumentationLibrarySpans
forall a b. (a -> b) -> a -> b
$ InstrumentationLibrarySpans
forall msg. Message msg => msg
defMessage
        InstrumentationLibrarySpans
-> (InstrumentationLibrarySpans -> InstrumentationLibrarySpans)
-> InstrumentationLibrarySpans
forall a b. a -> (a -> b) -> b
& LensLike'
  Identity InstrumentationLibrarySpans InstrumentationLibrary
forall (f :: * -> *) s a.
(Functor f, HasField s "instrumentationLibrary" a) =>
LensLike' f s a
instrumentationLibrary LensLike'
  Identity InstrumentationLibrarySpans InstrumentationLibrary
-> InstrumentationLibrary
-> InstrumentationLibrarySpans
-> InstrumentationLibrarySpans
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (
            InstrumentationLibrary
forall msg. Message msg => msg
defMessage
              InstrumentationLibrary
-> (InstrumentationLibrary -> InstrumentationLibrary)
-> InstrumentationLibrary
forall a b. a -> (a -> b) -> b
& LensLike' Identity InstrumentationLibrary Text
forall (f :: * -> *) s a.
(Functor f, HasField s "name" a) =>
LensLike' f s a
Proto.Opentelemetry.Proto.Trace.V1.Trace_Fields.name LensLike' Identity InstrumentationLibrary Text
-> Text -> InstrumentationLibrary -> InstrumentationLibrary
forall s t a b. ASetter s t a b -> b -> s -> t
.~ InstrumentationLibrary -> Text
OT.libraryName InstrumentationLibrary
library
              InstrumentationLibrary
-> (InstrumentationLibrary -> InstrumentationLibrary)
-> InstrumentationLibrary
forall a b. a -> (a -> b) -> b
& LensLike' Identity InstrumentationLibrary Text
forall (f :: * -> *) s a.
(Functor f, HasField s "version" a) =>
LensLike' f s a
version LensLike' Identity InstrumentationLibrary Text
-> Text -> InstrumentationLibrary -> InstrumentationLibrary
forall s t a b. ASetter s t a b -> b -> s -> t
.~ InstrumentationLibrary -> Text
OT.libraryVersion InstrumentationLibrary
library
          )
        InstrumentationLibrarySpans
-> (InstrumentationLibrarySpans -> InstrumentationLibrarySpans)
-> InstrumentationLibrarySpans
forall a b. a -> (a -> b) -> b
& LensLike' Identity InstrumentationLibrarySpans (Vector Span)
forall (f :: * -> *) s a.
(Functor f, HasField s "vec'spans" a) =>
LensLike' f s a
vec'spans LensLike' Identity InstrumentationLibrarySpans (Vector Span)
-> Vector Span
-> InstrumentationLibrarySpans
-> InstrumentationLibrarySpans
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 :: 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 -> (Span -> Span) -> m (Span -> Span)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Span -> Span
forall a. a -> a
id
      Just Span
s -> do
        SpanId
spanCtxt <- SpanContext -> SpanId
OT.spanId (SpanContext -> SpanId) -> m SpanContext -> m SpanId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Span -> m SpanContext
forall (m :: * -> *). MonadIO m => Span -> m SpanContext
OT.getSpanContext Span
s
        (Span -> Span) -> m (Span -> Span)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (\Span
otlpSpan -> Span
otlpSpan Span -> (Span -> Span) -> Span
forall a b. a -> (a -> b) -> b
& LensLike' Identity Span ByteString
forall (f :: * -> *) s a.
(Functor f, HasField s "parentSpanId" a) =>
LensLike' f s a
parentSpanId LensLike' Identity Span ByteString -> ByteString -> Span -> Span
forall s t a b. ASetter s t a b -> b -> s -> t
.~ SpanId -> ByteString
spanIdBytes SpanId
spanCtxt)

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

makeEvent :: OT.Event -> Span'Event
makeEvent :: Event -> Span'Event
makeEvent Event
e = Span'Event
forall msg. Message msg => msg
defMessage
  Span'Event -> (Span'Event -> Span'Event) -> Span'Event
forall a b. a -> (a -> b) -> b
& LensLike' Identity Span'Event Word64
forall (f :: * -> *) s a.
(Functor f, HasField s "timeUnixNano" a) =>
LensLike' f s a
timeUnixNano LensLike' Identity Span'Event Word64
-> Word64 -> Span'Event -> Span'Event
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Timestamp -> Word64
timestampNanoseconds (Event -> Timestamp
OT.eventTimestamp Event
e)
  Span'Event -> (Span'Event -> Span'Event) -> Span'Event
forall a b. a -> (a -> b) -> b
& LensLike' Identity Span'Event Text
forall (f :: * -> *) s a.
(Functor f, HasField s "name" a) =>
LensLike' f s a
Proto.Opentelemetry.Proto.Trace.V1.Trace_Fields.name LensLike' Identity Span'Event Text
-> Text -> Span'Event -> Span'Event
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Event -> Text
OT.eventName Event
e
  Span'Event -> (Span'Event -> Span'Event) -> Span'Event
forall a b. a -> (a -> b) -> b
& LensLike' Identity Span'Event (Vector KeyValue)
forall (f :: * -> *) s a.
(Functor f, HasField s "vec'attributes" a) =>
LensLike' f s a
vec'attributes LensLike' Identity Span'Event (Vector KeyValue)
-> Vector KeyValue -> Span'Event -> Span'Event
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Attributes -> Vector KeyValue
attributesToProto (Event -> Attributes
OT.eventAttributes Event
e)
  Span'Event -> (Span'Event -> Span'Event) -> Span'Event
forall a b. a -> (a -> b) -> b
& LensLike' Identity Span'Event Word32
forall (f :: * -> *) s a.
(Functor f, HasField s "droppedAttributesCount" a) =>
LensLike' f s a
droppedAttributesCount LensLike' Identity Span'Event Word32
-> Word32 -> Span'Event -> Span'Event
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Int, HashMap Text Attribute) -> Int
forall a b. (a, b) -> a
fst (Attributes -> (Int, HashMap Text Attribute)
getAttributes (Attributes -> (Int, HashMap Text Attribute))
-> Attributes -> (Int, HashMap Text Attribute)
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 = Span'Link
forall msg. Message msg => msg
defMessage
  Span'Link -> (Span'Link -> Span'Link) -> Span'Link
forall a b. a -> (a -> b) -> b
& LensLike' Identity Span'Link ByteString
forall (f :: * -> *) s a.
(Functor f, HasField s "traceId" a) =>
LensLike' f s a
traceId LensLike' Identity Span'Link ByteString
-> ByteString -> Span'Link -> Span'Link
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TraceId -> ByteString
traceIdBytes (SpanContext -> TraceId
OT.traceId (SpanContext -> TraceId) -> SpanContext -> TraceId
forall a b. (a -> b) -> a -> b
$ Link -> SpanContext
OT.frozenLinkContext Link
l)
  Span'Link -> (Span'Link -> Span'Link) -> Span'Link
forall a b. a -> (a -> b) -> b
& LensLike' Identity Span'Link ByteString
forall (f :: * -> *) s a.
(Functor f, HasField s "spanId" a) =>
LensLike' f s a
spanId LensLike' Identity Span'Link ByteString
-> ByteString -> Span'Link -> Span'Link
forall s t a b. ASetter s t a b -> b -> s -> t
.~ SpanId -> ByteString
spanIdBytes (SpanContext -> SpanId
OT.spanId (SpanContext -> SpanId) -> SpanContext -> SpanId
forall a b. (a -> b) -> a -> b
$ Link -> SpanContext
OT.frozenLinkContext Link
l)
  Span'Link -> (Span'Link -> Span'Link) -> Span'Link
forall a b. a -> (a -> b) -> b
& LensLike' Identity Span'Link (Vector KeyValue)
forall (f :: * -> *) s a.
(Functor f, HasField s "vec'attributes" a) =>
LensLike' f s a
vec'attributes LensLike' Identity Span'Link (Vector KeyValue)
-> Vector KeyValue -> Span'Link -> Span'Link
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Attributes -> Vector KeyValue
attributesToProto (Link -> Attributes
OT.frozenLinkAttributes Link
l)
  Span'Link -> (Span'Link -> Span'Link) -> Span'Link
forall a b. a -> (a -> b) -> b
& LensLike' Identity Span'Link Word32
forall (f :: * -> *) s a.
(Functor f, HasField s "droppedAttributesCount" a) =>
LensLike' f s a
droppedAttributesCount LensLike' Identity Span'Link Word32
-> Word32 -> Span'Link -> Span'Link
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Int, HashMap Text Attribute) -> Int
forall a b. (a, b) -> a
fst (Attributes -> (Int, HashMap Text Attribute)
getAttributes (Attributes -> (Int, HashMap Text Attribute))
-> Attributes -> (Int, HashMap Text Attribute)
forall a b. (a -> b) -> a -> b
$ Link -> Attributes
OT.frozenLinkAttributes Link
l))