{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
module OTel.SDK.Trace.Internal
  ( -- * Disclaimer
    -- $disclaimer
    TracerProviderSpec(..)
  , defaultTracerProviderSpec
  , withTracerProvider
  , withTracerProviderIO

  , SpanProcessor(..)
  , buildSpanProcessor
  , SimpleSpanProcessorSpec(..)
  , defaultSimpleSpanProcessorSpec
  , simpleSpanProcessor
  , SpanProcessorSpec(..)
  , defaultSpanProcessorSpec

  , SpanExportResult(..)
  , SpanExporter(..)
  , buildSpanExporter
  , OTLPSpanExporterSpec(..)
  , defaultOTLPSpanExporterSpec
  , otlpSpanExporter
  , OTLPProtocol(..)
  , httpProtobufProtocol
  , OTLPSpanExporterItem(..)
  , stmSpanExporter
  , SpanExporterSpec(..)
  , defaultSpanExporterSpec

  , Sampler(..)
  , buildSampler
  , SamplerSpec(..)
  , defaultSamplerSpec
  , alwaysOnSampler
  , alwaysOffSampler
  , ParentBasedSamplerSpec(..)
  , defaultParentBasedSamplerSpec
  , parentBasedSampler
  , constDecisionSampler
  , SamplerInput(..)
  , SamplingResult(..)
  , defaultSamplingResult
  , SamplingDecision(..)
  , samplingDecisionDrop
  , samplingDecisionRecordOnly
  , samplingDecisionRecordAndSample

  , SpanProcessorM(..)
  , askSpanExporter
  , runSpanProcessorM

  , SpanExporterM(..)
  , askResource
  , runSpanExporterM

  , SamplerM(..)
  , runSamplerM

  , IdGeneratorM(..)
  , runIdGeneratorM
  , IdGenerator(..)
  , buildIdGenerator
  , IdGeneratorSpec(..)
  , defaultIdGeneratorSpec
  , PRNG(..)
  , genUniform
  , newPRNGRef

  , OnException(..)
  , askException
  , askExceptionMetadata

  , OnTimeout(..)
  , askTimeoutMicros
  , askTimeoutMetadata

  , OnSpansExported(..)
  , askSpansExported
  , askSpansExportedResult
  , askSpansExportedMetadata

  , Batch(..)
  , singletonBatch
  , fromListBatch

  , ConcurrentWorkersSpec(..)
  , defaultConcurrentWorkersSpec
  , ConcurrentWorkers(..)
  , withConcurrentWorkers

  , unlessSTM

  , withAll

  , defaultSystemSeed
  , defaultManager

  , spanSummary

  , redactHttpExceptionHeaders
  ) where

#if MIN_VERSION_base(4,18,0)
import Control.Applicative (Alternative(..))
#else
import Control.Applicative (Alternative(..), Applicative(..))
#endif

import Control.Concurrent (MVar, newMVar, withMVar)
import Control.Concurrent.Async (Async, waitCatch, withAsync)
import Control.Concurrent.STM (STM, atomically, newTVarIO, readTVar, writeTVar)
import Control.Concurrent.STM.TBMQueue
  ( TBMQueue, closeTBMQueue, isClosedTBMQueue, newTBMQueueIO, readTBMQueue, tryWriteTBMQueue
  )
import Control.Concurrent.STM.TMQueue (TMQueue, closeTMQueue, writeTMQueue)
import Control.Exception (AsyncException, SomeAsyncException, evaluate)
import Control.Exception.Safe
  ( Exception(..), Handler(..), SomeException(..), MonadCatch, MonadMask, MonadThrow, catchAny
  , finally, throwM
  )
import Control.Monad (join, when)
import Control.Monad.Cont (ContT(..), cont, runCont)
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.IO.Unlift (MonadUnliftIO(..))
import Control.Monad.Logger.Aeson
  ( LoggingT(..), Message(..), MonadLoggerIO(..), (.=), MonadLogger, SeriesElem, logDebug, logError
  )
import Control.Monad.Reader (ReaderT(..))
import Control.Retry
  ( RetryAction(..), RetryPolicyM, RetryStatus, applyPolicy, fullJitterBackoff, limitRetries
  , recoveringDynamic
  )
import Data.Aeson (ToJSON(..), Value, object)
import Data.Aeson.Types (Pair)
import Data.ByteString.Lazy (ByteString)
import Data.Either (fromRight)
import Data.Foldable (fold, for_, traverse_)
import Data.Function (on)
import Data.Int (Int64)
import Data.Kind (Type)
import Data.Maybe (fromJust, fromMaybe, mapMaybe)
import Data.Monoid (Ap(..))
import Data.Proxy (Proxy(..))
import Data.Set (Set)
import Data.Text (Text, pack)
import Data.Time
  ( NominalDiffTime, UTCTime, defaultTimeLocale, diffUTCTime, getCurrentTime, parseTimeM
  )
import Data.Traversable (for)
import Data.Typeable (Typeable, typeRep)
import Data.Vector (Vector)
import GHC.Stack (SrcLoc(..), CallStack)
import Lens.Micro ((&), (.~))
import Network.HTTP.Client
  ( HttpException(..), HttpExceptionContent(..), Request(..), RequestBody(..), Response(..), Manager
  , httpLbs, requestFromURI, setRequestCheckStatus
  )
import Network.HTTP.Client.Internal (responseOriginalRequest)
import Network.HTTP.Client.TLS (newTlsManager)
import Network.HTTP.Types
  ( Status(..), Header, badGateway502, gatewayTimeout504, serviceUnavailable503, tooManyRequests429
  )
import Network.HTTP.Types.Header (HeaderName, hContentType, hRetryAfter)
import Network.URI (URI(..), parseURI)
import OTel.API.Common
  ( Attr(..), AttrType(..), AttrsFor(..), InstrumentationScope(..)
  , InstrumentationScopeName(unInstrumentationScopeName), KV((.@)), Key(unKey), TimestampSource(..)
  , Version(..), AttrVals, Attrs, AttrsBuilder, AttrsLimits, Logger, Timestamp, askException
  , askExceptionMetadata, askTimeoutMetadata, askTimeoutMicros, defaultAttrsLimits
  , droppedAttrsCount, foldMapWithKeyAttrs, schemaURLToText, timestampFromNanoseconds
  , timestampToNanoseconds, with
  )
import OTel.API.Common.Internal
  ( AttrVals(..), InstrumentationScope(..), OnException(..), OnTimeout(..)
  )
import OTel.API.Context.Core (Context, lookupContext)
import OTel.API.Trace
  ( Span(..), SpanContext(..), SpanEvent(..), SpanEventName(..), SpanKind(..), SpanLineage(..)
  , SpanLink(..), SpanName(unSpanName), SpanSpec(..), SpanStatus(..), MutableSpan, SpanId, SpanLinks
  , TraceId, TraceState, Tracer, TracerProvider, UpdateSpanSpec, contextKeySpan, emptySpanContext
  , emptyTraceState, frozenTimestamp, spanContextIsSampled, spanContextIsValid, spanEventsToList
  , spanIdFromWords, spanIdToBytesBuilder, spanIsSampled, spanLinksToList, traceFlagsSampled
  , traceIdFromWords, traceIdToBytesBuilder, pattern CODE_FILEPATH, pattern CODE_FUNCTION
  , pattern CODE_LINENO, pattern CODE_NAMESPACE
  )
import OTel.API.Trace.Core.Internal
  ( Span(..), SpanContext(..), SpanLinkSpec(..), SpanLinkSpecs(..), SpanLinks(..), SpanSpec(..)
  , Tracer(..), TracerProvider(..), buildSpanUpdater, freezeSpan, unsafeModifyMutableSpan
  , unsafeNewMutableSpan, unsafeReadMutableSpan
  )
import OTel.SDK.Resource.Core (buildResourcePure, defaultResourceBuilder)
import OTel.SDK.Resource.Core.Internal (Resource(..))
import Prelude hiding (span)
import System.Clock (Clock(Realtime), getTime, toNanoSecs)
import System.IO.Unsafe (unsafePerformIO)
import System.Random.MWC (Variate(..), GenIO, Seed, createSystemSeed, fromSeed, initialize, uniform)
import System.Timeout (timeout)
import qualified Data.ByteString.Builder as Builder
import qualified Data.ByteString.Char8 as ByteString.Char8
import qualified Data.DList as DList
import qualified Data.List as List
import qualified Data.ProtoLens as ProtoLens
import qualified Data.Set as Set
import qualified GHC.Stack as Stack
import qualified OTel.SDK.OTLP.Bindings.Collector.Trace.V1.TraceService as OTLP.Collector
import qualified OTel.SDK.OTLP.Bindings.Collector.Trace.V1.TraceService_Fields as OTLP.Collector
import qualified OTel.SDK.OTLP.Bindings.Common.V1.Common as OTLP.Common
import qualified OTel.SDK.OTLP.Bindings.Common.V1.Common_Fields as OTLP.Common
import qualified OTel.SDK.OTLP.Bindings.Resource.V1.Resource as OTLP.Resource
import qualified OTel.SDK.OTLP.Bindings.Resource.V1.Resource_Fields as OTLP.Resource
import qualified OTel.SDK.OTLP.Bindings.Trace.V1.Trace as OTLP.Trace
import qualified OTel.SDK.OTLP.Bindings.Trace.V1.Trace_Fields as OTLP.Trace

data TracerProviderSpec = TracerProviderSpec
  { TracerProviderSpec -> IO Timestamp
tracerProviderSpecNow :: IO Timestamp
  , TracerProviderSpec -> Logger
tracerProviderSpecLogger :: Logger
  , TracerProviderSpec -> Seed
tracerProviderSpecSeed :: Seed
  , TracerProviderSpec
-> forall a. Logger -> (IdGeneratorSpec -> IO a) -> IO a
tracerProviderSpecIdGenerator
      :: forall a. Logger -> (IdGeneratorSpec -> IO a) -> IO a
  , TracerProviderSpec
-> forall a. [Logger -> (SpanProcessorSpec -> IO a) -> IO a]
tracerProviderSpecSpanProcessors
      :: forall a. [Logger -> (SpanProcessorSpec -> IO a) -> IO a]
  , TracerProviderSpec
-> forall a. Logger -> (SamplerSpec -> IO a) -> IO a
tracerProviderSpecSampler
      :: forall a. Logger -> (SamplerSpec -> IO a) -> IO a
  , TracerProviderSpec -> Resource Attrs
tracerProviderSpecResource :: Resource Attrs
  , TracerProviderSpec -> AttrsLimits 'AttrsForSpan
tracerProviderSpecSpanAttrsLimits :: AttrsLimits 'AttrsForSpan
  , TracerProviderSpec -> AttrsLimits 'AttrsForSpanEvent
tracerProviderSpecSpanEventAttrsLimits :: AttrsLimits 'AttrsForSpanEvent
  , TracerProviderSpec -> AttrsLimits 'AttrsForSpanLink
tracerProviderSpecSpanLinkAttrsLimits :: AttrsLimits 'AttrsForSpanLink
  , TracerProviderSpec -> CallStack -> AttrsBuilder 'AttrsForSpan
tracerProviderSpecCallStackAttrs :: CallStack -> AttrsBuilder 'AttrsForSpan
  , TracerProviderSpec -> SpanContext -> [Pair]
tracerProviderSpecSpanContextMeta :: SpanContext -> [Pair]
  }

defaultTracerProviderSpec :: TracerProviderSpec
defaultTracerProviderSpec :: TracerProviderSpec
defaultTracerProviderSpec =
  TracerProviderSpec
    { tracerProviderSpecNow :: IO Timestamp
tracerProviderSpecNow =
        (TimeSpec -> Timestamp) -> IO TimeSpec -> IO Timestamp
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Integer -> Timestamp
timestampFromNanoseconds (Integer -> Timestamp)
-> (TimeSpec -> Integer) -> TimeSpec -> Timestamp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeSpec -> Integer
toNanoSecs) (IO TimeSpec -> IO Timestamp) -> IO TimeSpec -> IO Timestamp
forall a b. (a -> b) -> a -> b
$ Clock -> IO TimeSpec
getTime Clock
Realtime
    , tracerProviderSpecLogger :: Logger
tracerProviderSpecLogger = Logger
forall a. Monoid a => a
mempty
    , tracerProviderSpecSeed :: Seed
tracerProviderSpecSeed = Seed
defaultSystemSeed
    , tracerProviderSpecIdGenerator :: forall a. Logger -> (IdGeneratorSpec -> IO a) -> IO a
tracerProviderSpecIdGenerator = \Logger
_logger -> IdGeneratorSpec -> (IdGeneratorSpec -> IO a) -> IO a
forall a b. a -> (a -> b) -> b
with IdGeneratorSpec
defaultIdGeneratorSpec
    , tracerProviderSpecSpanProcessors :: forall a. [Logger -> (SpanProcessorSpec -> IO a) -> IO a]
tracerProviderSpecSpanProcessors = [Logger -> (SpanProcessorSpec -> IO a) -> IO a]
forall a. [Logger -> (SpanProcessorSpec -> IO a) -> IO a]
forall a. Monoid a => a
mempty
    , tracerProviderSpecSampler :: forall a. Logger -> (SamplerSpec -> IO a) -> IO a
tracerProviderSpecSampler = \Logger
_logger -> SamplerSpec -> (SamplerSpec -> IO a) -> IO a
forall a b. a -> (a -> b) -> b
with SamplerSpec
defaultSamplerSpec
    , tracerProviderSpecResource :: Resource Attrs
tracerProviderSpecResource =
        Resource Attrs
-> Either ResourceMergeError (Resource Attrs) -> Resource Attrs
forall b a. b -> Either a b -> b
fromRight ([Char] -> Resource Attrs
forall a. HasCallStack => [Char] -> a
error [Char]
"defaultTracerProviderSpec: defaultResource is never a Left") (Either ResourceMergeError (Resource Attrs) -> Resource Attrs)
-> Either ResourceMergeError (Resource Attrs) -> Resource Attrs
forall a b. (a -> b) -> a -> b
$
          ResourceBuilder -> Either ResourceMergeError (Resource Attrs)
buildResourcePure (ResourceBuilder -> Either ResourceMergeError (Resource Attrs))
-> ResourceBuilder -> Either ResourceMergeError (Resource Attrs)
forall a b. (a -> b) -> a -> b
$ Text -> ResourceBuilder
defaultResourceBuilder Text
"unknown_service"
    , tracerProviderSpecSpanAttrsLimits :: AttrsLimits 'AttrsForSpan
tracerProviderSpecSpanAttrsLimits = AttrsLimits 'AttrsForSpan
forall (af :: AttrsFor). AttrsLimits af
defaultAttrsLimits
    , tracerProviderSpecSpanEventAttrsLimits :: AttrsLimits 'AttrsForSpanEvent
tracerProviderSpecSpanEventAttrsLimits = AttrsLimits 'AttrsForSpanEvent
forall (af :: AttrsFor). AttrsLimits af
defaultAttrsLimits
    , tracerProviderSpecSpanLinkAttrsLimits :: AttrsLimits 'AttrsForSpanLink
tracerProviderSpecSpanLinkAttrsLimits = AttrsLimits 'AttrsForSpanLink
forall (af :: AttrsFor). AttrsLimits af
defaultAttrsLimits
    , tracerProviderSpecCallStackAttrs :: CallStack -> AttrsBuilder 'AttrsForSpan
tracerProviderSpecCallStackAttrs = \CallStack
cs ->
        case CallStack -> [([Char], SrcLoc)]
Stack.getCallStack CallStack
cs of
          (([Char]
function, SrcLoc
srcLoc) : [([Char], SrcLoc)]
_) ->
            Key Text
CODE_FUNCTION Key Text -> [Char] -> AttrsBuilder 'AttrsForSpan
forall kv from to.
(KV kv, KVConstraints kv from to) =>
Key to -> from -> kv
forall from to.
KVConstraints (AttrsBuilder 'AttrsForSpan) from to =>
Key to -> from -> AttrsBuilder 'AttrsForSpan
.@ [Char]
function
              AttrsBuilder 'AttrsForSpan
-> AttrsBuilder 'AttrsForSpan -> AttrsBuilder 'AttrsForSpan
forall a. Semigroup a => a -> a -> a
<> Key Text
CODE_NAMESPACE Key Text -> [Char] -> AttrsBuilder 'AttrsForSpan
forall kv from to.
(KV kv, KVConstraints kv from to) =>
Key to -> from -> kv
forall from to.
KVConstraints (AttrsBuilder 'AttrsForSpan) from to =>
Key to -> from -> AttrsBuilder 'AttrsForSpan
.@ SrcLoc -> [Char]
srcLocModule SrcLoc
srcLoc
              AttrsBuilder 'AttrsForSpan
-> AttrsBuilder 'AttrsForSpan -> AttrsBuilder 'AttrsForSpan
forall a. Semigroup a => a -> a -> a
<> Key Text
CODE_FILEPATH Key Text -> [Char] -> AttrsBuilder 'AttrsForSpan
forall kv from to.
(KV kv, KVConstraints kv from to) =>
Key to -> from -> kv
forall from to.
KVConstraints (AttrsBuilder 'AttrsForSpan) from to =>
Key to -> from -> AttrsBuilder 'AttrsForSpan
.@ SrcLoc -> [Char]
srcLocFile SrcLoc
srcLoc
              AttrsBuilder 'AttrsForSpan
-> AttrsBuilder 'AttrsForSpan -> AttrsBuilder 'AttrsForSpan
forall a. Semigroup a => a -> a -> a
<> Key Int64
CODE_LINENO Key Int64 -> Int -> AttrsBuilder 'AttrsForSpan
forall kv from to.
(KV kv, KVConstraints kv from to) =>
Key to -> from -> kv
forall from to.
KVConstraints (AttrsBuilder 'AttrsForSpan) from to =>
Key to -> from -> AttrsBuilder 'AttrsForSpan
.@ SrcLoc -> Int
srcLocStartLine SrcLoc
srcLoc
          [([Char], SrcLoc)]
_ -> AttrsBuilder 'AttrsForSpan
forall a. Monoid a => a
mempty
    , tracerProviderSpecSpanContextMeta :: SpanContext -> [Pair]
tracerProviderSpecSpanContextMeta = \SpanContext
spanContext ->
        [ Key
"spanContext" Key -> SpanContext -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= SpanContext
spanContext ]
    }

withTracerProvider
  :: forall m a
   . (MonadUnliftIO m)
  => TracerProviderSpec
  -> (TracerProvider -> m a)
  -> m a
withTracerProvider :: forall (m :: * -> *) a.
MonadUnliftIO m =>
TracerProviderSpec -> (TracerProvider -> m a) -> m a
withTracerProvider TracerProviderSpec
spec TracerProvider -> m a
action =
  ((forall a. m a -> IO a) -> IO a) -> m a
forall b. ((forall a. m a -> IO a) -> IO b) -> m b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO \forall a. m a -> IO a
runInIO -> TracerProviderSpec -> (TracerProvider -> IO a) -> IO a
forall a. TracerProviderSpec -> (TracerProvider -> IO a) -> IO a
withTracerProviderIO TracerProviderSpec
spec (m a -> IO a
forall a. m a -> IO a
runInIO (m a -> IO a) -> (TracerProvider -> m a) -> TracerProvider -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TracerProvider -> m a
action)

withTracerProviderIO
  :: forall a
   . TracerProviderSpec
  -> (TracerProvider -> IO a)
  -> IO a
withTracerProviderIO :: forall a. TracerProviderSpec -> (TracerProvider -> IO a) -> IO a
withTracerProviderIO TracerProviderSpec
tracerProviderSpec TracerProvider -> IO a
action = do
  (LoggingT IO () -> Logger -> IO ())
-> Logger -> LoggingT IO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip LoggingT IO () -> Logger -> IO ()
forall (m :: * -> *) a. LoggingT m a -> Logger -> m a
runLoggingT Logger
logger do
    Message -> LoggingT IO ()
forall (m :: * -> *).
(HasCallStack, MonadLogger m) =>
Message -> m ()
logDebug Message
"Acquiring tracer provider"
  TVar Bool
shutdownRef <- Bool -> IO (TVar Bool)
forall a. a -> IO (TVar a)
newTVarIO Bool
False
  MVar PRNG
prngRef <- Seed -> IO (MVar PRNG)
newPRNGRef Seed
seed
  IdGenerator
defIdGenerator <- Logger -> IdGeneratorSpec -> IO IdGenerator
forall (m :: * -> *).
MonadIO m =>
Logger -> IdGeneratorSpec -> m IdGenerator
buildIdGenerator Logger
forall a. Monoid a => a
mempty IdGeneratorSpec
defaultIdGeneratorSpec
  (IdGenerator -> IO a) -> IO a
forall r. (IdGenerator -> IO r) -> IO r
withIdGenerator \IdGenerator
idGenerator -> do
    (Sampler -> IO a) -> IO a
forall r. (Sampler -> IO r) -> IO r
withSampler \Sampler
sampler -> do
      (SpanProcessor -> IO a) -> IO a
forall r. (SpanProcessor -> IO r) -> IO r
withCompositeSpanProcessor \SpanProcessor
spanProcessor -> do
        let tracerProvider :: TracerProvider
tracerProvider =
              TracerProvider
                { tracerProviderGetTracer :: InstrumentationScope -> IO Tracer
tracerProviderGetTracer =
                    MVar PRNG
-> IdGenerator
-> IdGenerator
-> Sampler
-> SpanProcessor
-> InstrumentationScope
-> IO Tracer
getTracerWith MVar PRNG
prngRef IdGenerator
defIdGenerator IdGenerator
idGenerator Sampler
sampler SpanProcessor
spanProcessor
                , tracerProviderShutdown :: IO ()
tracerProviderShutdown = do
                    STM Bool -> STM (IO ()) -> IO ()
forall a. Monoid a => STM Bool -> STM (IO a) -> IO a
unlessSTM (TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
shutdownRef) do
                      TVar Bool -> Bool -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Bool
shutdownRef Bool
True
                      IO () -> STM (IO ())
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IO () -> STM (IO ())) -> IO () -> STM (IO ())
forall a b. (a -> b) -> a -> b
$ SpanProcessor -> IO ()
spanProcessorShutdown SpanProcessor
spanProcessor
                , tracerProviderForceFlush :: IO ()
tracerProviderForceFlush = do
                    STM Bool -> STM (IO ()) -> IO ()
forall a. Monoid a => STM Bool -> STM (IO a) -> IO a
unlessSTM (TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
shutdownRef) do
                      IO () -> STM (IO ())
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IO () -> STM (IO ())) -> IO () -> STM (IO ())
forall a b. (a -> b) -> a -> b
$ SpanProcessor -> IO ()
spanProcessorForceFlush SpanProcessor
spanProcessor
                }
        (LoggingT IO () -> Logger -> IO ())
-> Logger -> LoggingT IO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip LoggingT IO () -> Logger -> IO ()
forall (m :: * -> *) a. LoggingT m a -> Logger -> m a
runLoggingT Logger
logger do
          Message -> LoggingT IO ()
forall (m :: * -> *).
(HasCallStack, MonadLogger m) =>
Message -> m ()
logDebug (Message -> LoggingT IO ()) -> Message -> LoggingT IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Acquired tracer provider" Text -> [SeriesElem] -> Message
:#
            [ Key
"resource" Key -> Resource Attrs -> SeriesElem
forall v. ToJSON v => Key -> v -> SeriesElem
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Resource Attrs
res
            , Key
"limits" Key -> Value -> SeriesElem
forall v. ToJSON v => Key -> v -> SeriesElem
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object
                [ Key
"attributes" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object
                    [ Key
"span" Key -> AttrsLimits 'AttrsForSpan -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= AttrsLimits 'AttrsForSpan
spanAttrsLimits
                    , Key
"spanEvent" Key -> AttrsLimits 'AttrsForSpanEvent -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= AttrsLimits 'AttrsForSpanEvent
spanEventAttrsLimits
                    , Key
"spanLink" Key -> AttrsLimits 'AttrsForSpanLink -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= AttrsLimits 'AttrsForSpanLink
spanLinkAttrsLimits
                    ]
                ]
            ]
        TracerProvider -> IO a
action TracerProvider
tracerProvider IO a -> IO () -> IO a
forall (m :: * -> *) a b.
(HasCallStack, MonadMask m) =>
m a -> m b -> m a
`finally` TracerProvider -> IO ()
tracerProviderShutdown TracerProvider
tracerProvider
  where
  withIdGenerator :: (IdGenerator -> IO r) -> IO r
  withIdGenerator :: forall r. (IdGenerator -> IO r) -> IO r
withIdGenerator =
    ContT r IO IdGenerator -> (IdGenerator -> IO r) -> IO r
forall {k} (r :: k) (m :: k -> *) a.
ContT r m a -> (a -> m r) -> m r
runContT do
      IdGeneratorSpec
acquiredIdGenerator <- ((IdGeneratorSpec -> IO r) -> IO r) -> ContT r IO IdGeneratorSpec
forall {k} (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (((IdGeneratorSpec -> IO r) -> IO r) -> ContT r IO IdGeneratorSpec)
-> ((IdGeneratorSpec -> IO r) -> IO r)
-> ContT r IO IdGeneratorSpec
forall a b. (a -> b) -> a -> b
$ Logger -> (IdGeneratorSpec -> IO r) -> IO r
forall a. Logger -> (IdGeneratorSpec -> IO a) -> IO a
idGeneratorSpec Logger
logger
      IO IdGenerator -> ContT r IO IdGenerator
forall a. IO a -> ContT r IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO IdGenerator -> ContT r IO IdGenerator)
-> IO IdGenerator -> ContT r IO IdGenerator
forall a b. (a -> b) -> a -> b
$ Logger -> IdGeneratorSpec -> IO IdGenerator
forall (m :: * -> *).
MonadIO m =>
Logger -> IdGeneratorSpec -> m IdGenerator
buildIdGenerator Logger
logger IdGeneratorSpec
acquiredIdGenerator

  withSampler :: (Sampler -> IO r) -> IO r
  withSampler :: forall r. (Sampler -> IO r) -> IO r
withSampler =
    ContT r IO Sampler -> (Sampler -> IO r) -> IO r
forall {k} (r :: k) (m :: k -> *) a.
ContT r m a -> (a -> m r) -> m r
runContT do
      SamplerSpec
acquiredSamplerSpec <- ((SamplerSpec -> IO r) -> IO r) -> ContT r IO SamplerSpec
forall {k} (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (((SamplerSpec -> IO r) -> IO r) -> ContT r IO SamplerSpec)
-> ((SamplerSpec -> IO r) -> IO r) -> ContT r IO SamplerSpec
forall a b. (a -> b) -> a -> b
$ Logger -> (SamplerSpec -> IO r) -> IO r
forall a. Logger -> (SamplerSpec -> IO a) -> IO a
samplerSpec Logger
logger
      IO Sampler -> ContT r IO Sampler
forall a. IO a -> ContT r IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Sampler -> ContT r IO Sampler)
-> IO Sampler -> ContT r IO Sampler
forall a b. (a -> b) -> a -> b
$ Logger -> SamplerSpec -> IO Sampler
forall (m :: * -> *).
MonadIO m =>
Logger -> SamplerSpec -> m Sampler
buildSampler Logger
logger SamplerSpec
acquiredSamplerSpec

  withCompositeSpanProcessor :: (SpanProcessor -> IO r) -> IO r
  withCompositeSpanProcessor :: forall r. (SpanProcessor -> IO r) -> IO r
withCompositeSpanProcessor =
    ContT r IO SpanProcessor -> (SpanProcessor -> IO r) -> IO r
forall {k} (r :: k) (m :: k -> *) a.
ContT r m a -> (a -> m r) -> m r
runContT do
      [SpanProcessorSpec]
acquiredSpanProcessorSpecs <-
        [Logger -> (SpanProcessorSpec -> IO r) -> IO r]
-> ((Logger -> (SpanProcessorSpec -> IO r) -> IO r)
    -> ContT r IO SpanProcessorSpec)
-> ContT r IO [SpanProcessorSpec]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Logger -> (SpanProcessorSpec -> IO r) -> IO r]
forall a. [Logger -> (SpanProcessorSpec -> IO a) -> IO a]
spanProcessorSpecs \Logger -> (SpanProcessorSpec -> IO r) -> IO r
spanProcessorSpec ->
          ((SpanProcessorSpec -> IO r) -> IO r)
-> ContT r IO SpanProcessorSpec
forall {k} (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (((SpanProcessorSpec -> IO r) -> IO r)
 -> ContT r IO SpanProcessorSpec)
-> ((SpanProcessorSpec -> IO r) -> IO r)
-> ContT r IO SpanProcessorSpec
forall a b. (a -> b) -> a -> b
$ Logger -> (SpanProcessorSpec -> IO r) -> IO r
spanProcessorSpec Logger
logger
      [SpanProcessor]
acquiredSpanProcessors <- do
        (SpanProcessorSpec -> ContT r IO SpanProcessor)
-> [SpanProcessorSpec] -> ContT r IO [SpanProcessor]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (((SpanProcessor -> IO r) -> IO r) -> ContT r IO SpanProcessor
forall {k} (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (((SpanProcessor -> IO r) -> IO r) -> ContT r IO SpanProcessor)
-> (SpanProcessorSpec -> (SpanProcessor -> IO r) -> IO r)
-> SpanProcessorSpec
-> ContT r IO SpanProcessor
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Resource Attrs
-> Logger -> SpanProcessorSpec -> (SpanProcessor -> IO r) -> IO r
forall a.
Resource Attrs
-> Logger -> SpanProcessorSpec -> (SpanProcessor -> IO a) -> IO a
buildSpanProcessor Resource Attrs
res Logger
logger) [SpanProcessorSpec]
acquiredSpanProcessorSpecs
      SpanProcessor -> ContT r IO SpanProcessor
forall a. a -> ContT r IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SpanProcessor -> ContT r IO SpanProcessor)
-> SpanProcessor -> ContT r IO SpanProcessor
forall a b. (a -> b) -> a -> b
$ [SpanProcessor] -> SpanProcessor
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold [SpanProcessor]
acquiredSpanProcessors

  getTracerWith
    :: MVar PRNG
    -> IdGenerator
    -> IdGenerator
    -> Sampler
    -> SpanProcessor
    -> InstrumentationScope
    -> IO Tracer
  getTracerWith :: MVar PRNG
-> IdGenerator
-> IdGenerator
-> Sampler
-> SpanProcessor
-> InstrumentationScope
-> IO Tracer
getTracerWith MVar PRNG
prngRef IdGenerator
defIdGenerator IdGenerator
idGenerator Sampler
sampler SpanProcessor
spanProcessor InstrumentationScope
scope =
    (LoggingT IO Tracer -> Logger -> IO Tracer)
-> Logger -> LoggingT IO Tracer -> IO Tracer
forall a b c. (a -> b -> c) -> b -> a -> c
flip LoggingT IO Tracer -> Logger -> IO Tracer
forall (m :: * -> *) a. LoggingT m a -> Logger -> m a
runLoggingT Logger
logger do
      Message -> LoggingT IO ()
forall (m :: * -> *).
(HasCallStack, MonadLogger m) =>
Message -> m ()
logDebug (Message -> LoggingT IO ()) -> Message -> LoggingT IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Providing tracer" Text -> [SeriesElem] -> Message
:# [ Key
"instrumentationScope" Key -> InstrumentationScope -> SeriesElem
forall v. ToJSON v => Key -> v -> SeriesElem
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= InstrumentationScope
scope ]
      Tracer -> LoggingT IO Tracer
forall a. a -> LoggingT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tracer
        { tracerInstrumentationScope :: InstrumentationScope
tracerInstrumentationScope = InstrumentationScope
scope
        , tracerNow :: IO Timestamp
tracerNow = IO Timestamp
now
        , tracerStartSpan :: CallStack -> Context -> SpanSpec -> IO (MutableSpan, [Pair])
tracerStartSpan = MVar PRNG
-> IdGenerator
-> IdGenerator
-> Sampler
-> InstrumentationScope
-> SpanProcessor
-> CallStack
-> Context
-> SpanSpec
-> IO (MutableSpan, [Pair])
startSpan MVar PRNG
prngRef IdGenerator
defIdGenerator IdGenerator
idGenerator Sampler
sampler InstrumentationScope
scope SpanProcessor
spanProcessor
        , tracerProcessSpan :: Span Attrs -> IO ()
tracerProcessSpan = SpanProcessor -> Span Attrs -> IO ()
endSpan SpanProcessor
spanProcessor
        , tracerSpanAttrsLimits :: AttrsLimits 'AttrsForSpan
tracerSpanAttrsLimits = AttrsLimits 'AttrsForSpan
spanAttrsLimits
        , tracerSpanEventAttrsLimits :: AttrsLimits 'AttrsForSpanEvent
tracerSpanEventAttrsLimits = AttrsLimits 'AttrsForSpanEvent
spanEventAttrsLimits
        , tracerSpanLinkAttrsLimits :: AttrsLimits 'AttrsForSpanLink
tracerSpanLinkAttrsLimits = AttrsLimits 'AttrsForSpanLink
spanLinkAttrsLimits
        }

  endSpan :: SpanProcessor -> Span Attrs -> IO ()
  endSpan :: SpanProcessor -> Span Attrs -> IO ()
endSpan SpanProcessor
spanProcessor Span Attrs
endedSpan = do
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Span Attrs -> Bool
forall (attrs :: AttrsFor -> *). Span attrs -> Bool
spanIsRecording Span Attrs
endedSpan) do
      SpanProcessor -> Span Attrs -> IO ()
spanProcessorOnSpanEnd SpanProcessor
spanProcessor Span Attrs
endedSpan

  startSpan
    :: MVar PRNG
    -> IdGenerator
    -> IdGenerator
    -> Sampler
    -> InstrumentationScope
    -> SpanProcessor
    -> CallStack
    -> Context
    -> SpanSpec
    -> IO (MutableSpan, [Pair])
  startSpan :: MVar PRNG
-> IdGenerator
-> IdGenerator
-> Sampler
-> InstrumentationScope
-> SpanProcessor
-> CallStack
-> Context
-> SpanSpec
-> IO (MutableSpan, [Pair])
startSpan MVar PRNG
prngRef IdGenerator
defIdGenerator IdGenerator
idGenerator Sampler
sampler InstrumentationScope
scope SpanProcessor
spanProcessor CallStack
cs Context
implicitParentContext SpanSpec
spanSpec = do
    Span AttrsBuilder
span <- IO (Span AttrsBuilder)
buildSpan
    MutableSpan
mutableSpan <- Span AttrsBuilder -> IO MutableSpan
unsafeNewMutableSpan Span AttrsBuilder
span

    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Span AttrsBuilder -> Bool
forall (attrs :: AttrsFor -> *). Span attrs -> Bool
spanIsRecording Span AttrsBuilder
span) do
      SpanProcessor
-> Context -> (UpdateSpanSpec -> IO (Span Attrs)) -> IO ()
spanProcessorOnSpanStart SpanProcessor
spanProcessor Context
parentContext \UpdateSpanSpec
updateSpanSpec -> do
        MutableSpan -> UpdateSpanSpec -> IO (Span Attrs)
spanUpdater MutableSpan
mutableSpan UpdateSpanSpec
updateSpanSpec

    (MutableSpan, [Pair]) -> IO (MutableSpan, [Pair])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MutableSpan
mutableSpan, SpanContext -> [Pair]
spanContextMeta (SpanContext -> [Pair]) -> SpanContext -> [Pair]
forall a b. (a -> b) -> a -> b
$ Span AttrsBuilder -> SpanContext
forall (attrs :: AttrsFor -> *). Span attrs -> SpanContext
spanContext Span AttrsBuilder
span)
    where
    buildSpan :: IO (Span AttrsBuilder)
    buildSpan :: IO (Span AttrsBuilder)
buildSpan = do
      SpanLineage
spanLineage <- Context -> IO SpanLineage
spanLineageFromParentContext Context
parentContext
      SpanContext
initSpanContext <- SpanLineage -> IO SpanContext
newSpanContext SpanLineage
spanLineage

      SamplingResult
samplingResult <- Sampler -> SamplerInput -> IO SamplingResult
samplerShouldSample Sampler
sampler SamplerInput
        { samplerInputContext :: Context
samplerInputContext = Context
parentContext
        , samplerInputTraceId :: TraceId
samplerInputTraceId = SpanContext -> TraceId
spanContextTraceId SpanContext
initSpanContext
        , samplerInputSpanName :: SpanName
samplerInputSpanName = SpanName
spanSpecName
        , samplerInputSpanKind :: SpanKind
samplerInputSpanKind = SpanKind
spanSpecKind
        , samplerInputSpanAttrs :: AttrsBuilder 'AttrsForSpan
samplerInputSpanAttrs = AttrsBuilder 'AttrsForSpan
spanSpecAttrs
        , samplerInputSpanLinks :: SpanLinks AttrsBuilder
samplerInputSpanLinks = SpanLinks AttrsBuilder
spanLinks
        }

      let (Bool
spanIsRecording, SpanContext
spanContextPostSampling) =
            case SamplingResult -> SamplingDecision
samplingResultDecision SamplingResult
samplingResult of
              SamplingDecision
SamplingDecisionDrop -> (Bool
False, SpanContext
initSpanContext)
              SamplingDecision
SamplingDecisionRecordOnly -> (Bool
True, SpanContext
initSpanContext)
              SamplingDecision
SamplingDecisionRecordAndSample ->
                ( Bool
True
                , SpanContext
initSpanContext
                    { spanContextTraceFlags =
                        traceFlagsSampled <>  spanContextTraceFlags initSpanContext
                    }
                )

      Timestamp
spanStart <- do
        case TimestampSource
spanSpecStart of
          TimestampSourceAt Timestamp
timestamp -> Timestamp -> IO Timestamp
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Timestamp
timestamp
          TimestampSource
TimestampSourceNow -> IO Timestamp
now

      Span AttrsBuilder -> IO (Span AttrsBuilder)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Span
        { SpanLineage
spanLineage :: SpanLineage
spanLineage :: SpanLineage
spanLineage
        , spanContext :: SpanContext
spanContext =
            SpanContext
spanContextPostSampling
              { spanContextTraceState = samplingResultTraceState samplingResult
              }
        , spanName :: SpanName
spanName = SpanName
spanSpecName
        , spanStatus :: SpanStatus
spanStatus = SpanStatus
SpanStatusUnset
        , Timestamp
spanStart :: Timestamp
spanStart :: Timestamp
spanStart
        , spanFrozenAt :: SpanFrozenAt AttrsBuilder
spanFrozenAt = Maybe Timestamp
SpanFrozenAt AttrsBuilder
forall a. Maybe a
Nothing
        , spanKind :: SpanKind
spanKind = SpanKind
spanSpecKind
        , spanAttrs :: AttrsBuilder 'AttrsForSpan
spanAttrs =
            SamplingResult -> AttrsBuilder 'AttrsForSpan
samplingResultSpanAttrs SamplingResult
samplingResult
              AttrsBuilder 'AttrsForSpan
-> AttrsBuilder 'AttrsForSpan -> AttrsBuilder 'AttrsForSpan
forall a. Semigroup a => a -> a -> a
<> CallStack -> AttrsBuilder 'AttrsForSpan
callStackAttrs CallStack
cs
              AttrsBuilder 'AttrsForSpan
-> AttrsBuilder 'AttrsForSpan -> AttrsBuilder 'AttrsForSpan
forall a. Semigroup a => a -> a -> a
<> AttrsBuilder 'AttrsForSpan
spanSpecAttrs
        , SpanLinks AttrsBuilder
spanLinks :: SpanLinks AttrsBuilder
spanLinks :: SpanLinks AttrsBuilder
spanLinks
        , spanEvents :: SpanEvents AttrsBuilder
spanEvents = SpanEvents AttrsBuilder
forall a. Monoid a => a
mempty
        , Bool
spanIsRecording :: Bool
spanIsRecording :: Bool
spanIsRecording
        , spanInstrumentationScope :: InstrumentationScope
spanInstrumentationScope = InstrumentationScope
scope
        }
      where
      spanLineageFromParentContext :: Context -> IO SpanLineage
      spanLineageFromParentContext :: Context -> IO SpanLineage
spanLineageFromParentContext Context
context =
        case ContextKey MutableSpan -> Context -> Maybe MutableSpan
forall a. ContextKey a -> Context -> Maybe a
lookupContext ContextKey MutableSpan
contextKeySpan Context
context of
          Maybe MutableSpan
Nothing -> SpanLineage -> IO SpanLineage
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SpanLineage
SpanLineageRoot
          Just MutableSpan
mutableSpan -> do
            (Span AttrsBuilder -> SpanLineage)
-> IO (Span AttrsBuilder) -> IO SpanLineage
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SpanContext -> SpanLineage
SpanLineageChildOf (SpanContext -> SpanLineage)
-> (Span AttrsBuilder -> SpanContext)
-> Span AttrsBuilder
-> SpanLineage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Span AttrsBuilder -> SpanContext
forall (attrs :: AttrsFor -> *). Span attrs -> SpanContext
spanContext) (IO (Span AttrsBuilder) -> IO SpanLineage)
-> IO (Span AttrsBuilder) -> IO SpanLineage
forall a b. (a -> b) -> a -> b
$ MutableSpan -> IO (Span AttrsBuilder)
unsafeReadMutableSpan MutableSpan
mutableSpan

      newSpanContext :: SpanLineage -> IO SpanContext
      newSpanContext :: SpanLineage -> IO SpanContext
newSpanContext SpanLineage
spanLineage = do
        (TraceId
spanContextTraceId, SpanId
spanContextSpanId) <- do
          MVar PRNG -> (PRNG -> IO (TraceId, SpanId)) -> IO (TraceId, SpanId)
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar PRNG
prngRef \PRNG
prng -> do
            case SpanLineage
spanLineage of
              SpanLineage
SpanLineageRoot ->
                (TraceId -> SpanId -> (TraceId, SpanId))
-> IO TraceId -> IO SpanId -> IO (TraceId, SpanId)
forall a b c. (a -> b -> c) -> IO a -> IO b -> IO c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) (PRNG -> IO TraceId
genTraceId PRNG
prng) (PRNG -> IO SpanId
genSpanId PRNG
prng)
                  IO (TraceId, SpanId)
-> (SomeException -> IO (TraceId, SpanId)) -> IO (TraceId, SpanId)
forall (m :: * -> *) a.
(HasCallStack, MonadCatch m) =>
m a -> (SomeException -> m a) -> m a
`catchAny` \(SomeException e
ex) -> do
                    TraceId
traceId <- IdGenerator -> PRNG -> IO TraceId
idGeneratorGenTraceId IdGenerator
defIdGenerator PRNG
prng
                    SpanId
spanId <- IdGenerator -> PRNG -> IO SpanId
idGeneratorGenSpanId IdGenerator
defIdGenerator PRNG
prng
                    (LoggingT IO () -> Logger -> IO ())
-> Logger -> LoggingT IO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip LoggingT IO () -> Logger -> IO ()
forall (m :: * -> *) a. LoggingT m a -> Logger -> m a
runLoggingT Logger
logger do
                      Message -> LoggingT IO ()
forall (m :: * -> *).
(HasCallStack, MonadLogger m) =>
Message -> m ()
logError (Message -> LoggingT IO ()) -> Message -> LoggingT IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Fell back to default trace/span ID gen due to exception" Text -> [SeriesElem] -> Message
:#
                        [ Key
"exception" Key -> [Char] -> SeriesElem
forall v. ToJSON v => Key -> v -> SeriesElem
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= e -> [Char]
forall e. Exception e => e -> [Char]
displayException e
ex
                        , Key
"traceId" Key -> TraceId -> SeriesElem
forall v. ToJSON v => Key -> v -> SeriesElem
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= TraceId
traceId
                        , Key
"spanId" Key -> SpanId -> SeriesElem
forall v. ToJSON v => Key -> v -> SeriesElem
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= SpanId
spanId
                        ]
                    (TraceId, SpanId) -> IO (TraceId, SpanId)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TraceId
traceId, SpanId
spanId)
              SpanLineageChildOf SpanContext
scParent ->
                (SpanId -> (TraceId, SpanId)) -> IO SpanId -> IO (TraceId, SpanId)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SpanContext -> TraceId
spanContextTraceId SpanContext
scParent,) (PRNG -> IO SpanId
genSpanId PRNG
prng)
                  IO (TraceId, SpanId)
-> (SomeException -> IO (TraceId, SpanId)) -> IO (TraceId, SpanId)
forall (m :: * -> *) a.
(HasCallStack, MonadCatch m) =>
m a -> (SomeException -> m a) -> m a
`catchAny` \(SomeException e
ex) -> do
                    let traceId :: TraceId
traceId = SpanContext -> TraceId
spanContextTraceId SpanContext
scParent
                    SpanId
spanId <- IdGenerator -> PRNG -> IO SpanId
idGeneratorGenSpanId IdGenerator
defIdGenerator PRNG
prng
                    (LoggingT IO () -> Logger -> IO ())
-> Logger -> LoggingT IO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip LoggingT IO () -> Logger -> IO ()
forall (m :: * -> *) a. LoggingT m a -> Logger -> m a
runLoggingT Logger
logger do
                      Message -> LoggingT IO ()
forall (m :: * -> *).
(HasCallStack, MonadLogger m) =>
Message -> m ()
logError (Message -> LoggingT IO ()) -> Message -> LoggingT IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Fell back to default trace/span ID gen due to exception" Text -> [SeriesElem] -> Message
:#
                        [ Key
"exception" Key -> [Char] -> SeriesElem
forall v. ToJSON v => Key -> v -> SeriesElem
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= e -> [Char]
forall e. Exception e => e -> [Char]
displayException e
ex
                        , Key
"traceId" Key -> TraceId -> SeriesElem
forall v. ToJSON v => Key -> v -> SeriesElem
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= TraceId
traceId
                        , Key
"spanId" Key -> SpanId -> SeriesElem
forall v. ToJSON v => Key -> v -> SeriesElem
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= SpanId
spanId
                        ]
                    (TraceId, SpanId) -> IO (TraceId, SpanId)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TraceId
traceId, SpanId
spanId)

        SpanContext -> IO SpanContext
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SpanContext
emptySpanContext
          { spanContextTraceId
          , spanContextSpanId
          , spanContextTraceFlags = mempty
          , spanContextTraceState = emptyTraceState
          , spanContextIsRemote = False -- TODO: Populate correctly
          }

    spanUpdater :: MutableSpan -> UpdateSpanSpec -> IO (Span Attrs)
    spanUpdater :: MutableSpan -> UpdateSpanSpec -> IO (Span Attrs)
spanUpdater MutableSpan
mutableSpan UpdateSpanSpec
updateSpanSpec = do
      Span AttrsBuilder -> Span AttrsBuilder
updater <- IO Timestamp
-> UpdateSpanSpec -> IO (Span AttrsBuilder -> Span AttrsBuilder)
forall (m :: * -> *).
Monad m =>
m Timestamp
-> UpdateSpanSpec -> m (Span AttrsBuilder -> Span AttrsBuilder)
buildSpanUpdater (IO Timestamp -> IO Timestamp
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Timestamp
now) UpdateSpanSpec
updateSpanSpec
      Timestamp
frozenAt <- IO Timestamp -> IO Timestamp
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Timestamp
now
      MutableSpan
-> (Span AttrsBuilder -> (Span AttrsBuilder, Span Attrs))
-> IO (Span Attrs)
forall a.
MutableSpan
-> (Span AttrsBuilder -> (Span AttrsBuilder, a)) -> IO a
unsafeModifyMutableSpan MutableSpan
mutableSpan \Span AttrsBuilder
span ->
        let span' :: Span AttrsBuilder
span' = Span AttrsBuilder -> Span AttrsBuilder
updater Span AttrsBuilder
span
         in ( Span AttrsBuilder
span'
            , Timestamp
-> AttrsLimits 'AttrsForSpanLink
-> AttrsLimits 'AttrsForSpanEvent
-> AttrsLimits 'AttrsForSpan
-> Span AttrsBuilder
-> Span Attrs
freezeSpan Timestamp
frozenAt AttrsLimits 'AttrsForSpanLink
spanLinkAttrsLimits AttrsLimits 'AttrsForSpanEvent
spanEventAttrsLimits AttrsLimits 'AttrsForSpan
spanAttrsLimits Span AttrsBuilder
span'
            )

    spanLinks :: SpanLinks AttrsBuilder
spanLinks =
      DList (SpanLink AttrsBuilder) -> SpanLinks AttrsBuilder
forall (attrs :: AttrsFor -> *).
DList (SpanLink attrs) -> SpanLinks attrs
SpanLinks (DList (SpanLink AttrsBuilder) -> SpanLinks AttrsBuilder)
-> DList (SpanLink AttrsBuilder) -> SpanLinks AttrsBuilder
forall a b. (a -> b) -> a -> b
$ ((SpanLinkSpec -> SpanLink AttrsBuilder)
 -> DList SpanLinkSpec -> DList (SpanLink AttrsBuilder))
-> DList SpanLinkSpec
-> (SpanLinkSpec -> SpanLink AttrsBuilder)
-> DList (SpanLink AttrsBuilder)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (SpanLinkSpec -> SpanLink AttrsBuilder)
-> DList SpanLinkSpec -> DList (SpanLink AttrsBuilder)
forall a b. (a -> b) -> DList a -> DList b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SpanLinkSpecs -> DList SpanLinkSpec
unSpanLinkSpecs SpanLinkSpecs
spanSpecLinks) \SpanLinkSpec
spanLinkSpec ->
        SpanLink
          { spanLinkSpanContext :: SpanContext
spanLinkSpanContext =
              SpanLinkSpec -> SpanContext
spanLinkSpecSpanContext SpanLinkSpec
spanLinkSpec
          , spanLinkAttrs :: AttrsBuilder 'AttrsForSpanLink
spanLinkAttrs =
              SpanLinkSpec -> AttrsBuilder 'AttrsForSpanLink
spanLinkSpecAttrs SpanLinkSpec
spanLinkSpec
          }

    parentContext :: Context
parentContext = Context -> Maybe Context -> Context
forall a. a -> Maybe a -> a
fromMaybe Context
implicitParentContext Maybe Context
spanSpecParentContext

    IdGenerator
      { idGeneratorGenTraceId :: IdGenerator -> PRNG -> IO TraceId
idGeneratorGenTraceId = PRNG -> IO TraceId
genTraceId
      , idGeneratorGenSpanId :: IdGenerator -> PRNG -> IO SpanId
idGeneratorGenSpanId = PRNG -> IO SpanId
genSpanId
      } = IdGenerator
idGenerator

    SpanSpec
      { SpanName
spanSpecName :: SpanName
spanSpecName :: SpanSpec -> SpanName
spanSpecName
      , Maybe Context
spanSpecParentContext :: Maybe Context
spanSpecParentContext :: SpanSpec -> Maybe Context
spanSpecParentContext
      , TimestampSource
spanSpecStart :: TimestampSource
spanSpecStart :: SpanSpec -> TimestampSource
spanSpecStart
      , SpanKind
spanSpecKind :: SpanKind
spanSpecKind :: SpanSpec -> SpanKind
spanSpecKind
      , AttrsBuilder 'AttrsForSpan
spanSpecAttrs :: AttrsBuilder 'AttrsForSpan
spanSpecAttrs :: SpanSpec -> AttrsBuilder 'AttrsForSpan
spanSpecAttrs
      , SpanLinkSpecs
spanSpecLinks :: SpanLinkSpecs
spanSpecLinks :: SpanSpec -> SpanLinkSpecs
spanSpecLinks
      } = SpanSpec
spanSpec

  TracerProviderSpec
    { tracerProviderSpecNow :: TracerProviderSpec -> IO Timestamp
tracerProviderSpecNow = IO Timestamp
now
    , tracerProviderSpecLogger :: TracerProviderSpec -> Logger
tracerProviderSpecLogger = Logger
logger
    , tracerProviderSpecSeed :: TracerProviderSpec -> Seed
tracerProviderSpecSeed = Seed
seed
    , tracerProviderSpecIdGenerator :: TracerProviderSpec
-> forall a. Logger -> (IdGeneratorSpec -> IO a) -> IO a
tracerProviderSpecIdGenerator = forall a. Logger -> (IdGeneratorSpec -> IO a) -> IO a
idGeneratorSpec
    , tracerProviderSpecSpanProcessors :: TracerProviderSpec
-> forall a. [Logger -> (SpanProcessorSpec -> IO a) -> IO a]
tracerProviderSpecSpanProcessors = forall a. [Logger -> (SpanProcessorSpec -> IO a) -> IO a]
spanProcessorSpecs
    , tracerProviderSpecSampler :: TracerProviderSpec
-> forall a. Logger -> (SamplerSpec -> IO a) -> IO a
tracerProviderSpecSampler = forall a. Logger -> (SamplerSpec -> IO a) -> IO a
samplerSpec
    , tracerProviderSpecResource :: TracerProviderSpec -> Resource Attrs
tracerProviderSpecResource = Resource Attrs
res
    , tracerProviderSpecSpanAttrsLimits :: TracerProviderSpec -> AttrsLimits 'AttrsForSpan
tracerProviderSpecSpanAttrsLimits = AttrsLimits 'AttrsForSpan
spanAttrsLimits
    , tracerProviderSpecSpanEventAttrsLimits :: TracerProviderSpec -> AttrsLimits 'AttrsForSpanEvent
tracerProviderSpecSpanEventAttrsLimits = AttrsLimits 'AttrsForSpanEvent
spanEventAttrsLimits
    , tracerProviderSpecSpanLinkAttrsLimits :: TracerProviderSpec -> AttrsLimits 'AttrsForSpanLink
tracerProviderSpecSpanLinkAttrsLimits = AttrsLimits 'AttrsForSpanLink
spanLinkAttrsLimits
    , tracerProviderSpecCallStackAttrs :: TracerProviderSpec -> CallStack -> AttrsBuilder 'AttrsForSpan
tracerProviderSpecCallStackAttrs = CallStack -> AttrsBuilder 'AttrsForSpan
callStackAttrs
    , tracerProviderSpecSpanContextMeta :: TracerProviderSpec -> SpanContext -> [Pair]
tracerProviderSpecSpanContextMeta = SpanContext -> [Pair]
spanContextMeta
    } = TracerProviderSpec
tracerProviderSpec

data SpanProcessor = SpanProcessor
  { SpanProcessor
-> Context -> (UpdateSpanSpec -> IO (Span Attrs)) -> IO ()
spanProcessorOnSpanStart
      :: Context -- Parent context
      -> (UpdateSpanSpec -> IO (Span Attrs))
      -> IO ()
  , SpanProcessor -> Span Attrs -> IO ()
spanProcessorOnSpanEnd :: Span Attrs -> IO ()
  , SpanProcessor -> IO ()
spanProcessorShutdown :: IO ()
  , SpanProcessor -> IO ()
spanProcessorForceFlush :: IO ()
  }

instance Semigroup SpanProcessor where
  SpanProcessor
sp1 <> :: SpanProcessor -> SpanProcessor -> SpanProcessor
<> SpanProcessor
sp2 =
    SpanProcessor
      { spanProcessorOnSpanStart :: Context -> (UpdateSpanSpec -> IO (Span Attrs)) -> IO ()
spanProcessorOnSpanStart =
          SpanProcessor
-> Context -> (UpdateSpanSpec -> IO (Span Attrs)) -> IO ()
spanProcessorOnSpanStart SpanProcessor
sp1 (Context -> (UpdateSpanSpec -> IO (Span Attrs)) -> IO ())
-> (Context -> (UpdateSpanSpec -> IO (Span Attrs)) -> IO ())
-> Context
-> (UpdateSpanSpec -> IO (Span Attrs))
-> IO ()
forall a. Semigroup a => a -> a -> a
<> SpanProcessor
-> Context -> (UpdateSpanSpec -> IO (Span Attrs)) -> IO ()
spanProcessorOnSpanStart SpanProcessor
sp2
      , spanProcessorOnSpanEnd :: Span Attrs -> IO ()
spanProcessorOnSpanEnd =
          SpanProcessor -> Span Attrs -> IO ()
spanProcessorOnSpanEnd SpanProcessor
sp1 (Span Attrs -> IO ())
-> (Span Attrs -> IO ()) -> Span Attrs -> IO ()
forall a. Semigroup a => a -> a -> a
<> SpanProcessor -> Span Attrs -> IO ()
spanProcessorOnSpanEnd SpanProcessor
sp2
      , spanProcessorShutdown :: IO ()
spanProcessorShutdown =
          SpanProcessor -> IO ()
spanProcessorShutdown SpanProcessor
sp1 IO () -> IO () -> IO ()
forall a. Semigroup a => a -> a -> a
<> SpanProcessor -> IO ()
spanProcessorShutdown SpanProcessor
sp2
      , spanProcessorForceFlush :: IO ()
spanProcessorForceFlush =
          SpanProcessor -> IO ()
spanProcessorForceFlush SpanProcessor
sp1 IO () -> IO () -> IO ()
forall a. Semigroup a => a -> a -> a
<> SpanProcessor -> IO ()
spanProcessorForceFlush SpanProcessor
sp2
      }

instance Monoid SpanProcessor where
  mempty :: SpanProcessor
mempty =
    SpanProcessor
      { spanProcessorOnSpanStart :: Context -> (UpdateSpanSpec -> IO (Span Attrs)) -> IO ()
spanProcessorOnSpanStart = Context -> (UpdateSpanSpec -> IO (Span Attrs)) -> IO ()
forall a. Monoid a => a
mempty
      , spanProcessorOnSpanEnd :: Span Attrs -> IO ()
spanProcessorOnSpanEnd = Span Attrs -> IO ()
forall a. Monoid a => a
mempty
      , spanProcessorShutdown :: IO ()
spanProcessorShutdown = IO ()
forall a. Monoid a => a
mempty
      , spanProcessorForceFlush :: IO ()
spanProcessorForceFlush = IO ()
forall a. Monoid a => a
mempty
      }

buildSpanProcessor
  :: forall a
   . Resource Attrs
  -> Logger
  -> SpanProcessorSpec
  -> (SpanProcessor -> IO a)
  -> IO a
buildSpanProcessor :: forall a.
Resource Attrs
-> Logger -> SpanProcessorSpec -> (SpanProcessor -> IO a) -> IO a
buildSpanProcessor Resource Attrs
res Logger
logger SpanProcessorSpec
spanProcessorSpec = do
  ContT a IO SpanProcessor -> (SpanProcessor -> IO a) -> IO a
forall {k} (r :: k) (m :: k -> *) a.
ContT r m a -> (a -> m r) -> m r
runContT do
    SpanExporterSpec
spanExporterSpec <- ((SpanExporterSpec -> IO a) -> IO a) -> ContT a IO SpanExporterSpec
forall {k} (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (((SpanExporterSpec -> IO a) -> IO a)
 -> ContT a IO SpanExporterSpec)
-> ((SpanExporterSpec -> IO a) -> IO a)
-> ContT a IO SpanExporterSpec
forall a b. (a -> b) -> a -> b
$ Logger -> (SpanExporterSpec -> IO a) -> IO a
forall a. Logger -> (SpanExporterSpec -> IO a) -> IO a
spanProcessorSpecExporter Logger
logger
    TVar Bool
shutdownRef <- IO (TVar Bool) -> ContT a IO (TVar Bool)
forall a. IO a -> ContT a IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (TVar Bool) -> ContT a IO (TVar Bool))
-> IO (TVar Bool) -> ContT a IO (TVar Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> IO (TVar Bool)
forall a. a -> IO (TVar a)
newTVarIO Bool
False
    (LoggingT (ContT a IO) () -> Logger -> ContT a IO ())
-> Logger -> LoggingT (ContT a IO) () -> ContT a IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip LoggingT (ContT a IO) () -> Logger -> ContT a IO ()
forall (m :: * -> *) a. LoggingT m a -> Logger -> m a
runLoggingT Logger
logger do
      Message -> LoggingT (ContT a IO) ()
forall (m :: * -> *).
(HasCallStack, MonadLogger m) =>
Message -> m ()
logDebug (Message -> LoggingT (ContT a IO) ())
-> Message -> LoggingT (ContT a IO) ()
forall a b. (a -> b) -> a -> b
$ Text
"Building span processor" Text -> [SeriesElem] -> Message
:#
        [ Key
"name" Key -> Text -> SeriesElem
forall v. ToJSON v => Key -> v -> SeriesElem
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
spanProcessorSpecName
        , Key
"shutdownTimeout" Key -> Int -> SeriesElem
forall v. ToJSON v => Key -> v -> SeriesElem
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Int
shutdownTimeout
        , Key
"forceFlushTimeout" Key -> Int -> SeriesElem
forall v. ToJSON v => Key -> v -> SeriesElem
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Int
forceFlushTimeout
        , Key
"spanExporter" Key -> Value -> SeriesElem
forall v. ToJSON v => Key -> v -> SeriesElem
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object
            [ Key
"name" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= SpanExporterSpec -> Text
spanExporterSpecName SpanExporterSpec
spanExporterSpec
            , Key
"shutdownTimeout" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= SpanExporterSpec -> Int
spanExporterSpecShutdownTimeout SpanExporterSpec
spanExporterSpec
            , Key
"forceFlushTimeout" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= SpanExporterSpec -> Int
spanExporterSpecForceFlushTimeout SpanExporterSpec
spanExporterSpec
            ]
        ]
    SpanExporter
spanExporter <- IO SpanExporter -> ContT a IO SpanExporter
forall a. IO a -> ContT a IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO SpanExporter -> ContT a IO SpanExporter)
-> IO SpanExporter -> ContT a IO SpanExporter
forall a b. (a -> b) -> a -> b
$ Resource Attrs -> Logger -> SpanExporterSpec -> IO SpanExporter
buildSpanExporter Resource Attrs
res Logger
logger SpanExporterSpec
spanExporterSpec
    SpanProcessor -> ContT a IO SpanProcessor
forall a. a -> ContT a IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SpanProcessor -> ContT a IO SpanProcessor)
-> SpanProcessor -> ContT a IO SpanProcessor
forall a b. (a -> b) -> a -> b
$ TVar Bool -> SpanExporter -> SpanProcessor
spanProcessor TVar Bool
shutdownRef SpanExporter
spanExporter
  where
  spanProcessor :: TVar Bool -> SpanExporter -> SpanProcessor
spanProcessor TVar Bool
shutdownRef SpanExporter
spanExporter =
    SpanProcessor
      { spanProcessorOnSpanStart :: Context -> (UpdateSpanSpec -> IO (Span Attrs)) -> IO ()
spanProcessorOnSpanStart = \Context
mParentSpanContext UpdateSpanSpec -> IO (Span Attrs)
spanUpdater -> do
          STM Bool -> STM (IO ()) -> IO ()
forall a. Monoid a => STM Bool -> STM (IO a) -> IO a
unlessSTM (TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
shutdownRef) do
            IO () -> STM (IO ())
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure do
              Int -> [SeriesElem] -> SpanProcessorM () -> IO ()
run Int
defaultTimeout [SeriesElem]
metaOnSpanStart do
                Context
-> (UpdateSpanSpec -> SpanProcessorM (Span Attrs))
-> SpanProcessorM ()
spanProcessorSpecOnSpanStart Context
mParentSpanContext \UpdateSpanSpec
updateSpanSpec -> do
                  IO (Span Attrs) -> SpanProcessorM (Span Attrs)
forall a. IO a -> SpanProcessorM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Span Attrs) -> SpanProcessorM (Span Attrs))
-> IO (Span Attrs) -> SpanProcessorM (Span Attrs)
forall a b. (a -> b) -> a -> b
$ UpdateSpanSpec -> IO (Span Attrs)
spanUpdater UpdateSpanSpec
updateSpanSpec
      , spanProcessorOnSpanEnd :: Span Attrs -> IO ()
spanProcessorOnSpanEnd = \Span Attrs
endedSpan -> do
          STM Bool -> STM (IO ()) -> IO ()
forall a. Monoid a => STM Bool -> STM (IO a) -> IO a
unlessSTM (TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
shutdownRef) do
            IO () -> STM (IO ())
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure do
              Int -> [SeriesElem] -> SpanProcessorM () -> IO ()
run Int
defaultTimeout [SeriesElem]
metaOnSpanEnd do
                Span Attrs -> SpanProcessorM ()
spanProcessorSpecOnSpanEnd Span Attrs
endedSpan
      , spanProcessorShutdown :: IO ()
spanProcessorShutdown = do
          STM Bool -> STM (IO ()) -> IO ()
forall a. Monoid a => STM Bool -> STM (IO a) -> IO a
unlessSTM (TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
shutdownRef) do
            TVar Bool -> Bool -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Bool
shutdownRef Bool
True
            IO () -> STM (IO ())
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure do
              Int -> [SeriesElem] -> SpanProcessorM () -> IO ()
run Int
shutdownTimeout [SeriesElem]
metaShutdown do
                SpanProcessorM ()
spanProcessorSpecShutdown
      , spanProcessorForceFlush :: IO ()
spanProcessorForceFlush = do
          STM Bool -> STM (IO ()) -> IO ()
forall a. Monoid a => STM Bool -> STM (IO a) -> IO a
unlessSTM (TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
shutdownRef) do
            IO () -> STM (IO ())
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure do
              Int -> [SeriesElem] -> SpanProcessorM () -> IO ()
run Int
forceFlushTimeout [SeriesElem]
metaForceFlush do
                SpanProcessorM ()
spanProcessorSpecForceFlush
      }
    where
    run :: Int -> [SeriesElem] -> SpanProcessorM () -> IO ()
    run :: Int -> [SeriesElem] -> SpanProcessorM () -> IO ()
run = SpanExporter
-> Logger
-> OnTimeout ()
-> OnException ()
-> Int
-> [SeriesElem]
-> SpanProcessorM ()
-> IO ()
forall a.
SpanExporter
-> Logger
-> OnTimeout a
-> OnException a
-> Int
-> [SeriesElem]
-> SpanProcessorM a
-> IO a
runSpanProcessorM SpanExporter
spanExporter Logger
logger OnTimeout ()
onTimeout OnException ()
onEx

  defaultTimeout :: Int
  defaultTimeout :: Int
defaultTimeout = Int
5_000_000

  metaOnSpanStart :: [SeriesElem]
metaOnSpanStart = Text -> [SeriesElem]
mkLoggingMeta Text
"onSpanStart"
  metaOnSpanEnd :: [SeriesElem]
metaOnSpanEnd = Text -> [SeriesElem]
mkLoggingMeta Text
"onSpanEnd"
  metaShutdown :: [SeriesElem]
metaShutdown = Text -> [SeriesElem]
mkLoggingMeta Text
"shutdown"
  metaForceFlush :: [SeriesElem]
metaForceFlush = Text -> [SeriesElem]
mkLoggingMeta Text
"forceFlush"

  mkLoggingMeta :: Text -> [SeriesElem]
  mkLoggingMeta :: Text -> [SeriesElem]
mkLoggingMeta Text
method =
    [ Key
"spanProcessor" Key -> Value -> SeriesElem
forall v. ToJSON v => Key -> v -> SeriesElem
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object
        [ Key
"name" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
spanProcessorSpecName
        , Key
"method" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
method
        ]
    ]

  SpanProcessorSpec
    { Text
spanProcessorSpecName :: Text
spanProcessorSpecName :: SpanProcessorSpec -> Text
spanProcessorSpecName
    , forall a. Logger -> (SpanExporterSpec -> IO a) -> IO a
spanProcessorSpecExporter :: forall a. Logger -> (SpanExporterSpec -> IO a) -> IO a
spanProcessorSpecExporter :: SpanProcessorSpec
-> forall a. Logger -> (SpanExporterSpec -> IO a) -> IO a
spanProcessorSpecExporter
    , Context
-> (UpdateSpanSpec -> SpanProcessorM (Span Attrs))
-> SpanProcessorM ()
spanProcessorSpecOnSpanStart :: Context
-> (UpdateSpanSpec -> SpanProcessorM (Span Attrs))
-> SpanProcessorM ()
spanProcessorSpecOnSpanStart :: SpanProcessorSpec
-> Context
-> (UpdateSpanSpec -> SpanProcessorM (Span Attrs))
-> SpanProcessorM ()
spanProcessorSpecOnSpanStart
    , Span Attrs -> SpanProcessorM ()
spanProcessorSpecOnSpanEnd :: Span Attrs -> SpanProcessorM ()
spanProcessorSpecOnSpanEnd :: SpanProcessorSpec -> Span Attrs -> SpanProcessorM ()
spanProcessorSpecOnSpanEnd
    , SpanProcessorM ()
spanProcessorSpecShutdown :: SpanProcessorM ()
spanProcessorSpecShutdown :: SpanProcessorSpec -> SpanProcessorM ()
spanProcessorSpecShutdown
    , spanProcessorSpecShutdownTimeout :: SpanProcessorSpec -> Int
spanProcessorSpecShutdownTimeout = Int
shutdownTimeout
    , SpanProcessorM ()
spanProcessorSpecForceFlush :: SpanProcessorM ()
spanProcessorSpecForceFlush :: SpanProcessorSpec -> SpanProcessorM ()
spanProcessorSpecForceFlush
    , spanProcessorSpecForceFlushTimeout :: SpanProcessorSpec -> Int
spanProcessorSpecForceFlushTimeout = Int
forceFlushTimeout
    , spanProcessorSpecOnTimeout :: SpanProcessorSpec -> OnTimeout ()
spanProcessorSpecOnTimeout = OnTimeout ()
onTimeout
    , spanProcessorSpecOnException :: SpanProcessorSpec -> OnException ()
spanProcessorSpecOnException = OnException ()
onEx
    } = SpanProcessorSpec
spanProcessorSpec

data SimpleSpanProcessorSpec = SimpleSpanProcessorSpec
  { SimpleSpanProcessorSpec -> Text
simpleSpanProcessorSpecName :: Text
  , SimpleSpanProcessorSpec
-> forall a. Logger -> (SpanExporterSpec -> IO a) -> IO a
simpleSpanProcessorSpecExporter
      :: forall a. Logger -> (SpanExporterSpec -> IO a) -> IO a
  , SimpleSpanProcessorSpec -> OnSpansExported ()
simpleSpanProcessorSpecOnSpansExported :: OnSpansExported ()
  }

defaultSimpleSpanProcessorSpec :: SimpleSpanProcessorSpec
defaultSimpleSpanProcessorSpec :: SimpleSpanProcessorSpec
defaultSimpleSpanProcessorSpec =
  SimpleSpanProcessorSpec
    { simpleSpanProcessorSpecExporter :: forall a. Logger -> (SpanExporterSpec -> IO a) -> IO a
simpleSpanProcessorSpecExporter = \Logger
_logger -> SpanExporterSpec -> (SpanExporterSpec -> IO a) -> IO a
forall a b. a -> (a -> b) -> b
with SpanExporterSpec
defaultSpanExporterSpec
    , simpleSpanProcessorSpecName :: Text
simpleSpanProcessorSpecName = Text
"simple"
    , simpleSpanProcessorSpecOnSpansExported :: OnSpansExported ()
simpleSpanProcessorSpecOnSpansExported = do
        OnSpansExported SpanExportResult
askSpansExportedResult OnSpansExported SpanExportResult
-> (SpanExportResult -> OnSpansExported ()) -> OnSpansExported ()
forall a b.
OnSpansExported a -> (a -> OnSpansExported b) -> OnSpansExported b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          SpanExportResult
SpanExportResultSuccess -> () -> OnSpansExported ()
forall a. a -> OnSpansExported a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          SpanExportResult
SpanExportResultFailure -> do
            Batch (Span Attrs)
spans <- OnSpansExported (Batch (Span Attrs))
askSpansExported
            [SeriesElem]
pairs <- OnSpansExported [SeriesElem]
askSpansExportedMetadata
            Message -> OnSpansExported ()
forall (m :: * -> *).
(HasCallStack, MonadLogger m) =>
Message -> m ()
logError (Message -> OnSpansExported ()) -> Message -> OnSpansExported ()
forall a b. (a -> b) -> a -> b
$ Text
"Exporter failed to export spans" Text -> [SeriesElem] -> Message
:#
              Key
"spans" Key -> Batch Value -> SeriesElem
forall v. ToJSON v => Key -> v -> SeriesElem
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Span Attrs -> Value) -> Batch (Span Attrs) -> Batch Value
forall a b. (a -> b) -> Batch a -> Batch b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Span Attrs -> Value
forall (attrs :: AttrsFor -> *). Span attrs -> Value
spanSummary Batch (Span Attrs)
spans SeriesElem -> [SeriesElem] -> [SeriesElem]
forall a. a -> [a] -> [a]
: [SeriesElem]
pairs
    }

simpleSpanProcessor
  :: forall a
   . SimpleSpanProcessorSpec
  -> Logger
  -> (SpanProcessorSpec -> IO a)
  -> IO a
simpleSpanProcessor :: forall a.
SimpleSpanProcessorSpec
-> Logger -> (SpanProcessorSpec -> IO a) -> IO a
simpleSpanProcessor SimpleSpanProcessorSpec
simpleSpanProcessorSpec Logger
logger =
  SpanProcessorSpec -> (SpanProcessorSpec -> IO a) -> IO a
forall a b. a -> (a -> b) -> b
with SpanProcessorSpec
defaultSpanProcessorSpec
    { spanProcessorSpecName = name
    , spanProcessorSpecExporter = spanExporterSpec
    , spanProcessorSpecOnSpanEnd = \Span Attrs
span -> do
        Bool -> SpanProcessorM () -> SpanProcessorM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Span Attrs -> Bool
forall (attrs :: AttrsFor -> *). Span attrs -> Bool
spanIsSampled Span Attrs
span) do
          let batch :: Batch (Span Attrs)
batch = Span Attrs -> Batch (Span Attrs)
forall a. a -> Batch a
singletonBatch Span Attrs
span
          SpanExporter
spanExporter <- SpanProcessorM SpanExporter
askSpanExporter
          IO () -> SpanProcessorM ()
forall a. IO a -> SpanProcessorM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> SpanProcessorM ()) -> IO () -> SpanProcessorM ()
forall a b. (a -> b) -> a -> b
$ SpanExporter
-> Batch (Span Attrs) -> (SpanExportResult -> IO ()) -> IO ()
spanExporterExport SpanExporter
spanExporter Batch (Span Attrs)
batch \SpanExportResult
spanExportResult -> do
            (LoggingT IO () -> Logger -> IO ())
-> Logger -> LoggingT IO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip LoggingT IO () -> Logger -> IO ()
forall (m :: * -> *) a. LoggingT m a -> Logger -> m a
runLoggingT Logger
logger do
              OnSpansExported ()
-> Batch (Span Attrs)
-> SpanExportResult
-> [SeriesElem]
-> LoggingT IO ()
forall a.
OnSpansExported a
-> Batch (Span Attrs)
-> SpanExportResult
-> [SeriesElem]
-> LoggingT IO a
runOnSpansExported OnSpansExported ()
onSpansExported Batch (Span Attrs)
batch SpanExportResult
spanExportResult [SeriesElem]
metaOnSpanEnd
    }
  where
  metaOnSpanEnd :: [SeriesElem]
  metaOnSpanEnd :: [SeriesElem]
metaOnSpanEnd = Text -> [SeriesElem]
mkLoggingMeta Text
"onSpanEnd"

  mkLoggingMeta :: Text -> [SeriesElem]
  mkLoggingMeta :: Text -> [SeriesElem]
mkLoggingMeta Text
method =
    [ Key
"spanProcessorSpec" Key -> Value -> SeriesElem
forall v. ToJSON v => Key -> v -> SeriesElem
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object
        [ Key
"name" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
name
        , Key
"method" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
method
        ]
    ]

  SimpleSpanProcessorSpec
    { simpleSpanProcessorSpecName :: SimpleSpanProcessorSpec -> Text
simpleSpanProcessorSpecName = Text
name
    , simpleSpanProcessorSpecExporter :: SimpleSpanProcessorSpec
-> forall a. Logger -> (SpanExporterSpec -> IO a) -> IO a
simpleSpanProcessorSpecExporter = forall a. Logger -> (SpanExporterSpec -> IO a) -> IO a
spanExporterSpec
    , simpleSpanProcessorSpecOnSpansExported :: SimpleSpanProcessorSpec -> OnSpansExported ()
simpleSpanProcessorSpecOnSpansExported = OnSpansExported ()
onSpansExported
    } = SimpleSpanProcessorSpec
simpleSpanProcessorSpec

data SpanProcessorSpec = SpanProcessorSpec
  { SpanProcessorSpec -> Text
spanProcessorSpecName :: Text
  , SpanProcessorSpec
-> forall a. Logger -> (SpanExporterSpec -> IO a) -> IO a
spanProcessorSpecExporter
      :: forall a. Logger -> (SpanExporterSpec -> IO a) -> IO a
  , SpanProcessorSpec
-> Context
-> (UpdateSpanSpec -> SpanProcessorM (Span Attrs))
-> SpanProcessorM ()
spanProcessorSpecOnSpanStart
      :: Context -- Parent context
      -> (UpdateSpanSpec -> SpanProcessorM (Span Attrs))
      -> SpanProcessorM ()
  , SpanProcessorSpec -> Span Attrs -> SpanProcessorM ()
spanProcessorSpecOnSpanEnd :: Span Attrs -> SpanProcessorM ()
  , SpanProcessorSpec -> SpanProcessorM ()
spanProcessorSpecShutdown :: SpanProcessorM ()
  , SpanProcessorSpec -> Int
spanProcessorSpecShutdownTimeout :: Int
  , SpanProcessorSpec -> SpanProcessorM ()
spanProcessorSpecForceFlush :: SpanProcessorM ()
  , SpanProcessorSpec -> Int
spanProcessorSpecForceFlushTimeout :: Int
  , SpanProcessorSpec -> OnTimeout ()
spanProcessorSpecOnTimeout :: OnTimeout ()
  , SpanProcessorSpec -> OnException ()
spanProcessorSpecOnException :: OnException ()
  }

defaultSpanProcessorSpec :: SpanProcessorSpec
defaultSpanProcessorSpec :: SpanProcessorSpec
defaultSpanProcessorSpec =
  SpanProcessorSpec
    { spanProcessorSpecName :: Text
spanProcessorSpecName = Text
"default"
    , spanProcessorSpecExporter :: forall a. Logger -> (SpanExporterSpec -> IO a) -> IO a
spanProcessorSpecExporter = \Logger
_logger -> SpanExporterSpec -> (SpanExporterSpec -> IO a) -> IO a
forall a b. a -> (a -> b) -> b
with SpanExporterSpec
defaultSpanExporterSpec
    , spanProcessorSpecOnSpanStart :: Context
-> (UpdateSpanSpec -> SpanProcessorM (Span Attrs))
-> SpanProcessorM ()
spanProcessorSpecOnSpanStart = Context
-> (UpdateSpanSpec -> SpanProcessorM (Span Attrs))
-> SpanProcessorM ()
forall a. Monoid a => a
mempty
    , spanProcessorSpecOnSpanEnd :: Span Attrs -> SpanProcessorM ()
spanProcessorSpecOnSpanEnd = Span Attrs -> SpanProcessorM ()
forall a. Monoid a => a
mempty
    , spanProcessorSpecShutdown :: SpanProcessorM ()
spanProcessorSpecShutdown = do
        SpanExporter
spanExporter <- SpanProcessorM SpanExporter
askSpanExporter
        IO () -> SpanProcessorM ()
forall a. IO a -> SpanProcessorM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> SpanProcessorM ()) -> IO () -> SpanProcessorM ()
forall a b. (a -> b) -> a -> b
$ SpanExporter -> IO ()
spanExporterShutdown SpanExporter
spanExporter
    , spanProcessorSpecShutdownTimeout :: Int
spanProcessorSpecShutdownTimeout = Int
30_000_000
    , spanProcessorSpecForceFlush :: SpanProcessorM ()
spanProcessorSpecForceFlush = do
        SpanExporter
spanExporter <- SpanProcessorM SpanExporter
askSpanExporter
        IO () -> SpanProcessorM ()
forall a. IO a -> SpanProcessorM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> SpanProcessorM ()) -> IO () -> SpanProcessorM ()
forall a b. (a -> b) -> a -> b
$ SpanExporter -> IO ()
spanExporterForceFlush SpanExporter
spanExporter
    , spanProcessorSpecForceFlushTimeout :: Int
spanProcessorSpecForceFlushTimeout = Int
30_000_000
    , spanProcessorSpecOnTimeout :: OnTimeout ()
spanProcessorSpecOnTimeout = do
        Int
timeoutMicros <- OnTimeout Int
askTimeoutMicros
        [SeriesElem]
pairs <- OnTimeout [SeriesElem]
askTimeoutMetadata
        Message -> OnTimeout ()
forall (m :: * -> *).
(HasCallStack, MonadLogger m) =>
Message -> m ()
logError (Message -> OnTimeout ()) -> Message -> OnTimeout ()
forall a b. (a -> b) -> a -> b
$ Text
"Action did not complete within timeout" Text -> [SeriesElem] -> Message
:#
          Key
"timeoutMicros" Key -> Int -> SeriesElem
forall v. ToJSON v => Key -> v -> SeriesElem
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Int
timeoutMicros SeriesElem -> [SeriesElem] -> [SeriesElem]
forall a. a -> [a] -> [a]
: [SeriesElem]
pairs
    , spanProcessorSpecOnException :: OnException ()
spanProcessorSpecOnException = do
        SomeException e
ex <- OnException SomeException
askException
        [SeriesElem]
pairs <- OnException [SeriesElem]
askExceptionMetadata
        Message -> OnException ()
forall (m :: * -> *).
(HasCallStack, MonadLogger m) =>
Message -> m ()
logError (Message -> OnException ()) -> Message -> OnException ()
forall a b. (a -> b) -> a -> b
$ Text
"Ignoring exception" Text -> [SeriesElem] -> Message
:#
          Key
"exception" Key -> [Char] -> SeriesElem
forall v. ToJSON v => Key -> v -> SeriesElem
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= e -> [Char]
forall e. Exception e => e -> [Char]
displayException e
ex SeriesElem -> [SeriesElem] -> [SeriesElem]
forall a. a -> [a] -> [a]
: [SeriesElem]
pairs
    }

data SpanExportResult
  = SpanExportResultSuccess
  | SpanExportResultFailure
  deriving stock (SpanExportResult -> SpanExportResult -> Bool
(SpanExportResult -> SpanExportResult -> Bool)
-> (SpanExportResult -> SpanExportResult -> Bool)
-> Eq SpanExportResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SpanExportResult -> SpanExportResult -> Bool
== :: SpanExportResult -> SpanExportResult -> Bool
$c/= :: SpanExportResult -> SpanExportResult -> Bool
/= :: SpanExportResult -> SpanExportResult -> Bool
Eq, Int -> SpanExportResult -> ShowS
[SpanExportResult] -> ShowS
SpanExportResult -> [Char]
(Int -> SpanExportResult -> ShowS)
-> (SpanExportResult -> [Char])
-> ([SpanExportResult] -> ShowS)
-> Show SpanExportResult
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SpanExportResult -> ShowS
showsPrec :: Int -> SpanExportResult -> ShowS
$cshow :: SpanExportResult -> [Char]
show :: SpanExportResult -> [Char]
$cshowList :: [SpanExportResult] -> ShowS
showList :: [SpanExportResult] -> ShowS
Show)

data SpanExporter = SpanExporter
  { SpanExporter
-> Batch (Span Attrs) -> (SpanExportResult -> IO ()) -> IO ()
spanExporterExport
      :: Batch (Span Attrs)
      -> (SpanExportResult -> IO ())
      -> IO ()
  , SpanExporter -> IO ()
spanExporterShutdown :: IO ()
  , SpanExporter -> IO ()
spanExporterForceFlush :: IO ()
  }

buildSpanExporter
  :: Resource Attrs
  -> Logger
  -> SpanExporterSpec
  -> IO SpanExporter
buildSpanExporter :: Resource Attrs -> Logger -> SpanExporterSpec -> IO SpanExporter
buildSpanExporter Resource Attrs
res Logger
logger SpanExporterSpec
spanExporterSpec = do
  TVar Bool
shutdownRef <- IO (TVar Bool) -> IO (TVar Bool)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (TVar Bool) -> IO (TVar Bool))
-> IO (TVar Bool) -> IO (TVar Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> IO (TVar Bool)
forall a. a -> IO (TVar a)
newTVarIO Bool
False
  SpanExporter -> IO SpanExporter
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SpanExporter -> IO SpanExporter)
-> SpanExporter -> IO SpanExporter
forall a b. (a -> b) -> a -> b
$ TVar Bool -> SpanExporter
spanExporter TVar Bool
shutdownRef
  where
  spanExporter :: TVar Bool -> SpanExporter
spanExporter TVar Bool
shutdownRef =
    SpanExporter
      { spanExporterExport :: Batch (Span Attrs) -> (SpanExportResult -> IO ()) -> IO ()
spanExporterExport = \Batch (Span Attrs)
spans SpanExportResult -> IO ()
onSpansExported -> do
          STM Bool -> STM (IO ()) -> IO ()
forall a. Monoid a => STM Bool -> STM (IO a) -> IO a
unlessSTM (TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
shutdownRef) do
            IO () -> STM (IO ())
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure do
              Resource Attrs
-> Logger
-> OnTimeout ()
-> OnException ()
-> Int
-> [SeriesElem]
-> SpanExporterM ()
-> IO ()
forall a.
Resource Attrs
-> Logger
-> OnTimeout a
-> OnException a
-> Int
-> [SeriesElem]
-> SpanExporterM a
-> IO a
runSpanExporterM Resource Attrs
res Logger
logger OnTimeout ()
onTimeout OnException ()
onEx Int
defaultTimeout [SeriesElem]
metaExport do
                Batch (Span Attrs)
-> (SpanExportResult -> IO ()) -> SpanExporterM ()
spanExporterSpecExport Batch (Span Attrs)
spans \SpanExportResult
spanExportResult -> do
                  IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ SpanExportResult -> IO ()
onSpansExported SpanExportResult
spanExportResult
      , spanExporterShutdown :: IO ()
spanExporterShutdown = do
          STM Bool -> STM (IO ()) -> IO ()
forall a. Monoid a => STM Bool -> STM (IO a) -> IO a
unlessSTM (TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
shutdownRef) do
            TVar Bool -> Bool -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Bool
shutdownRef Bool
True
            IO () -> STM (IO ())
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure do
              Resource Attrs
-> Logger
-> OnTimeout ()
-> OnException ()
-> Int
-> [SeriesElem]
-> SpanExporterM ()
-> IO ()
forall a.
Resource Attrs
-> Logger
-> OnTimeout a
-> OnException a
-> Int
-> [SeriesElem]
-> SpanExporterM a
-> IO a
runSpanExporterM Resource Attrs
res Logger
logger OnTimeout ()
onTimeout OnException ()
onEx Int
shutdownTimeout [SeriesElem]
metaShutdown do
                SpanExporterM ()
spanExporterSpecShutdown
      , spanExporterForceFlush :: IO ()
spanExporterForceFlush = do
          STM Bool -> STM (IO ()) -> IO ()
forall a. Monoid a => STM Bool -> STM (IO a) -> IO a
unlessSTM (TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
shutdownRef) do
            IO () -> STM (IO ())
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure do
              Resource Attrs
-> Logger
-> OnTimeout ()
-> OnException ()
-> Int
-> [SeriesElem]
-> SpanExporterM ()
-> IO ()
forall a.
Resource Attrs
-> Logger
-> OnTimeout a
-> OnException a
-> Int
-> [SeriesElem]
-> SpanExporterM a
-> IO a
runSpanExporterM Resource Attrs
res Logger
logger OnTimeout ()
onTimeout OnException ()
onEx Int
forceFlushTimeout [SeriesElem]
metaForceFlush do
                SpanExporterM ()
spanExporterSpecForceFlush
      }

  defaultTimeout :: Int
  defaultTimeout :: Int
defaultTimeout = Int
10_000_000

  metaExport :: [SeriesElem]
metaExport = Text -> [SeriesElem]
mkLoggingMeta Text
"export"
  metaShutdown :: [SeriesElem]
metaShutdown = Text -> [SeriesElem]
mkLoggingMeta Text
"shutdown"
  metaForceFlush :: [SeriesElem]
metaForceFlush = Text -> [SeriesElem]
mkLoggingMeta Text
"forceFlush"

  mkLoggingMeta :: Text -> [SeriesElem]
  mkLoggingMeta :: Text -> [SeriesElem]
mkLoggingMeta Text
method =
    [ Key
"spanExporter" Key -> Value -> SeriesElem
forall v. ToJSON v => Key -> v -> SeriesElem
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object
        [ Key
"name" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
spanExporterSpecName
        , Key
"method" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
method
        ]
    ]

  SpanExporterSpec
    { Text
spanExporterSpecName :: SpanExporterSpec -> Text
spanExporterSpecName :: Text
spanExporterSpecName
    , Batch (Span Attrs)
-> (SpanExportResult -> IO ()) -> SpanExporterM ()
spanExporterSpecExport :: Batch (Span Attrs)
-> (SpanExportResult -> IO ()) -> SpanExporterM ()
spanExporterSpecExport :: SpanExporterSpec
-> Batch (Span Attrs)
-> (SpanExportResult -> IO ())
-> SpanExporterM ()
spanExporterSpecExport
    , SpanExporterM ()
spanExporterSpecShutdown :: SpanExporterM ()
spanExporterSpecShutdown :: SpanExporterSpec -> SpanExporterM ()
spanExporterSpecShutdown
    , spanExporterSpecShutdownTimeout :: SpanExporterSpec -> Int
spanExporterSpecShutdownTimeout = Int
shutdownTimeout
    , SpanExporterM ()
spanExporterSpecForceFlush :: SpanExporterM ()
spanExporterSpecForceFlush :: SpanExporterSpec -> SpanExporterM ()
spanExporterSpecForceFlush
    , spanExporterSpecForceFlushTimeout :: SpanExporterSpec -> Int
spanExporterSpecForceFlushTimeout = Int
forceFlushTimeout
    , spanExporterSpecOnTimeout :: SpanExporterSpec -> OnTimeout ()
spanExporterSpecOnTimeout = OnTimeout ()
onTimeout
    , spanExporterSpecOnException :: SpanExporterSpec -> OnException ()
spanExporterSpecOnException = OnException ()
onEx
    } = SpanExporterSpec
spanExporterSpec

data OTLPSpanExporterSpec = OTLPSpanExporterSpec
  { OTLPSpanExporterSpec -> Manager
otlpSpanExporterSpecManager :: Manager
  , OTLPSpanExporterSpec -> URI
otlpSpanExporterSpecEndpoint :: URI
  , OTLPSpanExporterSpec -> Int
otlpSpanExporterSpecTimeout :: Int
  , OTLPSpanExporterSpec -> OTLPProtocol
otlpSpanExporterSpecProtocol :: OTLPProtocol
    -- | A list of headers to include when communicating with the observability
    -- backend (e.g. Honeycomb) over HTTP.
    --
    -- Use this list to include the necessary secrets for talking with your
    -- observability backend(s).
  , OTLPSpanExporterSpec -> [Header]
otlpSpanExporterSpecHeaders :: [Header]
    -- | A list of sensitive header names that will be redacted before a
    -- 'Request' is displayed. Note that the only time a 'Request' is displayed
    -- is when the span exporter encounters an 'HttpException' when
    -- communicating with the observability backend (e.g. Honeycomb). The
    -- default is 'mempty'.
    --
    -- Use this list to avoid leaking sensitive data like API keys into your
    -- logs:
    --
    -- @
    -- 'defaultOTLPSpanExporterSpec'
    --   { 'otlpSpanExporterSpecRedactedRequestHeaders' = ["x-honeycomb-team"]
    --   }
    -- @
  , OTLPSpanExporterSpec -> [HeaderName]
otlpSpanExporterSpecRedactedRequestHeaders :: [HeaderName]
    -- | A list of sensitive header names that will be redacted before a
    -- 'Response' is displayed. Note that the only time a 'Response' is
    -- displayed is when the span exporter encounters an 'HttpException' when
    -- communicating with the observability backend (e.g. Honeycomb). The
    -- default is 'mempty'.
    --
    -- Use this list to avoid leaking sensitive data like API keys into your
    -- logs.
    --
    -- @
    -- 'defaultOTLPSpanExporterSpec'
    --   { 'otlpSpanExporterSpecRedactedResponseHeaders' = ["x-honeycomb-team"]
    --   }
    -- @
  , OTLPSpanExporterSpec -> [HeaderName]
otlpSpanExporterSpecRedactedResponseHeaders :: [HeaderName]
  , OTLPSpanExporterSpec -> Int
otlpSpanExporterSpecWorkerQueueSize :: Int
  , OTLPSpanExporterSpec -> Int
otlpSpanExporterSpecWorkerCount :: Int
    -- | The retry policy to use when communicating with the observability
    -- backend produces an exception.
    --
    -- The default is defined as follows:
    --
    -- @
    -- 'fullJitterBackoff' 10_000 <> 'limitRetries' 10
    -- @
    --
    -- 'Control.Retry.simulatePolicyPP' can be used to get an idea of the retry
    -- policy's iterations and total cumulative delay:
    --
    -- > ghci> simulatePolicyPP 10 $ fullJitterBackoff 10000 <> limitRetries 10
    -- > 0: 6.659ms
    -- > 1: 12.302ms
    -- > 2: 21.228ms
    -- > 3: 45.048ms
    -- > 4: 128.142ms
    -- > 5: 274.269ms
    -- > 6: 351.933ms
    -- > 7: 688.239ms
    -- > 8: 1313.14ms
    -- > 9: 4806.224ms
    -- > 10: Inhibit
    -- > Total cumulative delay would be: 7647.184ms
    --
    -- For more info on defining custom retry policies, see "Control.Retry".
  , OTLPSpanExporterSpec -> RetryPolicyM IO
otlpSpanExporterSpecRetryPolicy :: RetryPolicyM IO
  }

-- TODO: Env vars
defaultOTLPSpanExporterSpec :: OTLPSpanExporterSpec
defaultOTLPSpanExporterSpec :: OTLPSpanExporterSpec
defaultOTLPSpanExporterSpec =
  OTLPSpanExporterSpec
    { otlpSpanExporterSpecManager :: Manager
otlpSpanExporterSpecManager = Manager
defaultManager
    , otlpSpanExporterSpecEndpoint :: URI
otlpSpanExporterSpecEndpoint = Maybe URI -> URI
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe URI -> URI) -> Maybe URI -> URI
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe URI
parseURI [Char]
"http://localhost:4318/v1/traces"
    , otlpSpanExporterSpecTimeout :: Int
otlpSpanExporterSpecTimeout = Int
10_000_000
    , otlpSpanExporterSpecProtocol :: OTLPProtocol
otlpSpanExporterSpecProtocol = OTLPProtocol
httpProtobufProtocol
    , otlpSpanExporterSpecHeaders :: [Header]
otlpSpanExporterSpecHeaders = [Header]
forall a. Monoid a => a
mempty
    , otlpSpanExporterSpecRedactedRequestHeaders :: [HeaderName]
otlpSpanExporterSpecRedactedRequestHeaders = [HeaderName]
forall a. Monoid a => a
mempty
    , otlpSpanExporterSpecRedactedResponseHeaders :: [HeaderName]
otlpSpanExporterSpecRedactedResponseHeaders = [HeaderName]
forall a. Monoid a => a
mempty
    , otlpSpanExporterSpecWorkerQueueSize :: Int
otlpSpanExporterSpecWorkerQueueSize =
        ConcurrentWorkersSpec Any -> Int
forall item. ConcurrentWorkersSpec item -> Int
concurrentWorkersSpecQueueSize ConcurrentWorkersSpec Any
forall item. ConcurrentWorkersSpec item
defaultConcurrentWorkersSpec
    , otlpSpanExporterSpecWorkerCount :: Int
otlpSpanExporterSpecWorkerCount =
        ConcurrentWorkersSpec Any -> Int
forall item. ConcurrentWorkersSpec item -> Int
concurrentWorkersSpecWorkerCount ConcurrentWorkersSpec Any
forall item. ConcurrentWorkersSpec item
defaultConcurrentWorkersSpec
    , otlpSpanExporterSpecRetryPolicy :: RetryPolicyM IO
otlpSpanExporterSpecRetryPolicy =
        Int -> RetryPolicyM IO
forall (m :: * -> *). MonadIO m => Int -> RetryPolicyM m
fullJitterBackoff Int
10_000 RetryPolicyM IO -> RetryPolicyM IO -> RetryPolicyM IO
forall a. Semigroup a => a -> a -> a
<> Int -> RetryPolicy
limitRetries Int
10
    }

otlpSpanExporter
  :: forall a
   . OTLPSpanExporterSpec
  -> Logger
  -> (SpanExporterSpec -> IO a)
  -> IO a
otlpSpanExporter :: forall a.
OTLPSpanExporterSpec
-> Logger -> (SpanExporterSpec -> IO a) -> IO a
otlpSpanExporter OTLPSpanExporterSpec
otlpSpanExporterSpec Logger
logger SpanExporterSpec -> IO a
f = do
  Request
req <- do
    ((Request -> Request) -> IO Request -> IO Request)
-> IO Request -> (Request -> Request) -> IO Request
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Request -> Request) -> IO Request -> IO Request
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (URI -> IO Request
forall (m :: * -> *). MonadThrow m => URI -> m Request
requestFromURI URI
endpoint) \Request
baseReq ->
      Request -> Request
setRequestCheckStatus Request
baseReq
        { method = "POST"
        , requestHeaders =
            DList.toList $ mconcat
              [ DList.singleton (hContentType, "application/x-protobuf")
              , DList.fromList headers
              , DList.fromList $ requestHeaders baseReq
              ]
        }
  ConcurrentWorkersSpec OTLPSpanExporterItem
-> (ConcurrentWorkers OTLPSpanExporterItem -> IO a) -> IO a
forall item a.
(ToJSON item, Typeable item) =>
ConcurrentWorkersSpec item
-> (ConcurrentWorkers item -> IO a) -> IO a
withConcurrentWorkers (Request -> ConcurrentWorkersSpec OTLPSpanExporterItem
concurrentWorkersSpec Request
req) \ConcurrentWorkers OTLPSpanExporterItem
workers -> do
    SpanExporterSpec -> IO a
f (SpanExporterSpec -> IO a) -> SpanExporterSpec -> IO a
forall a b. (a -> b) -> a -> b
$ ConcurrentWorkers OTLPSpanExporterItem -> SpanExporterSpec
spanExporterSpec ConcurrentWorkers OTLPSpanExporterItem
workers
  where
  spanExporterSpec :: ConcurrentWorkers OTLPSpanExporterItem -> SpanExporterSpec
spanExporterSpec ConcurrentWorkers OTLPSpanExporterItem
workers =
    SpanExporterSpec
defaultSpanExporterSpec
      { spanExporterSpecName = "otlp"
      , spanExporterSpecExport = \Batch (Span Attrs)
spans SpanExportResult -> IO ()
onSpansExported -> do
          Resource Attrs
res <- SpanExporterM (Resource Attrs)
askResource
          IO () -> SpanExporterM ()
forall a. IO a -> SpanExporterM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> SpanExporterM ()) -> IO () -> SpanExporterM ()
forall a b. (a -> b) -> a -> b
$ ConcurrentWorkers OTLPSpanExporterItem
-> OTLPSpanExporterItem -> IO ()
forall item. ConcurrentWorkers item -> item -> IO ()
concurrentWorkersEnqueueItem ConcurrentWorkers OTLPSpanExporterItem
workers OTLPSpanExporterItem
            { otlpSpanExporterItemBatch :: Batch (Span Attrs)
otlpSpanExporterItemBatch = Batch (Span Attrs)
spans
            , otlpSpanExporterItemCallback :: SpanExportResult -> IO ()
otlpSpanExporterItemCallback = SpanExportResult -> IO ()
onSpansExported
            , otlpSpanExporterResource :: Resource Attrs
otlpSpanExporterResource = Resource Attrs
res
            }
      , spanExporterSpecShutdown = do
          liftIO $ concurrentWorkersStopWorkers workers
      }

  concurrentWorkersSpec :: Request -> ConcurrentWorkersSpec OTLPSpanExporterItem
concurrentWorkersSpec Request
req =
    ConcurrentWorkersSpec Any
forall item. ConcurrentWorkersSpec item
defaultConcurrentWorkersSpec
      { concurrentWorkersSpecQueueSize = queueSize
      , concurrentWorkersSpecWorkerCount = workerCount
      , concurrentWorkersSpecProcessItem = \OTLPSpanExporterItem
item -> do
          Maybe (Response ByteString)
mResp <- do
            Int -> IO (Response ByteString) -> IO (Maybe (Response ByteString))
forall a. Int -> IO a -> IO (Maybe a)
timeout Int
exportTimeout do
              Request -> IO (Response ByteString)
send Request
req
                { requestBody =
                    RequestBodyBS
                      $ ProtoLens.encodeMessage
                      $ exportTraceServiceRequest (otlpSpanExporterResource item)
                      $ otlpSpanExporterItemBatch item
                }
          (LoggingT IO () -> Logger -> IO ())
-> Logger -> LoggingT IO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip LoggingT IO () -> Logger -> IO ()
forall (m :: * -> *) a. LoggingT m a -> Logger -> m a
runLoggingT Logger
logger do
            case Maybe (Response ByteString)
mResp of
              Just Response ByteString
_resp -> () -> LoggingT IO ()
forall a. a -> LoggingT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
              Maybe (Response ByteString)
Nothing -> do
                Message -> LoggingT IO ()
forall (m :: * -> *).
(HasCallStack, MonadLogger m) =>
Message -> m ()
logError (Message -> LoggingT IO ()) -> Message -> LoggingT IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Exporting spans timed out" Text -> [SeriesElem] -> Message
:#
                  Key
"spans" Key -> Batch Value -> SeriesElem
forall v. ToJSON v => Key -> v -> SeriesElem
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Span Attrs -> Value) -> Batch (Span Attrs) -> Batch Value
forall a b. (a -> b) -> Batch a -> Batch b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Span Attrs -> Value
forall (attrs :: AttrsFor -> *). Span attrs -> Value
spanSummary (OTLPSpanExporterItem -> Batch (Span Attrs)
otlpSpanExporterItemBatch OTLPSpanExporterItem
item) SeriesElem -> [SeriesElem] -> [SeriesElem]
forall a. a -> [a] -> [a]
: [SeriesElem]
loggingMeta
          OTLPSpanExporterItem -> SpanExportResult -> IO ()
otlpSpanExporterItemCallback OTLPSpanExporterItem
item SpanExportResult
SpanExportResultSuccess
      , concurrentWorkersSpecOnException = \OTLPSpanExporterItem
item -> do
          SomeException e
ex <- do
            Set HeaderName -> Set HeaderName -> SomeException -> SomeException
redactHttpExceptionHeaders Set HeaderName
redactedReqHeaders Set HeaderName
redactedRespHeaders (SomeException -> SomeException)
-> OnException SomeException -> OnException SomeException
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> OnException SomeException
askException
          [SeriesElem]
pairs <- OnException [SeriesElem]
askExceptionMetadata
          Message -> OnException ()
forall (m :: * -> *).
(HasCallStack, MonadLogger m) =>
Message -> m ()
logError (Message -> OnException ()) -> Message -> OnException ()
forall a b. (a -> b) -> a -> b
$ Text
"Concurrent worker ignoring exception from exporting batch" Text -> [SeriesElem] -> Message
:#
            Key
"exception" Key -> [Char] -> SeriesElem
forall v. ToJSON v => Key -> v -> SeriesElem
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= e -> [Char]
forall e. Exception e => e -> [Char]
displayException e
ex
              SeriesElem -> [SeriesElem] -> [SeriesElem]
forall a. a -> [a] -> [a]
: Key
"batch" Key -> Batch Value -> SeriesElem
forall v. ToJSON v => Key -> v -> SeriesElem
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Span Attrs -> Value) -> Batch (Span Attrs) -> Batch Value
forall a b. (a -> b) -> Batch a -> Batch b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Span Attrs -> Value
forall (attrs :: AttrsFor -> *). Span attrs -> Value
spanSummary (OTLPSpanExporterItem -> Batch (Span Attrs)
otlpSpanExporterItemBatch OTLPSpanExporterItem
item)
              SeriesElem -> [SeriesElem] -> [SeriesElem]
forall a. a -> [a] -> [a]
: [SeriesElem]
pairs
          IO () -> OnException ()
forall a. IO a -> OnException a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> OnException ()) -> IO () -> OnException ()
forall a b. (a -> b) -> a -> b
$ OTLPSpanExporterItem -> SpanExportResult -> IO ()
otlpSpanExporterItemCallback OTLPSpanExporterItem
item SpanExportResult
SpanExportResultFailure
      , concurrentWorkersSpecLogger = logger
      , concurrentWorkersSpecLoggingMeta = loggingMeta
      }

  send :: Request -> IO (Response ByteString)
  send :: Request -> IO (Response ByteString)
send Request
req = do
    RetryPolicyM IO
-> [RetryStatus -> Handler IO RetryAction]
-> (RetryStatus -> IO (Response ByteString))
-> IO (Response ByteString)
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
RetryPolicyM m
-> [RetryStatus -> Handler m RetryAction]
-> (RetryStatus -> m a)
-> m a
recoveringDynamic RetryPolicyM IO
retryPolicy [RetryStatus -> Handler IO RetryAction]
handlers \RetryStatus
_retryStatus -> do
      Request -> Manager -> IO (Response ByteString)
httpLbs Request
req Manager
manager
    where
    handlers :: [RetryStatus -> Handler IO RetryAction]
    handlers :: [RetryStatus -> Handler IO RetryAction]
handlers =
      [ Handler IO RetryAction -> RetryStatus -> Handler IO RetryAction
forall a b. a -> b -> a
const (Handler IO RetryAction -> RetryStatus -> Handler IO RetryAction)
-> Handler IO RetryAction -> RetryStatus -> Handler IO RetryAction
forall a b. (a -> b) -> a -> b
$ (AsyncException -> IO RetryAction) -> Handler IO RetryAction
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler \(AsyncException
_ :: AsyncException) -> RetryAction -> IO RetryAction
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RetryAction
DontRetry
      , Handler IO RetryAction -> RetryStatus -> Handler IO RetryAction
forall a b. a -> b -> a
const (Handler IO RetryAction -> RetryStatus -> Handler IO RetryAction)
-> Handler IO RetryAction -> RetryStatus -> Handler IO RetryAction
forall a b. (a -> b) -> a -> b
$ (SomeAsyncException -> IO RetryAction) -> Handler IO RetryAction
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler \(SomeAsyncException
_ :: SomeAsyncException) -> RetryAction -> IO RetryAction
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RetryAction
DontRetry
      , \RetryStatus
retryStatus -> (HttpException -> IO RetryAction) -> Handler IO RetryAction
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler \case
          InvalidUrlException {} -> RetryAction -> IO RetryAction
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RetryAction
DontRetry
          httpEx :: HttpException
httpEx@(HttpExceptionRequest Request
_req HttpExceptionContent
httpExceptionContent) -> do
            case HttpExceptionContent
httpExceptionContent of
              ConnectionClosed {} -> RetryStatus
-> Text -> Maybe SomeException -> Maybe Int -> IO RetryAction
consult RetryStatus
retryStatus Text
"ConnectionClosed" Maybe SomeException
mSomeHttpEx Maybe Int
forall a. Maybe a
Nothing
              ConnectionFailure SomeException
someEx -> RetryStatus
-> Text -> Maybe SomeException -> Maybe Int -> IO RetryAction
consult RetryStatus
retryStatus Text
"ConnectionFailure" (SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just SomeException
someEx) Maybe Int
forall a. Maybe a
Nothing
              ConnectionTimeout {} -> RetryStatus
-> Text -> Maybe SomeException -> Maybe Int -> IO RetryAction
consult RetryStatus
retryStatus Text
"ConnectionTimeout" Maybe SomeException
mSomeHttpEx Maybe Int
forall a. Maybe a
Nothing
              InternalException SomeException
someEx -> RetryStatus
-> Text -> Maybe SomeException -> Maybe Int -> IO RetryAction
consult RetryStatus
retryStatus Text
"InternalException" (SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just SomeException
someEx) Maybe Int
forall a. Maybe a
Nothing
              ResponseTimeout {} -> RetryStatus
-> Text -> Maybe SomeException -> Maybe Int -> IO RetryAction
consult RetryStatus
retryStatus Text
"ResponseTimeout" Maybe SomeException
mSomeHttpEx Maybe Int
forall a. Maybe a
Nothing
              StatusCodeException Response ()
resp ByteString
_bs
                | Status
status Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
tooManyRequests429 Bool -> Bool -> Bool
|| Status
status Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
serviceUnavailable503 ->
                    HttpException -> RetryStatus -> Response () -> IO RetryAction
checkRetryAfterHeader HttpException
httpEx RetryStatus
retryStatus Response ()
resp
                | Status
status Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
badGateway502 Bool -> Bool -> Bool
|| Status
status Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
gatewayTimeout504 ->
                    RetryStatus
-> Text -> Maybe SomeException -> Maybe Int -> IO RetryAction
consult RetryStatus
retryStatus Text
statusCodeText Maybe SomeException
mSomeHttpEx Maybe Int
forall a. Maybe a
Nothing
                | Bool
otherwise -> RetryAction -> IO RetryAction
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RetryAction
DontRetry
                where
                statusCodeText :: Text
                statusCodeText :: Text
statusCodeText = [Char] -> Text
pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Int -> [Char]
forall a. Show a => a -> [Char]
show (Int -> [Char]) -> Int -> [Char]
forall a b. (a -> b) -> a -> b
$ Status -> Int
statusCode (Status -> Int) -> Status -> Int
forall a b. (a -> b) -> a -> b
$ Response () -> Status
forall body. Response body -> Status
responseStatus Response ()
resp

                status :: Status
                status :: Status
status = Response () -> Status
forall body. Response body -> Status
responseStatus Response ()
resp
              HttpExceptionContent
_ -> RetryAction -> IO RetryAction
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RetryAction
DontRetry
              where
              mSomeHttpEx :: Maybe SomeException
              mSomeHttpEx :: Maybe SomeException
mSomeHttpEx = 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
toException HttpException
httpEx
      ]
      where
      checkRetryAfterHeader :: HttpException -> RetryStatus -> Response () -> IO RetryAction
      checkRetryAfterHeader :: HttpException -> RetryStatus -> Response () -> IO RetryAction
checkRetryAfterHeader HttpException
httpEx RetryStatus
retryStatus Response ()
resp = do
        case HeaderName -> [Header] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hRetryAfter ([Header] -> Maybe ByteString) -> [Header] -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Response () -> [Header]
forall body. Response body -> [Header]
responseHeaders Response ()
resp of
          Maybe ByteString
Nothing -> RetryStatus
-> Text -> Maybe SomeException -> Maybe Int -> IO RetryAction
consult RetryStatus
retryStatus Text
statusCodeText Maybe SomeException
mSomeHttpEx Maybe Int
forall a. Maybe a
Nothing
          Just ByteString
headerVal -> do
            case [Char] -> Maybe (Either NominalDiffTime UTCTime)
parseRetryAfterHeader ([Char] -> Maybe (Either NominalDiffTime UTCTime))
-> [Char] -> Maybe (Either NominalDiffTime UTCTime)
forall a b. (a -> b) -> a -> b
$ ByteString -> [Char]
ByteString.Char8.unpack ByteString
headerVal of
              Maybe (Either NominalDiffTime UTCTime)
Nothing -> RetryStatus
-> Text -> Maybe SomeException -> Maybe Int -> IO RetryAction
consult RetryStatus
retryStatus Text
statusCodeText Maybe SomeException
mSomeHttpEx Maybe Int
forall a. Maybe a
Nothing
              Just (Left NominalDiffTime
delay) -> do
                RetryStatus
-> Text -> Maybe SomeException -> Maybe Int -> IO RetryAction
consult RetryStatus
retryStatus Text
statusCodeText Maybe SomeException
mSomeHttpEx (Maybe Int -> IO RetryAction) -> Maybe Int -> IO RetryAction
forall a b. (a -> b) -> a -> b
$ Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> Int
forall b. Integral b => NominalDiffTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (NominalDiffTime -> Int) -> NominalDiffTime -> Int
forall a b. (a -> b) -> a -> b
$ NominalDiffTime
1_000_000 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
delay
              Just (Right UTCTime
httpDate) -> do
                NominalDiffTime
delay <- (UTCTime -> NominalDiffTime) -> IO UTCTime -> IO NominalDiffTime
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
httpDate) IO UTCTime
getCurrentTime
                RetryStatus
-> Text -> Maybe SomeException -> Maybe Int -> IO RetryAction
consult RetryStatus
retryStatus Text
statusCodeText Maybe SomeException
mSomeHttpEx (Maybe Int -> IO RetryAction) -> Maybe Int -> IO RetryAction
forall a b. (a -> b) -> a -> b
$ Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> Int
forall b. Integral b => NominalDiffTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (NominalDiffTime -> Int) -> NominalDiffTime -> Int
forall a b. (a -> b) -> a -> b
$ NominalDiffTime
1_000_000 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
delay
        where
        parseRetryAfterHeader :: String -> Maybe (Either NominalDiffTime UTCTime)
        parseRetryAfterHeader :: [Char] -> Maybe (Either NominalDiffTime UTCTime)
parseRetryAfterHeader [Char]
headerVal =
          (NominalDiffTime -> Either NominalDiffTime UTCTime)
-> Maybe NominalDiffTime -> Maybe (Either NominalDiffTime UTCTime)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NominalDiffTime -> Either NominalDiffTime UTCTime
forall a b. a -> Either a b
Left Maybe NominalDiffTime
parseNominalDiffTime Maybe (Either NominalDiffTime UTCTime)
-> Maybe (Either NominalDiffTime UTCTime)
-> Maybe (Either NominalDiffTime UTCTime)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (UTCTime -> Either NominalDiffTime UTCTime)
-> Maybe UTCTime -> Maybe (Either NominalDiffTime UTCTime)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UTCTime -> Either NominalDiffTime UTCTime
forall a b. b -> Either a b
Right Maybe UTCTime
parseHttpDate Maybe (Either NominalDiffTime UTCTime)
-> Maybe (Either NominalDiffTime UTCTime)
-> Maybe (Either NominalDiffTime UTCTime)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe (Either NominalDiffTime UTCTime)
forall a. Maybe a
Nothing
          where
          parseNominalDiffTime :: Maybe NominalDiffTime
parseNominalDiffTime = Bool -> TimeLocale -> [Char] -> [Char] -> Maybe NominalDiffTime
forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> [Char] -> [Char] -> m t
parseTimeM Bool
True TimeLocale
defaultTimeLocale [Char]
"%s" [Char]
headerVal
          parseHttpDate :: Maybe UTCTime
parseHttpDate = Bool -> TimeLocale -> [Char] -> [Char] -> Maybe UTCTime
forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> [Char] -> [Char] -> m t
parseTimeM Bool
True TimeLocale
defaultTimeLocale [Char]
"%a, %d %b %Y %H:%M:%S GMT" [Char]
headerVal

        statusCodeText :: Text
        statusCodeText :: Text
statusCodeText = [Char] -> Text
pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Int -> [Char]
forall a. Show a => a -> [Char]
show (Int -> [Char]) -> Int -> [Char]
forall a b. (a -> b) -> a -> b
$ Status -> Int
statusCode (Status -> Int) -> Status -> Int
forall a b. (a -> b) -> a -> b
$ Response () -> Status
forall body. Response body -> Status
responseStatus Response ()
resp

        mSomeHttpEx :: Maybe SomeException
        mSomeHttpEx :: Maybe SomeException
mSomeHttpEx = 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
toException HttpException
httpEx

      consult :: RetryStatus -> Text -> Maybe SomeException -> Maybe Int -> IO RetryAction
      consult :: RetryStatus
-> Text -> Maybe SomeException -> Maybe Int -> IO RetryAction
consult RetryStatus
retryStatus Text
hint Maybe SomeException
mSomeEx Maybe Int
mOverrideDelay =
        (LoggingT IO RetryAction -> Logger -> IO RetryAction)
-> Logger -> LoggingT IO RetryAction -> IO RetryAction
forall a b c. (a -> b -> c) -> b -> a -> c
flip LoggingT IO RetryAction -> Logger -> IO RetryAction
forall (m :: * -> *) a. LoggingT m a -> Logger -> m a
runLoggingT Logger
logger do
          IO (Maybe RetryStatus) -> LoggingT IO (Maybe RetryStatus)
forall a. IO a -> LoggingT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (RetryPolicyM IO -> RetryStatus -> IO (Maybe RetryStatus)
forall (m :: * -> *).
Monad m =>
RetryPolicyM m -> RetryStatus -> m (Maybe RetryStatus)
applyPolicy RetryPolicyM IO
retryPolicy RetryStatus
retryStatus) LoggingT IO (Maybe RetryStatus)
-> (Maybe RetryStatus -> LoggingT IO RetryAction)
-> LoggingT IO RetryAction
forall a b. LoggingT IO a -> (a -> LoggingT IO b) -> LoggingT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Maybe RetryStatus
Nothing -> do
              Message -> LoggingT IO ()
forall (m :: * -> *).
(HasCallStack, MonadLogger m) =>
Message -> m ()
logError (Message -> LoggingT IO ()) -> Message -> LoggingT IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Span export exceeded maximum retries" Text -> [SeriesElem] -> Message
:# [SeriesElem]
meta
              RetryAction -> LoggingT IO RetryAction
forall a. a -> LoggingT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RetryAction
DontRetry
            Just {} -> do
              case Maybe Int
mOverrideDelay of
                Maybe Int
Nothing -> do
                  Message -> LoggingT IO ()
forall (m :: * -> *).
(HasCallStack, MonadLogger m) =>
Message -> m ()
logDebug (Message -> LoggingT IO ()) -> Message -> LoggingT IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Retrying span export with policy delay" Text -> [SeriesElem] -> Message
:# [SeriesElem]
meta
                  RetryAction -> LoggingT IO RetryAction
forall a. a -> LoggingT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RetryAction
ConsultPolicy
                Just Int
overrideDelay -> do
                  Message -> LoggingT IO ()
forall (m :: * -> *).
(HasCallStack, MonadLogger m) =>
Message -> m ()
logDebug (Message -> LoggingT IO ()) -> Message -> LoggingT IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Retrying span export with overridden delay" Text -> [SeriesElem] -> Message
:#
                    Key
"delayMicros" Key -> Int -> SeriesElem
forall v. ToJSON v => Key -> v -> SeriesElem
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Int
overrideDelay SeriesElem -> [SeriesElem] -> [SeriesElem]
forall a. a -> [a] -> [a]
: [SeriesElem]
meta
                  RetryAction -> LoggingT IO RetryAction
forall a. a -> LoggingT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RetryAction -> LoggingT IO RetryAction)
-> RetryAction -> LoggingT IO RetryAction
forall a b. (a -> b) -> a -> b
$ Int -> RetryAction
ConsultPolicyOverrideDelay Int
overrideDelay
        where
        meta :: [SeriesElem]
        meta :: [SeriesElem]
meta =
          (([SeriesElem] -> [SeriesElem]) -> [SeriesElem] -> [SeriesElem])
-> [SeriesElem] -> [[SeriesElem] -> [SeriesElem]] -> [SeriesElem]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ([SeriesElem] -> [SeriesElem]) -> [SeriesElem] -> [SeriesElem]
forall a b. (a -> b) -> a -> b
($) [SeriesElem]
loggingMeta
            [ (Key
"hint" Key -> Text -> SeriesElem
forall v. ToJSON v => Key -> v -> SeriesElem
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
hint SeriesElem -> [SeriesElem] -> [SeriesElem]
forall a. a -> [a] -> [a]
:)
            , Maybe ([SeriesElem] -> [SeriesElem])
-> [SeriesElem] -> [SeriesElem]
forall m. Monoid m => Maybe m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold do
                SomeException
someEx <- Set HeaderName -> Set HeaderName -> SomeException -> SomeException
redactHttpExceptionHeaders Set HeaderName
redactedReqHeaders Set HeaderName
redactedRespHeaders (SomeException -> SomeException)
-> Maybe SomeException -> Maybe SomeException
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe SomeException
mSomeEx
                ([SeriesElem] -> [SeriesElem])
-> Maybe ([SeriesElem] -> [SeriesElem])
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Key
"exception" Key -> [Char] -> SeriesElem
forall v. ToJSON v => Key -> v -> SeriesElem
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= SomeException -> [Char]
forall e. Exception e => e -> [Char]
displayException SomeException
someEx SeriesElem -> [SeriesElem] -> [SeriesElem]
forall a. a -> [a] -> [a]
:)
            ]

  exportTraceServiceRequest
    :: Resource Attrs
    -> Batch (Span Attrs)
    -> OTLP.Collector.ExportTraceServiceRequest
  exportTraceServiceRequest :: Resource Attrs -> Batch (Span Attrs) -> ExportTraceServiceRequest
exportTraceServiceRequest Resource Attrs
res Batch (Span Attrs)
batch =
    ExportTraceServiceRequest
forall msg. Message msg => msg
ProtoLens.defMessage
      ExportTraceServiceRequest
-> (ExportTraceServiceRequest -> ExportTraceServiceRequest)
-> ExportTraceServiceRequest
forall a b. a -> (a -> b) -> b
& LensLike' Identity ExportTraceServiceRequest [ResourceSpans]
forall (f :: * -> *) s a.
(Functor f, HasField s "resourceSpans" a) =>
LensLike' f s a
OTLP.Collector.resourceSpans LensLike' Identity ExportTraceServiceRequest [ResourceSpans]
-> [ResourceSpans]
-> ExportTraceServiceRequest
-> ExportTraceServiceRequest
forall s t a b. ASetter s t a b -> b -> s -> t
.~
          [ ResourceSpans
forall msg. Message msg => msg
ProtoLens.defMessage
              ResourceSpans -> (ResourceSpans -> ResourceSpans) -> ResourceSpans
forall a b. a -> (a -> b) -> b
& (ResourceSpans -> ResourceSpans)
-> (SchemaURL -> ResourceSpans -> ResourceSpans)
-> Maybe SchemaURL
-> ResourceSpans
-> ResourceSpans
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ResourceSpans -> ResourceSpans
forall a. a -> a
id (\SchemaURL
x -> LensLike' Identity ResourceSpans Text
forall (f :: * -> *) s a.
(Functor f, HasField s "schemaUrl" a) =>
LensLike' f s a
OTLP.Trace.schemaUrl LensLike' Identity ResourceSpans Text
-> Text -> ResourceSpans -> ResourceSpans
forall s t a b. ASetter s t a b -> b -> s -> t
.~ SchemaURL -> Text
schemaURLToText SchemaURL
x) (Resource Attrs -> Maybe SchemaURL
forall (attrs :: AttrsFor -> *). Resource attrs -> Maybe SchemaURL
resourceSchemaURL Resource Attrs
res)
              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
OTLP.Trace.resource LensLike' Identity ResourceSpans Resource
-> Resource -> ResourceSpans -> ResourceSpans
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Resource
convertResourceAttrs
              ResourceSpans -> (ResourceSpans -> ResourceSpans) -> ResourceSpans
forall a b. a -> (a -> b) -> b
& LensLike' Identity ResourceSpans [ScopeSpans]
forall (f :: * -> *) s a.
(Functor f, HasField s "scopeSpans" a) =>
LensLike' f s a
OTLP.Trace.scopeSpans LensLike' Identity ResourceSpans [ScopeSpans]
-> [ScopeSpans] -> ResourceSpans -> ResourceSpans
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ([Span Attrs] -> Maybe ScopeSpans)
-> [[Span Attrs]] -> [ScopeSpans]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe [Span Attrs] -> Maybe ScopeSpans
convertSpanGroup [[Span Attrs]]
groupedSpans
          ]
    where
    convertResourceAttrs :: OTLP.Resource.Resource
    convertResourceAttrs :: Resource
convertResourceAttrs =
      Resource
forall msg. Message msg => msg
ProtoLens.defMessage
        Resource -> (Resource -> Resource) -> Resource
forall a b. a -> (a -> b) -> b
& LensLike' Identity Resource [KeyValue]
forall (f :: * -> *) s a.
(Functor f, HasField s "attributes" a) =>
LensLike' f s a
OTLP.Resource.attributes LensLike' Identity Resource [KeyValue]
-> [KeyValue] -> Resource -> Resource
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Attrs 'AttrsForResource -> [KeyValue]
forall (af :: AttrsFor). Attrs af -> [KeyValue]
convertAttrKVs (Resource Attrs -> Attrs 'AttrsForResource
forall (attrs :: AttrsFor -> *).
Resource attrs -> attrs 'AttrsForResource
resourceAttrs Resource Attrs
res)

    groupedSpans :: [[Span Attrs]]
    groupedSpans :: [[Span Attrs]]
groupedSpans =
      Batch (Span Attrs) -> [Span Attrs]
forall a. Batch a -> [a]
unBatch Batch (Span Attrs)
batch
        [Span Attrs] -> ([Span Attrs] -> [Span Attrs]) -> [Span Attrs]
forall a b. a -> (a -> b) -> b
& (Span Attrs -> InstrumentationScope)
-> [Span Attrs] -> [Span Attrs]
forall b a. Ord b => (a -> b) -> [a] -> [a]
List.sortOn Span Attrs -> InstrumentationScope
forall (attrs :: AttrsFor -> *). Span attrs -> InstrumentationScope
spanInstrumentationScope
        [Span Attrs] -> ([Span Attrs] -> [[Span Attrs]]) -> [[Span Attrs]]
forall a b. a -> (a -> b) -> b
& (Span Attrs -> Span Attrs -> Bool)
-> [Span Attrs] -> [[Span Attrs]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
List.groupBy (InstrumentationScope -> InstrumentationScope -> Bool
forall a. Eq a => a -> a -> Bool
(==) (InstrumentationScope -> InstrumentationScope -> Bool)
-> (Span Attrs -> InstrumentationScope)
-> Span Attrs
-> Span Attrs
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Span Attrs -> InstrumentationScope
forall (attrs :: AttrsFor -> *). Span attrs -> InstrumentationScope
spanInstrumentationScope)

    convertSpanGroup :: [Span Attrs] -> Maybe OTLP.Trace.ScopeSpans
    convertSpanGroup :: [Span Attrs] -> Maybe ScopeSpans
convertSpanGroup [Span Attrs]
spans =
      case [Span Attrs]
spans of
        [] -> Maybe ScopeSpans
forall a. Maybe a
Nothing
        Span Attrs
span : [Span Attrs]
_ ->
          ScopeSpans
forall msg. Message msg => msg
ProtoLens.defMessage
            ScopeSpans -> (ScopeSpans -> ScopeSpans) -> ScopeSpans
forall a b. a -> (a -> b) -> b
& LensLike' Identity ScopeSpans InstrumentationScope
forall (f :: * -> *) s a.
(Functor f, HasField s "scope" a) =>
LensLike' f s a
OTLP.Trace.scope LensLike' Identity ScopeSpans InstrumentationScope
-> InstrumentationScope -> ScopeSpans -> ScopeSpans
forall s t a b. ASetter s t a b -> b -> s -> t
.~ InstrumentationScope -> InstrumentationScope
convertInstScope InstrumentationScope
instScope
            ScopeSpans -> (ScopeSpans -> ScopeSpans) -> ScopeSpans
forall a b. a -> (a -> b) -> b
& LensLike' Identity ScopeSpans [Span]
forall (f :: * -> *) s a.
(Functor f, HasField s "spans" a) =>
LensLike' f s a
OTLP.Trace.spans LensLike' Identity ScopeSpans [Span]
-> [Span] -> ScopeSpans -> ScopeSpans
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Span Attrs -> Span) -> [Span Attrs] -> [Span]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Span Attrs -> Span
convertSpan [Span Attrs]
spans
            ScopeSpans -> (ScopeSpans -> ScopeSpans) -> ScopeSpans
forall a b. a -> (a -> b) -> b
& (ScopeSpans -> ScopeSpans)
-> (SchemaURL -> ScopeSpans -> ScopeSpans)
-> Maybe SchemaURL
-> ScopeSpans
-> ScopeSpans
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ScopeSpans -> ScopeSpans
forall a. a -> a
id (\SchemaURL
x -> LensLike' Identity ScopeSpans Text
forall (f :: * -> *) s a.
(Functor f, HasField s "schemaUrl" a) =>
LensLike' f s a
OTLP.Trace.schemaUrl LensLike' Identity ScopeSpans Text
-> Text -> ScopeSpans -> ScopeSpans
forall s t a b. ASetter s t a b -> b -> s -> t
.~ SchemaURL -> Text
schemaURLToText SchemaURL
x) Maybe SchemaURL
schemaURL
            ScopeSpans -> (ScopeSpans -> Maybe ScopeSpans) -> Maybe ScopeSpans
forall a b. a -> (a -> b) -> b
& ScopeSpans -> Maybe ScopeSpans
forall a. a -> Maybe a
Just
          where
          InstrumentationScope { instrumentationScopeSchemaURL :: InstrumentationScope -> Maybe SchemaURL
instrumentationScopeSchemaURL = Maybe SchemaURL
schemaURL } = InstrumentationScope
instScope
          instScope :: InstrumentationScope
instScope = Span Attrs -> InstrumentationScope
forall (attrs :: AttrsFor -> *). Span attrs -> InstrumentationScope
spanInstrumentationScope Span Attrs
span

    convertSpan :: Span Attrs -> OTLP.Trace.Span
    convertSpan :: Span Attrs -> Span
convertSpan Span Attrs
span =
      Span
forall msg. Message msg => msg
ProtoLens.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
OTLP.Trace.traceId LensLike' Identity Span ByteString -> ByteString -> Span -> Span
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Builder -> ByteString
bytesBuilderToBS8 (TraceId -> Builder
traceIdToBytesBuilder TraceId
traceId)
        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
OTLP.Trace.spanId LensLike' Identity Span ByteString -> ByteString -> Span -> Span
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Builder -> ByteString
bytesBuilderToBS8 (SpanId -> Builder
spanIdToBytesBuilder SpanId
spanId)
        -- TODO: & OTLP.Trace.traceState .~ undefined
        Span -> (Span -> Span) -> Span
forall a b. a -> (a -> b) -> b
& (Span -> Span)
-> (SpanId -> Span -> Span) -> Maybe SpanId -> Span -> Span
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Span -> Span
forall a. a -> a
id (\SpanId
x -> LensLike' Identity Span ByteString
forall (f :: * -> *) s a.
(Functor f, HasField s "parentSpanId" a) =>
LensLike' f s a
OTLP.Trace.parentSpanId LensLike' Identity Span ByteString -> ByteString -> Span -> Span
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Builder -> ByteString
bytesBuilderToBS8 (SpanId -> Builder
spanIdToBytesBuilder SpanId
x)) Maybe SpanId
mParentSpanId
        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
OTLP.Trace.name LensLike' Identity Span Text -> Text -> Span -> Span
forall s t a b. ASetter s t a b -> b -> s -> t
.~ SpanName -> Text
unSpanName SpanName
spanName
        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
OTLP.Trace.kind LensLike' Identity Span Span'SpanKind
-> Span'SpanKind -> Span -> Span
forall s t a b. ASetter s t a b -> b -> s -> t
.~ SpanKind -> Span'SpanKind
convertSpanKind SpanKind
spanKind
        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
OTLP.Trace.startTimeUnixNano LensLike' Identity Span Word64 -> Word64 -> Span -> Span
forall s t a b. ASetter s t a b -> b -> s -> t
.~
            Integer -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Timestamp -> Integer
timestampToNanoseconds Timestamp
spanStart)
        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
OTLP.Trace.endTimeUnixNano LensLike' Identity Span Word64 -> Word64 -> Span -> Span
forall s t a b. ASetter s t a b -> b -> s -> t
.~
            Integer -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Timestamp -> Integer
timestampToNanoseconds (Timestamp -> Integer) -> Timestamp -> Integer
forall a b. (a -> b) -> a -> b
$ SpanFrozenTimestamp -> Timestamp
frozenTimestamp SpanFrozenTimestamp
SpanFrozenAt Attrs
spanFrozenAt)
        Span -> (Span -> Span) -> Span
forall a b. a -> (a -> b) -> b
& LensLike' Identity Span [KeyValue]
forall (f :: * -> *) s a.
(Functor f, HasField s "attributes" a) =>
LensLike' f s a
OTLP.Trace.attributes LensLike' Identity Span [KeyValue] -> [KeyValue] -> Span -> Span
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Attrs 'AttrsForSpan -> [KeyValue]
forall (af :: AttrsFor). Attrs af -> [KeyValue]
convertAttrKVs Attrs 'AttrsForSpan
spanAttrs
        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
OTLP.Trace.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 (Attrs 'AttrsForSpan -> Int
forall (af :: AttrsFor). Attrs af -> Int
droppedAttrsCount Attrs 'AttrsForSpan
spanAttrs)
        Span -> (Span -> Span) -> Span
forall a b. a -> (a -> b) -> b
& LensLike' Identity Span [Span'Event]
forall (f :: * -> *) s a.
(Functor f, HasField s "events" a) =>
LensLike' f s a
OTLP.Trace.events LensLike' Identity Span [Span'Event]
-> [Span'Event] -> Span -> Span
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (SpanEvent Attrs -> Span'Event)
-> [SpanEvent Attrs] -> [Span'Event]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SpanEvent Attrs -> Span'Event
convertSpanEvent (SpanEvents Attrs -> [SpanEvent Attrs]
forall (attrs :: AttrsFor -> *).
SpanEvents attrs -> [SpanEvent attrs]
spanEventsToList SpanEvents Attrs
spanEvents)
        Span -> (Span -> Span) -> Span
forall a b. a -> (a -> b) -> b
& LensLike' Identity Span [Span'Link]
forall (f :: * -> *) s a.
(Functor f, HasField s "links" a) =>
LensLike' f s a
OTLP.Trace.links LensLike' Identity Span [Span'Link] -> [Span'Link] -> Span -> Span
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (SpanLink Attrs -> Span'Link) -> [SpanLink Attrs] -> [Span'Link]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SpanLink Attrs -> Span'Link
convertSpanLink (SpanLinks Attrs -> [SpanLink Attrs]
forall (attrs :: AttrsFor -> *).
SpanLinks attrs -> [SpanLink attrs]
spanLinksToList SpanLinks Attrs
spanLinks)
        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
OTLP.Trace.status LensLike' Identity Span Status -> Status -> Span -> Span
forall s t a b. ASetter s t a b -> b -> s -> t
.~ SpanStatus -> Status
convertSpanStatus SpanStatus
spanStatus
      where
      mParentSpanId :: Maybe SpanId
mParentSpanId =
        case SpanLineage
spanLineage of
          SpanLineage
SpanLineageRoot -> Maybe SpanId
forall a. Maybe a
Nothing
          SpanLineageChildOf SpanContext
parentSpanContext ->
            SpanId -> Maybe SpanId
forall a. a -> Maybe a
Just (SpanId -> Maybe SpanId) -> SpanId -> Maybe SpanId
forall a b. (a -> b) -> a -> b
$ SpanContext -> SpanId
spanContextSpanId SpanContext
parentSpanContext


      Span
        { SpanLineage
spanLineage :: forall (attrs :: AttrsFor -> *). Span attrs -> SpanLineage
spanLineage :: SpanLineage
spanLineage
        , spanContext :: forall (attrs :: AttrsFor -> *). Span attrs -> SpanContext
spanContext =
            SpanContext
              { spanContextTraceId :: SpanContext -> TraceId
spanContextTraceId = TraceId
traceId
              , spanContextSpanId :: SpanContext -> SpanId
spanContextSpanId = SpanId
spanId
              --, spanContextTraceState = traceState
              }
        , SpanName
spanName :: forall (attrs :: AttrsFor -> *). Span attrs -> SpanName
spanName :: SpanName
spanName
        , SpanStatus
spanStatus :: forall (attrs :: AttrsFor -> *). Span attrs -> SpanStatus
spanStatus :: SpanStatus
spanStatus
        , Timestamp
spanStart :: forall (attrs :: AttrsFor -> *). Span attrs -> Timestamp
spanStart :: Timestamp
spanStart
        , SpanFrozenAt Attrs
spanFrozenAt :: forall (attrs :: AttrsFor -> *). Span attrs -> SpanFrozenAt attrs
spanFrozenAt :: SpanFrozenAt Attrs
spanFrozenAt
        , SpanKind
spanKind :: forall (attrs :: AttrsFor -> *). Span attrs -> SpanKind
spanKind :: SpanKind
spanKind
        , Attrs 'AttrsForSpan
spanAttrs :: forall (attrs :: AttrsFor -> *). Span attrs -> attrs 'AttrsForSpan
spanAttrs :: Attrs 'AttrsForSpan
spanAttrs
        , SpanLinks Attrs
spanLinks :: forall (attrs :: AttrsFor -> *). Span attrs -> SpanLinks attrs
spanLinks :: SpanLinks Attrs
spanLinks
        , SpanEvents Attrs
spanEvents :: forall (attrs :: AttrsFor -> *). Span attrs -> SpanEvents attrs
spanEvents :: SpanEvents Attrs
spanEvents
        } = Span Attrs
span

    convertSpanEvent :: SpanEvent Attrs -> OTLP.Trace.Span'Event
    convertSpanEvent :: SpanEvent Attrs -> Span'Event
convertSpanEvent SpanEvent Attrs
spanEvent =
      Span'Event
forall msg. Message msg => msg
ProtoLens.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
OTLP.Trace.timeUnixNano LensLike' Identity Span'Event Word64
-> Word64 -> Span'Event -> Span'Event
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Timestamp -> Integer
timestampToNanoseconds Timestamp
timestamp)
        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
OTLP.Trace.name LensLike' Identity Span'Event Text
-> Text -> Span'Event -> Span'Event
forall s t a b. ASetter s t a b -> b -> s -> t
.~ SpanEventName -> Text
unSpanEventName SpanEventName
name
        Span'Event -> (Span'Event -> Span'Event) -> Span'Event
forall a b. a -> (a -> b) -> b
& LensLike' Identity Span'Event [KeyValue]
forall (f :: * -> *) s a.
(Functor f, HasField s "attributes" a) =>
LensLike' f s a
OTLP.Trace.attributes LensLike' Identity Span'Event [KeyValue]
-> [KeyValue] -> Span'Event -> Span'Event
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Attrs 'AttrsForSpanEvent -> [KeyValue]
forall (af :: AttrsFor). Attrs af -> [KeyValue]
convertAttrKVs Attrs 'AttrsForSpanEvent
attrs
        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
OTLP.Trace.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 (Attrs 'AttrsForSpanEvent -> Int
forall (af :: AttrsFor). Attrs af -> Int
droppedAttrsCount Attrs 'AttrsForSpanEvent
attrs)
      where
      SpanEvent
        { spanEventName :: forall (attrs :: AttrsFor -> *). SpanEvent attrs -> SpanEventName
spanEventName = SpanEventName
name
        , spanEventTimestamp :: forall (attrs :: AttrsFor -> *). SpanEvent attrs -> Timestamp
spanEventTimestamp = Timestamp
timestamp
        , spanEventAttrs :: forall (attrs :: AttrsFor -> *).
SpanEvent attrs -> attrs 'AttrsForSpanEvent
spanEventAttrs = Attrs 'AttrsForSpanEvent
attrs
        } = SpanEvent Attrs
spanEvent

    convertSpanLink :: SpanLink Attrs -> OTLP.Trace.Span'Link
    convertSpanLink :: SpanLink Attrs -> Span'Link
convertSpanLink SpanLink Attrs
spanLink =
      Span'Link
forall msg. Message msg => msg
ProtoLens.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
OTLP.Trace.traceId LensLike' Identity Span'Link ByteString
-> ByteString -> Span'Link -> Span'Link
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Builder -> ByteString
bytesBuilderToBS8 (TraceId -> Builder
traceIdToBytesBuilder TraceId
traceId)
        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
OTLP.Trace.spanId LensLike' Identity Span'Link ByteString
-> ByteString -> Span'Link -> Span'Link
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Builder -> ByteString
bytesBuilderToBS8 (SpanId -> Builder
spanIdToBytesBuilder SpanId
spanId)
        -- TODO: & OTLP.Trace.traceState .~ undefined
        Span'Link -> (Span'Link -> Span'Link) -> Span'Link
forall a b. a -> (a -> b) -> b
& LensLike' Identity Span'Link [KeyValue]
forall (f :: * -> *) s a.
(Functor f, HasField s "attributes" a) =>
LensLike' f s a
OTLP.Trace.attributes LensLike' Identity Span'Link [KeyValue]
-> [KeyValue] -> Span'Link -> Span'Link
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Attrs 'AttrsForSpanLink -> [KeyValue]
forall (af :: AttrsFor). Attrs af -> [KeyValue]
convertAttrKVs Attrs 'AttrsForSpanLink
attrs
        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
OTLP.Trace.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 (Attrs 'AttrsForSpanLink -> Int
forall (af :: AttrsFor). Attrs af -> Int
droppedAttrsCount Attrs 'AttrsForSpanLink
attrs)
      where
      SpanLink
        { spanLinkSpanContext :: forall (attrs :: AttrsFor -> *). SpanLink attrs -> SpanContext
spanLinkSpanContext =
            SpanContext
              { spanContextTraceId :: SpanContext -> TraceId
spanContextTraceId = TraceId
traceId
              , spanContextSpanId :: SpanContext -> SpanId
spanContextSpanId = SpanId
spanId
              --, spanContextTraceState = traceState
              }
        , spanLinkAttrs :: forall (attrs :: AttrsFor -> *).
SpanLink attrs -> attrs 'AttrsForSpanLink
spanLinkAttrs = Attrs 'AttrsForSpanLink
attrs
        } = SpanLink Attrs
spanLink

    convertAttrKVs :: Attrs af -> [OTLP.Common.KeyValue]
    convertAttrKVs :: forall (af :: AttrsFor). Attrs af -> [KeyValue]
convertAttrKVs =
      DList KeyValue -> [KeyValue]
forall a. DList a -> [a]
DList.toList (DList KeyValue -> [KeyValue])
-> (Attrs af -> DList KeyValue) -> Attrs af -> [KeyValue]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Key a -> Attr a -> DList KeyValue)
-> Attrs af -> DList KeyValue
forall m (af :: AttrsFor).
Monoid m =>
(forall a. Key a -> Attr a -> m) -> Attrs af -> m
foldMapWithKeyAttrs \Key a
k Attr a
v -> KeyValue -> DList KeyValue
forall a. a -> DList a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (KeyValue -> DList KeyValue) -> KeyValue -> DList KeyValue
forall a b. (a -> b) -> a -> b
$ Key a -> Attr a -> KeyValue
forall typ. Key typ -> Attr typ -> KeyValue
convertAttrKV Key a
k Attr a
v

    convertAttrKV :: Key typ -> Attr typ -> OTLP.Common.KeyValue
    convertAttrKV :: forall typ. Key typ -> Attr typ -> KeyValue
convertAttrKV Key typ
k Attr typ
v =
      KeyValue
forall msg. Message msg => msg
ProtoLens.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
OTLP.Common.key LensLike' Identity KeyValue Text -> Text -> KeyValue -> KeyValue
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Key typ -> Text
forall a. Key a -> Text
unKey Key typ
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
OTLP.Common.value LensLike' Identity KeyValue AnyValue
-> AnyValue -> KeyValue -> KeyValue
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Attr typ -> AnyValue
forall typ. Attr typ -> AnyValue
convertAttrValue Attr typ
v

    convertAttrValue :: Attr typ -> OTLP.Common.AnyValue
    convertAttrValue :: forall typ. Attr typ -> AnyValue
convertAttrValue Attr typ
attr =
      forall msg. Message msg => msg
ProtoLens.defMessage @OTLP.Common.AnyValue
        AnyValue -> (AnyValue -> AnyValue) -> AnyValue
forall a b. a -> (a -> b) -> b
& case Attr typ -> AttrType typ
forall a. Attr a -> AttrType a
attrType Attr typ
attr of
            AttrType typ
AttrTypeText -> LensLike' Identity AnyValue typ
forall (f :: * -> *) s a.
(Functor f, HasField s "stringValue" a) =>
LensLike' f s a
OTLP.Common.stringValue LensLike' Identity AnyValue typ -> typ -> AnyValue -> AnyValue
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Attr typ -> typ
forall a. Attr a -> a
attrVal Attr typ
attr
            AttrType typ
AttrTypeBool -> LensLike' Identity AnyValue typ
forall (f :: * -> *) s a.
(Functor f, HasField s "boolValue" a) =>
LensLike' f s a
OTLP.Common.boolValue LensLike' Identity AnyValue typ -> typ -> AnyValue -> AnyValue
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Attr typ -> typ
forall a. Attr a -> a
attrVal Attr typ
attr
            AttrType typ
AttrTypeInt -> LensLike' Identity AnyValue typ
forall (f :: * -> *) s a.
(Functor f, HasField s "intValue" a) =>
LensLike' f s a
OTLP.Common.intValue LensLike' Identity AnyValue typ -> typ -> AnyValue -> AnyValue
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Attr typ -> typ
forall a. Attr a -> a
attrVal Attr typ
attr
            AttrType typ
AttrTypeDouble -> LensLike' Identity AnyValue typ
forall (f :: * -> *) s a.
(Functor f, HasField s "doubleValue" a) =>
LensLike' f s a
OTLP.Common.doubleValue LensLike' Identity AnyValue typ -> typ -> AnyValue -> AnyValue
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Attr typ -> typ
forall a. Attr a -> a
attrVal Attr typ
attr
            AttrType typ
AttrTypeTextArray ->
              LensLike' Identity AnyValue ArrayValue
forall (f :: * -> *) s a.
(Functor f, HasField s "arrayValue" a) =>
LensLike' f s a
OTLP.Common.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
ProtoLens.defMessage
                    ArrayValue -> (ArrayValue -> ArrayValue) -> ArrayValue
forall a b. a -> (a -> b) -> b
& LensLike' Identity ArrayValue (Vector AnyValue)
forall (f :: * -> *) s a.
(Functor f, HasField s "vec'values" a) =>
LensLike' f s a
OTLP.Common.vec'values LensLike' Identity ArrayValue (Vector AnyValue)
-> Vector AnyValue -> ArrayValue -> ArrayValue
forall s t a b. ASetter s t a b -> b -> s -> t
.~ AttrVals Text -> Vector AnyValue
convertTextArrayAttrVals (Attr (AttrVals Text) -> AttrVals Text
forall a. Attr a -> a
attrVal Attr typ
Attr (AttrVals Text)
attr)
                )
            AttrType typ
AttrTypeBoolArray ->
              LensLike' Identity AnyValue ArrayValue
forall (f :: * -> *) s a.
(Functor f, HasField s "arrayValue" a) =>
LensLike' f s a
OTLP.Common.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
ProtoLens.defMessage
                    ArrayValue -> (ArrayValue -> ArrayValue) -> ArrayValue
forall a b. a -> (a -> b) -> b
& LensLike' Identity ArrayValue (Vector AnyValue)
forall (f :: * -> *) s a.
(Functor f, HasField s "vec'values" a) =>
LensLike' f s a
OTLP.Common.vec'values LensLike' Identity ArrayValue (Vector AnyValue)
-> Vector AnyValue -> ArrayValue -> ArrayValue
forall s t a b. ASetter s t a b -> b -> s -> t
.~ AttrVals Bool -> Vector AnyValue
convertBoolArrayAttrVals (Attr (AttrVals Bool) -> AttrVals Bool
forall a. Attr a -> a
attrVal Attr typ
Attr (AttrVals Bool)
attr)
                )
            AttrType typ
AttrTypeIntArray ->
              LensLike' Identity AnyValue ArrayValue
forall (f :: * -> *) s a.
(Functor f, HasField s "arrayValue" a) =>
LensLike' f s a
OTLP.Common.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
ProtoLens.defMessage
                    ArrayValue -> (ArrayValue -> ArrayValue) -> ArrayValue
forall a b. a -> (a -> b) -> b
& LensLike' Identity ArrayValue (Vector AnyValue)
forall (f :: * -> *) s a.
(Functor f, HasField s "vec'values" a) =>
LensLike' f s a
OTLP.Common.vec'values LensLike' Identity ArrayValue (Vector AnyValue)
-> Vector AnyValue -> ArrayValue -> ArrayValue
forall s t a b. ASetter s t a b -> b -> s -> t
.~ AttrVals Int64 -> Vector AnyValue
convertIntArrayAttrVals (Attr (AttrVals Int64) -> AttrVals Int64
forall a. Attr a -> a
attrVal Attr typ
Attr (AttrVals Int64)
attr)
                )
            AttrType typ
AttrTypeDoubleArray ->
              LensLike' Identity AnyValue ArrayValue
forall (f :: * -> *) s a.
(Functor f, HasField s "arrayValue" a) =>
LensLike' f s a
OTLP.Common.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
ProtoLens.defMessage
                    ArrayValue -> (ArrayValue -> ArrayValue) -> ArrayValue
forall a b. a -> (a -> b) -> b
& LensLike' Identity ArrayValue (Vector AnyValue)
forall (f :: * -> *) s a.
(Functor f, HasField s "vec'values" a) =>
LensLike' f s a
OTLP.Common.vec'values LensLike' Identity ArrayValue (Vector AnyValue)
-> Vector AnyValue -> ArrayValue -> ArrayValue
forall s t a b. ASetter s t a b -> b -> s -> t
.~ AttrVals Double -> Vector AnyValue
convertDoubleArrayAttrVals (Attr (AttrVals Double) -> AttrVals Double
forall a. Attr a -> a
attrVal Attr typ
Attr (AttrVals Double)
attr)
                )

    convertTextArrayAttrVals :: AttrVals Text -> Vector OTLP.Common.AnyValue
    convertTextArrayAttrVals :: AttrVals Text -> Vector AnyValue
convertTextArrayAttrVals =
      (Text -> AnyValue) -> Vector Text -> Vector AnyValue
forall a b. (a -> b) -> Vector a -> Vector b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Text
x -> AnyValue
forall msg. Message msg => msg
ProtoLens.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
OTLP.Common.stringValue LensLike' Identity AnyValue Text -> Text -> AnyValue -> AnyValue
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Text
x) (Vector Text -> Vector AnyValue)
-> (AttrVals Text -> Vector Text)
-> AttrVals Text
-> Vector AnyValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AttrVals Text -> Vector Text
forall a. AttrVals a -> Vector a
unAttrVals

    convertBoolArrayAttrVals :: AttrVals Bool -> Vector OTLP.Common.AnyValue
    convertBoolArrayAttrVals :: AttrVals Bool -> Vector AnyValue
convertBoolArrayAttrVals =
      (Bool -> AnyValue) -> Vector Bool -> Vector AnyValue
forall a b. (a -> b) -> Vector a -> Vector b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Bool
x -> AnyValue
forall msg. Message msg => msg
ProtoLens.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
OTLP.Common.boolValue LensLike' Identity AnyValue Bool -> Bool -> AnyValue -> AnyValue
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
x) (Vector Bool -> Vector AnyValue)
-> (AttrVals Bool -> Vector Bool)
-> AttrVals Bool
-> Vector AnyValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AttrVals Bool -> Vector Bool
forall a. AttrVals a -> Vector a
unAttrVals

    convertIntArrayAttrVals :: AttrVals Int64 -> Vector OTLP.Common.AnyValue
    convertIntArrayAttrVals :: AttrVals Int64 -> Vector AnyValue
convertIntArrayAttrVals =
      (Int64 -> AnyValue) -> Vector Int64 -> Vector AnyValue
forall a b. (a -> b) -> Vector a -> Vector b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Int64
x -> AnyValue
forall msg. Message msg => msg
ProtoLens.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
OTLP.Common.intValue LensLike' Identity AnyValue Int64 -> Int64 -> AnyValue -> AnyValue
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Int64
x) (Vector Int64 -> Vector AnyValue)
-> (AttrVals Int64 -> Vector Int64)
-> AttrVals Int64
-> Vector AnyValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AttrVals Int64 -> Vector Int64
forall a. AttrVals a -> Vector a
unAttrVals

    convertDoubleArrayAttrVals :: AttrVals Double -> Vector OTLP.Common.AnyValue
    convertDoubleArrayAttrVals :: AttrVals Double -> Vector AnyValue
convertDoubleArrayAttrVals =
      (Double -> AnyValue) -> Vector Double -> Vector AnyValue
forall a b. (a -> b) -> Vector a -> Vector b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Double
x -> AnyValue
forall msg. Message msg => msg
ProtoLens.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
OTLP.Common.doubleValue LensLike' Identity AnyValue Double
-> Double -> AnyValue -> AnyValue
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Double
x) (Vector Double -> Vector AnyValue)
-> (AttrVals Double -> Vector Double)
-> AttrVals Double
-> Vector AnyValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AttrVals Double -> Vector Double
forall a. AttrVals a -> Vector a
unAttrVals

    convertSpanStatus :: SpanStatus -> OTLP.Trace.Status
    convertSpanStatus :: SpanStatus -> Status
convertSpanStatus = \case
      SpanStatus
SpanStatusUnset ->
        Status
forall msg. Message msg => msg
ProtoLens.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
OTLP.Trace.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
OTLP.Trace.Status'STATUS_CODE_UNSET
      SpanStatus
SpanStatusOk ->
        Status
forall msg. Message msg => msg
ProtoLens.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
OTLP.Trace.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
OTLP.Trace.Status'STATUS_CODE_OK
      SpanStatusError Text
errText ->
        Status
forall msg. Message msg => msg
ProtoLens.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
OTLP.Trace.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
OTLP.Trace.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
OTLP.Trace.message LensLike' Identity Status Text -> Text -> Status -> Status
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Text
errText

    convertSpanKind :: SpanKind -> OTLP.Trace.Span'SpanKind
    convertSpanKind :: SpanKind -> Span'SpanKind
convertSpanKind = \case
      SpanKind
SpanKindServer -> Span'SpanKind
OTLP.Trace.Span'SPAN_KIND_SERVER
      SpanKind
SpanKindClient -> Span'SpanKind
OTLP.Trace.Span'SPAN_KIND_CLIENT
      SpanKind
SpanKindProducer -> Span'SpanKind
OTLP.Trace.Span'SPAN_KIND_PRODUCER
      SpanKind
SpanKindConsumer -> Span'SpanKind
OTLP.Trace.Span'SPAN_KIND_CONSUMER
      SpanKind
SpanKindInternal -> Span'SpanKind
OTLP.Trace.Span'SPAN_KIND_INTERNAL

    convertInstScope :: InstrumentationScope -> OTLP.Common.InstrumentationScope
    convertInstScope :: InstrumentationScope -> InstrumentationScope
convertInstScope InstrumentationScope
instScope =
      -- N.B. There are 'attributes' and 'droppedAttributesCount' fields available too.
      InstrumentationScope
forall msg. Message msg => msg
ProtoLens.defMessage
        InstrumentationScope
-> (InstrumentationScope -> InstrumentationScope)
-> InstrumentationScope
forall a b. a -> (a -> b) -> b
& LensLike' Identity InstrumentationScope Text
forall (f :: * -> *) s a.
(Functor f, HasField s "name" a) =>
LensLike' f s a
OTLP.Common.name LensLike' Identity InstrumentationScope Text
-> Text -> InstrumentationScope -> InstrumentationScope
forall s t a b. ASetter s t a b -> b -> s -> t
.~ InstrumentationScopeName -> Text
unInstrumentationScopeName InstrumentationScopeName
name
        InstrumentationScope
-> (InstrumentationScope -> InstrumentationScope)
-> InstrumentationScope
forall a b. a -> (a -> b) -> b
& (InstrumentationScope -> InstrumentationScope)
-> (Version -> InstrumentationScope -> InstrumentationScope)
-> Maybe Version
-> InstrumentationScope
-> InstrumentationScope
forall b a. b -> (a -> b) -> Maybe a -> b
maybe InstrumentationScope -> InstrumentationScope
forall a. a -> a
id (\Version
x -> LensLike' Identity InstrumentationScope Text
forall (f :: * -> *) s a.
(Functor f, HasField s "version" a) =>
LensLike' f s a
OTLP.Common.version LensLike' Identity InstrumentationScope Text
-> Text -> InstrumentationScope -> InstrumentationScope
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Version -> Text
unVersion Version
x) Maybe Version
version
      where
      InstrumentationScope
        { instrumentationScopeName :: InstrumentationScope -> InstrumentationScopeName
instrumentationScopeName = InstrumentationScopeName
name
        , instrumentationScopeVersion :: InstrumentationScope -> Maybe Version
instrumentationScopeVersion = Maybe Version
version
        } = InstrumentationScope
instScope

    bytesBuilderToBS8 :: Builder -> ByteString
bytesBuilderToBS8 = ByteString -> ByteString
ByteString.Char8.toStrict (ByteString -> ByteString)
-> (Builder -> ByteString) -> Builder -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
Builder.toLazyByteString

  loggingMeta :: [SeriesElem]
loggingMeta =
    [ Key
"spanExporter" Key -> Value -> SeriesElem
forall v. ToJSON v => Key -> v -> SeriesElem
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object
        [ Key
"name" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"otlp" :: Text)
        ]
    ]

  redactedReqHeaders :: Set HeaderName
redactedReqHeaders = [HeaderName] -> Set HeaderName
forall a. Ord a => [a] -> Set a
Set.fromList [HeaderName]
redactedReqHeadersList
  redactedRespHeaders :: Set HeaderName
redactedRespHeaders = [HeaderName] -> Set HeaderName
forall a. Ord a => [a] -> Set a
Set.fromList [HeaderName]
redactedRespHeadersList

  OTLPSpanExporterSpec
    { otlpSpanExporterSpecManager :: OTLPSpanExporterSpec -> Manager
otlpSpanExporterSpecManager = Manager
manager
    , otlpSpanExporterSpecEndpoint :: OTLPSpanExporterSpec -> URI
otlpSpanExporterSpecEndpoint = URI
endpoint
    , otlpSpanExporterSpecTimeout :: OTLPSpanExporterSpec -> Int
otlpSpanExporterSpecTimeout = Int
exportTimeout
    , otlpSpanExporterSpecProtocol :: OTLPSpanExporterSpec -> OTLPProtocol
otlpSpanExporterSpecProtocol = OTLPProtocol
_protocol -- N.B. Only http/protobuf is supported
    , otlpSpanExporterSpecHeaders :: OTLPSpanExporterSpec -> [Header]
otlpSpanExporterSpecHeaders = [Header]
headers
    , otlpSpanExporterSpecRedactedRequestHeaders :: OTLPSpanExporterSpec -> [HeaderName]
otlpSpanExporterSpecRedactedRequestHeaders = [HeaderName]
redactedReqHeadersList
    , otlpSpanExporterSpecRedactedResponseHeaders :: OTLPSpanExporterSpec -> [HeaderName]
otlpSpanExporterSpecRedactedResponseHeaders = [HeaderName]
redactedRespHeadersList
    , otlpSpanExporterSpecWorkerQueueSize :: OTLPSpanExporterSpec -> Int
otlpSpanExporterSpecWorkerQueueSize = Int
queueSize
    , otlpSpanExporterSpecWorkerCount :: OTLPSpanExporterSpec -> Int
otlpSpanExporterSpecWorkerCount = Int
workerCount
    , otlpSpanExporterSpecRetryPolicy :: OTLPSpanExporterSpec -> RetryPolicyM IO
otlpSpanExporterSpecRetryPolicy = RetryPolicyM IO
retryPolicy
    } = OTLPSpanExporterSpec
otlpSpanExporterSpec

data OTLPProtocol
  = OTLPProtocolHTTPProtobuf
  deriving stock (OTLPProtocol -> OTLPProtocol -> Bool
(OTLPProtocol -> OTLPProtocol -> Bool)
-> (OTLPProtocol -> OTLPProtocol -> Bool) -> Eq OTLPProtocol
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: OTLPProtocol -> OTLPProtocol -> Bool
== :: OTLPProtocol -> OTLPProtocol -> Bool
$c/= :: OTLPProtocol -> OTLPProtocol -> Bool
/= :: OTLPProtocol -> OTLPProtocol -> Bool
Eq, Int -> OTLPProtocol -> ShowS
[OTLPProtocol] -> ShowS
OTLPProtocol -> [Char]
(Int -> OTLPProtocol -> ShowS)
-> (OTLPProtocol -> [Char])
-> ([OTLPProtocol] -> ShowS)
-> Show OTLPProtocol
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> OTLPProtocol -> ShowS
showsPrec :: Int -> OTLPProtocol -> ShowS
$cshow :: OTLPProtocol -> [Char]
show :: OTLPProtocol -> [Char]
$cshowList :: [OTLPProtocol] -> ShowS
showList :: [OTLPProtocol] -> ShowS
Show)

httpProtobufProtocol :: OTLPProtocol
httpProtobufProtocol :: OTLPProtocol
httpProtobufProtocol = OTLPProtocol
OTLPProtocolHTTPProtobuf

-- | Little ad-hoc helper type for use in 'otlpSpanExporterIO'.
data OTLPSpanExporterItem = OTLPSpanExporterItem
  { OTLPSpanExporterItem -> Batch (Span Attrs)
otlpSpanExporterItemBatch :: Batch (Span Attrs)
  , OTLPSpanExporterItem -> SpanExportResult -> IO ()
otlpSpanExporterItemCallback :: SpanExportResult -> IO ()
  , OTLPSpanExporterItem -> Resource Attrs
otlpSpanExporterResource :: Resource Attrs
  }

instance ToJSON OTLPSpanExporterItem where
  toJSON :: OTLPSpanExporterItem -> Value
toJSON = Batch (Span Attrs) -> Value
forall a. ToJSON a => a -> Value
toJSON (Batch (Span Attrs) -> Value)
-> (OTLPSpanExporterItem -> Batch (Span Attrs))
-> OTLPSpanExporterItem
-> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OTLPSpanExporterItem -> Batch (Span Attrs)
otlpSpanExporterItemBatch

stmSpanExporter
  :: forall a
   . TMQueue (Span Attrs)
  -> Logger
  -> (SpanExporterSpec -> IO a)
  -> IO a
stmSpanExporter :: forall a.
TMQueue (Span Attrs)
-> Logger -> (SpanExporterSpec -> IO a) -> IO a
stmSpanExporter TMQueue (Span Attrs)
queue Logger
_logger =
  SpanExporterSpec -> (SpanExporterSpec -> IO a) -> IO a
forall a b. a -> (a -> b) -> b
with SpanExporterSpec
defaultSpanExporterSpec
    { spanExporterSpecName = "stm"
    , spanExporterSpecExport = \Batch (Span Attrs)
spans SpanExportResult -> IO ()
onSpansExported -> do
        SpanExporterM (SpanExporterM ()) -> SpanExporterM ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (SpanExporterM (SpanExporterM ()) -> SpanExporterM ())
-> SpanExporterM (SpanExporterM ()) -> SpanExporterM ()
forall a b. (a -> b) -> a -> b
$ IO (SpanExporterM ()) -> SpanExporterM (SpanExporterM ())
forall a. IO a -> SpanExporterM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (SpanExporterM ()) -> SpanExporterM (SpanExporterM ()))
-> IO (SpanExporterM ()) -> SpanExporterM (SpanExporterM ())
forall a b. (a -> b) -> a -> b
$ STM (SpanExporterM ()) -> IO (SpanExporterM ())
forall a. STM a -> IO a
atomically do
          (Span Attrs -> STM ()) -> Batch (Span Attrs) -> STM ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (TMQueue (Span Attrs) -> Span Attrs -> STM ()
forall a. TMQueue a -> a -> STM ()
writeTMQueue TMQueue (Span Attrs)
queue) Batch (Span Attrs)
spans
          SpanExporterM () -> STM (SpanExporterM ())
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SpanExporterM () -> STM (SpanExporterM ()))
-> SpanExporterM () -> STM (SpanExporterM ())
forall a b. (a -> b) -> a -> b
$ IO () -> SpanExporterM ()
forall a. IO a -> SpanExporterM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> SpanExporterM ()) -> IO () -> SpanExporterM ()
forall a b. (a -> b) -> a -> b
$ SpanExportResult -> IO ()
onSpansExported SpanExportResult
SpanExportResultSuccess
    , spanExporterSpecShutdown = do
        liftIO $ atomically $ closeTMQueue queue
    }

data SpanExporterSpec = SpanExporterSpec
  { SpanExporterSpec -> Text
spanExporterSpecName :: Text
  , SpanExporterSpec
-> Batch (Span Attrs)
-> (SpanExportResult -> IO ())
-> SpanExporterM ()
spanExporterSpecExport
      :: Batch (Span Attrs)
      -> (SpanExportResult -> IO ())
      -> SpanExporterM ()
  , SpanExporterSpec -> SpanExporterM ()
spanExporterSpecShutdown :: SpanExporterM ()
  , SpanExporterSpec -> Int
spanExporterSpecShutdownTimeout :: Int
  , SpanExporterSpec -> SpanExporterM ()
spanExporterSpecForceFlush :: SpanExporterM ()
  , SpanExporterSpec -> Int
spanExporterSpecForceFlushTimeout :: Int
  , SpanExporterSpec -> OnTimeout ()
spanExporterSpecOnTimeout :: OnTimeout ()
  , SpanExporterSpec -> OnException ()
spanExporterSpecOnException :: OnException ()
  }

defaultSpanExporterSpec :: SpanExporterSpec
defaultSpanExporterSpec :: SpanExporterSpec
defaultSpanExporterSpec =
  SpanExporterSpec
    { spanExporterSpecName :: Text
spanExporterSpecName = Text
"default"
    , spanExporterSpecExport :: Batch (Span Attrs)
-> (SpanExportResult -> IO ()) -> SpanExporterM ()
spanExporterSpecExport = Batch (Span Attrs)
-> (SpanExportResult -> IO ()) -> SpanExporterM ()
forall a. Monoid a => a
mempty
    , spanExporterSpecShutdown :: SpanExporterM ()
spanExporterSpecShutdown = SpanExporterM ()
forall a. Monoid a => a
mempty
    , spanExporterSpecShutdownTimeout :: Int
spanExporterSpecShutdownTimeout = Int
30_000_000
    , spanExporterSpecForceFlush :: SpanExporterM ()
spanExporterSpecForceFlush = SpanExporterM ()
forall a. Monoid a => a
mempty
    , spanExporterSpecForceFlushTimeout :: Int
spanExporterSpecForceFlushTimeout = Int
30_000_000
    , spanExporterSpecOnTimeout :: OnTimeout ()
spanExporterSpecOnTimeout = do
        Int
timeoutMicros <- OnTimeout Int
askTimeoutMicros
        [SeriesElem]
pairs <- OnTimeout [SeriesElem]
askTimeoutMetadata
        Message -> OnTimeout ()
forall (m :: * -> *).
(HasCallStack, MonadLogger m) =>
Message -> m ()
logError (Message -> OnTimeout ()) -> Message -> OnTimeout ()
forall a b. (a -> b) -> a -> b
$ Text
"Action did not complete within timeout" Text -> [SeriesElem] -> Message
:#
          Key
"timeoutMicros" Key -> Int -> SeriesElem
forall v. ToJSON v => Key -> v -> SeriesElem
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Int
timeoutMicros SeriesElem -> [SeriesElem] -> [SeriesElem]
forall a. a -> [a] -> [a]
: [SeriesElem]
pairs
    , spanExporterSpecOnException :: OnException ()
spanExporterSpecOnException = do
        SomeException e
ex <- OnException SomeException
askException
        [SeriesElem]
pairs <- OnException [SeriesElem]
askExceptionMetadata
        Message -> OnException ()
forall (m :: * -> *).
(HasCallStack, MonadLogger m) =>
Message -> m ()
logError (Message -> OnException ()) -> Message -> OnException ()
forall a b. (a -> b) -> a -> b
$ Text
"Ignoring exception" Text -> [SeriesElem] -> Message
:#
          Key
"exception" Key -> [Char] -> SeriesElem
forall v. ToJSON v => Key -> v -> SeriesElem
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= e -> [Char]
forall e. Exception e => e -> [Char]
displayException e
ex SeriesElem -> [SeriesElem] -> [SeriesElem]
forall a. a -> [a] -> [a]
: [SeriesElem]
pairs
    }

data Sampler = Sampler
  { Sampler -> Text
samplerName :: Text
  , Sampler -> Text
samplerDescription :: Text
  , Sampler -> SamplerInput -> IO SamplingResult
samplerShouldSample :: SamplerInput -> IO SamplingResult
  }

buildSampler
  :: forall m
   . (MonadIO m)
  => Logger
  -> SamplerSpec
  -> m Sampler
buildSampler :: forall (m :: * -> *).
MonadIO m =>
Logger -> SamplerSpec -> m Sampler
buildSampler Logger
logger SamplerSpec
samplerSpec = do
  (LoggingT m () -> Logger -> m ())
-> Logger -> LoggingT m () -> m ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip LoggingT m () -> Logger -> m ()
forall (m :: * -> *) a. LoggingT m a -> Logger -> m a
runLoggingT Logger
logger do
    Message -> LoggingT m ()
forall (m :: * -> *).
(HasCallStack, MonadLogger m) =>
Message -> m ()
logDebug (Message -> LoggingT m ()) -> Message -> LoggingT m ()
forall a b. (a -> b) -> a -> b
$ Text
"Building sampler" Text -> [SeriesElem] -> Message
:#
      [ Key
"name" Key -> Text -> SeriesElem
forall v. ToJSON v => Key -> v -> SeriesElem
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
samplerSpecName
      , Key
"description" Key -> Text -> SeriesElem
forall v. ToJSON v => Key -> v -> SeriesElem
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
samplerSpecDescription
      ]
  Sampler -> m Sampler
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Sampler
    { samplerName :: Text
samplerName = Text
samplerSpecName
    , samplerDescription :: Text
samplerDescription = Text
samplerSpecDescription
    , samplerShouldSample :: SamplerInput -> IO SamplingResult
samplerShouldSample = \SamplerInput
samplerInput -> do
        Logger
-> OnException SamplingResult
-> [SeriesElem]
-> SamplerM SamplingResult
-> IO SamplingResult
forall a.
Logger -> OnException a -> [SeriesElem] -> SamplerM a -> IO a
runSamplerM Logger
logger OnException SamplingResult
onEx [SeriesElem]
metaShouldSample do
          SamplerInput -> SamplerM SamplingResult
samplerSpecShouldSample SamplerInput
samplerInput
    }
  where
  metaShouldSample :: [SeriesElem]
metaShouldSample = Text -> [SeriesElem]
mkLoggingMeta Text
"shouldSample"

  mkLoggingMeta :: Text -> [SeriesElem]
  mkLoggingMeta :: Text -> [SeriesElem]
mkLoggingMeta Text
method =
    [ Key
"sampler" Key -> Value -> SeriesElem
forall v. ToJSON v => Key -> v -> SeriesElem
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object
        [ Key
"name" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
samplerSpecName
        , Key
"description" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
samplerSpecDescription
        , Key
"method" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
method
        ]
    ]

  SamplerSpec
    { Text
samplerSpecName :: Text
samplerSpecName :: SamplerSpec -> Text
samplerSpecName
    , Text
samplerSpecDescription :: Text
samplerSpecDescription :: SamplerSpec -> Text
samplerSpecDescription
    , SamplerInput -> SamplerM SamplingResult
samplerSpecShouldSample :: SamplerInput -> SamplerM SamplingResult
samplerSpecShouldSample :: SamplerSpec -> SamplerInput -> SamplerM SamplingResult
samplerSpecShouldSample
    , samplerSpecOnException :: SamplerSpec -> OnException SamplingResult
samplerSpecOnException = OnException SamplingResult
onEx
    } = SamplerSpec
samplerSpec

data SamplerSpec = SamplerSpec
  { SamplerSpec -> Text
samplerSpecName :: Text
  , SamplerSpec -> Text
samplerSpecDescription :: Text
  , SamplerSpec -> SamplerInput -> SamplerM SamplingResult
samplerSpecShouldSample :: SamplerInput -> SamplerM SamplingResult
  , SamplerSpec -> OnException SamplingResult
samplerSpecOnException :: OnException SamplingResult
  }

defaultSamplerSpec :: SamplerSpec
defaultSamplerSpec :: SamplerSpec
defaultSamplerSpec = SamplerSpec
alwaysOffSampler'

alwaysOnSampler
  :: forall a
   . Logger
  -> (SamplerSpec -> IO a)
  -> IO a
alwaysOnSampler :: forall a. Logger -> (SamplerSpec -> IO a) -> IO a
alwaysOnSampler Logger
_logger = SamplerSpec -> (SamplerSpec -> IO a) -> IO a
forall a b. a -> (a -> b) -> b
with SamplerSpec
alwaysOnSampler'

alwaysOnSampler' :: SamplerSpec
alwaysOnSampler' :: SamplerSpec
alwaysOnSampler' =
  (SamplingDecision -> SamplerSpec
constDecisionSampler SamplingDecision
SamplingDecisionRecordAndSample)
    { samplerSpecName = "AlwaysOn"
    , samplerSpecDescription = "AlwaysOnSampler"
    }

alwaysOffSampler
  :: forall a
   . Logger
  -> (SamplerSpec -> IO a)
  -> IO a
alwaysOffSampler :: forall a. Logger -> (SamplerSpec -> IO a) -> IO a
alwaysOffSampler Logger
_logger = SamplerSpec -> (SamplerSpec -> IO a) -> IO a
forall a b. a -> (a -> b) -> b
with SamplerSpec
alwaysOffSampler'

alwaysOffSampler' :: SamplerSpec
alwaysOffSampler' :: SamplerSpec
alwaysOffSampler' =
  (SamplingDecision -> SamplerSpec
constDecisionSampler SamplingDecision
SamplingDecisionDrop)
    { samplerSpecName = "AlwaysOff"
    , samplerSpecDescription = "AlwaysOffSampler"
    }

data ParentBasedSamplerSpec = ParentBasedSamplerSpec
  { ParentBasedSamplerSpec
-> forall a. Logger -> (SamplerSpec -> IO a) -> IO a
parentBasedSamplerSpecOnRoot
      :: forall a. Logger -> (SamplerSpec -> IO a) -> IO a
  , ParentBasedSamplerSpec
-> forall a. Logger -> (SamplerSpec -> IO a) -> IO a
parentBasedSamplerSpecOnRemoteParentSampled
      :: forall a. Logger -> (SamplerSpec -> IO a) -> IO a
  , ParentBasedSamplerSpec
-> forall a. Logger -> (SamplerSpec -> IO a) -> IO a
parentBasedSamplerSpecOnRemoteParentNotSampled
      :: forall a. Logger -> (SamplerSpec -> IO a) -> IO a
  , ParentBasedSamplerSpec
-> forall a. Logger -> (SamplerSpec -> IO a) -> IO a
parentBasedSamplerSpecOnLocalParentSampled
      :: forall a. Logger -> (SamplerSpec -> IO a) -> IO a
  , ParentBasedSamplerSpec
-> forall a. Logger -> (SamplerSpec -> IO a) -> IO a
parentBasedSamplerSpecOnLocalParentNotSampled
      :: forall a. Logger -> (SamplerSpec -> IO a) -> IO a
  }

defaultParentBasedSamplerSpec :: ParentBasedSamplerSpec
defaultParentBasedSamplerSpec :: ParentBasedSamplerSpec
defaultParentBasedSamplerSpec =
  ParentBasedSamplerSpec
    { parentBasedSamplerSpecOnRoot :: forall a. Logger -> (SamplerSpec -> IO a) -> IO a
parentBasedSamplerSpecOnRoot = Logger -> (SamplerSpec -> IO a) -> IO a
forall a. Logger -> (SamplerSpec -> IO a) -> IO a
alwaysOffSampler
    , parentBasedSamplerSpecOnRemoteParentSampled :: forall a. Logger -> (SamplerSpec -> IO a) -> IO a
parentBasedSamplerSpecOnRemoteParentSampled = Logger -> (SamplerSpec -> IO a) -> IO a
forall a. Logger -> (SamplerSpec -> IO a) -> IO a
alwaysOnSampler
    , parentBasedSamplerSpecOnRemoteParentNotSampled :: forall a. Logger -> (SamplerSpec -> IO a) -> IO a
parentBasedSamplerSpecOnRemoteParentNotSampled = Logger -> (SamplerSpec -> IO a) -> IO a
forall a. Logger -> (SamplerSpec -> IO a) -> IO a
alwaysOffSampler
    , parentBasedSamplerSpecOnLocalParentSampled :: forall a. Logger -> (SamplerSpec -> IO a) -> IO a
parentBasedSamplerSpecOnLocalParentSampled = Logger -> (SamplerSpec -> IO a) -> IO a
forall a. Logger -> (SamplerSpec -> IO a) -> IO a
alwaysOnSampler
    , parentBasedSamplerSpecOnLocalParentNotSampled :: forall a. Logger -> (SamplerSpec -> IO a) -> IO a
parentBasedSamplerSpecOnLocalParentNotSampled = Logger -> (SamplerSpec -> IO a) -> IO a
forall a. Logger -> (SamplerSpec -> IO a) -> IO a
alwaysOffSampler
    }

parentBasedSampler
  :: forall a
   . ParentBasedSamplerSpec
  -> Logger
  -> (SamplerSpec -> IO a)
  -> IO a
parentBasedSampler :: forall a.
ParentBasedSamplerSpec -> Logger -> (SamplerSpec -> IO a) -> IO a
parentBasedSampler ParentBasedSamplerSpec
parentBasedSamplerSpec Logger
logger =
  ContT a IO SamplerSpec -> (SamplerSpec -> IO a) -> IO a
forall {k} (r :: k) (m :: k -> *) a.
ContT r m a -> (a -> m r) -> m r
runContT do
    SamplerSpec
onRoot <- ((SamplerSpec -> IO a) -> IO a) -> ContT a IO SamplerSpec
forall {k} (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (((SamplerSpec -> IO a) -> IO a) -> ContT a IO SamplerSpec)
-> ((SamplerSpec -> IO a) -> IO a) -> ContT a IO SamplerSpec
forall a b. (a -> b) -> a -> b
$ Logger -> (SamplerSpec -> IO a) -> IO a
forall a. Logger -> (SamplerSpec -> IO a) -> IO a
withOnRoot Logger
logger
    SamplerSpec
onRemoteParentSampled <- ((SamplerSpec -> IO a) -> IO a) -> ContT a IO SamplerSpec
forall {k} (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (((SamplerSpec -> IO a) -> IO a) -> ContT a IO SamplerSpec)
-> ((SamplerSpec -> IO a) -> IO a) -> ContT a IO SamplerSpec
forall a b. (a -> b) -> a -> b
$ Logger -> (SamplerSpec -> IO a) -> IO a
forall a. Logger -> (SamplerSpec -> IO a) -> IO a
withOnRemoteParentSampled Logger
logger
    SamplerSpec
onRemoteParentNotSampled <- ((SamplerSpec -> IO a) -> IO a) -> ContT a IO SamplerSpec
forall {k} (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (((SamplerSpec -> IO a) -> IO a) -> ContT a IO SamplerSpec)
-> ((SamplerSpec -> IO a) -> IO a) -> ContT a IO SamplerSpec
forall a b. (a -> b) -> a -> b
$ Logger -> (SamplerSpec -> IO a) -> IO a
forall a. Logger -> (SamplerSpec -> IO a) -> IO a
withOnRemoteParentNotSampled Logger
logger
    SamplerSpec
onLocalParentSampled <- ((SamplerSpec -> IO a) -> IO a) -> ContT a IO SamplerSpec
forall {k} (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (((SamplerSpec -> IO a) -> IO a) -> ContT a IO SamplerSpec)
-> ((SamplerSpec -> IO a) -> IO a) -> ContT a IO SamplerSpec
forall a b. (a -> b) -> a -> b
$ Logger -> (SamplerSpec -> IO a) -> IO a
forall a. Logger -> (SamplerSpec -> IO a) -> IO a
withOnLocalParentSampled Logger
logger
    SamplerSpec
onLocalParentNotSampled <- ((SamplerSpec -> IO a) -> IO a) -> ContT a IO SamplerSpec
forall {k} (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (((SamplerSpec -> IO a) -> IO a) -> ContT a IO SamplerSpec)
-> ((SamplerSpec -> IO a) -> IO a) -> ContT a IO SamplerSpec
forall a b. (a -> b) -> a -> b
$ Logger -> (SamplerSpec -> IO a) -> IO a
forall a. Logger -> (SamplerSpec -> IO a) -> IO a
withOnLocalParentNotSampled Logger
logger

    let shouldSample :: SpanContext -> SamplerInput -> SamplerM SamplingResult
shouldSample SpanContext
parentSpanContext SamplerInput
samplerInput
          | Bool
hasParent Bool -> Bool -> Bool
&& Bool
parentIsRemote Bool -> Bool -> Bool
&& Bool
parentIsSampled =
              SamplerSpec -> SamplerInput -> SamplerM SamplingResult
samplerSpecShouldSample SamplerSpec
onRemoteParentSampled SamplerInput
samplerInput
          | Bool
hasParent Bool -> Bool -> Bool
&& Bool
parentIsRemote Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
parentIsSampled =
              SamplerSpec -> SamplerInput -> SamplerM SamplingResult
samplerSpecShouldSample SamplerSpec
onRemoteParentNotSampled SamplerInput
samplerInput
          | Bool
hasParent Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
parentIsRemote Bool -> Bool -> Bool
&& Bool
parentIsSampled =
              SamplerSpec -> SamplerInput -> SamplerM SamplingResult
samplerSpecShouldSample SamplerSpec
onLocalParentSampled SamplerInput
samplerInput
          | Bool
hasParent Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
parentIsRemote Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
parentIsSampled =
              SamplerSpec -> SamplerInput -> SamplerM SamplingResult
samplerSpecShouldSample SamplerSpec
onLocalParentNotSampled SamplerInput
samplerInput
          | Bool
otherwise =
              SamplerSpec -> SamplerInput -> SamplerM SamplingResult
samplerSpecShouldSample SamplerSpec
onRoot SamplerInput
samplerInput
          where
          hasParent :: Bool
hasParent = SpanContext -> Bool
spanContextIsValid SpanContext
parentSpanContext
          parentIsRemote :: Bool
parentIsRemote = SpanContext -> Bool
spanContextIsRemote SpanContext
parentSpanContext
          parentIsSampled :: Bool
parentIsSampled = SpanContext -> Bool
spanContextIsSampled SpanContext
parentSpanContext

    SamplerSpec -> ContT a IO SamplerSpec
forall a. a -> ContT a IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SamplerSpec
defaultSamplerSpec
      { samplerSpecName = "ParentBased"
      , samplerSpecDescription = "ParentBased"
      , samplerSpecShouldSample = \SamplerInput
samplerInput -> do
          SpanContext
parentSpanContext <- do
            case ContextKey MutableSpan -> Context -> Maybe MutableSpan
forall a. ContextKey a -> Context -> Maybe a
lookupContext ContextKey MutableSpan
contextKeySpan (Context -> Maybe MutableSpan) -> Context -> Maybe MutableSpan
forall a b. (a -> b) -> a -> b
$ SamplerInput -> Context
samplerInputContext SamplerInput
samplerInput of
              Maybe MutableSpan
Nothing -> SpanContext -> SamplerM SpanContext
forall a. a -> SamplerM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SpanContext
emptySpanContext
              Just MutableSpan
mutableSpan -> do
                IO SpanContext -> SamplerM SpanContext
forall a. IO a -> SamplerM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO SpanContext -> SamplerM SpanContext)
-> IO SpanContext -> SamplerM SpanContext
forall a b. (a -> b) -> a -> b
$ Span AttrsBuilder -> SpanContext
forall (attrs :: AttrsFor -> *). Span attrs -> SpanContext
spanContext (Span AttrsBuilder -> SpanContext)
-> IO (Span AttrsBuilder) -> IO SpanContext
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MutableSpan -> IO (Span AttrsBuilder)
unsafeReadMutableSpan MutableSpan
mutableSpan
          SpanContext -> SamplerInput -> SamplerM SamplingResult
shouldSample SpanContext
parentSpanContext SamplerInput
samplerInput
      }
  where
  ParentBasedSamplerSpec
    { parentBasedSamplerSpecOnRoot :: ParentBasedSamplerSpec
-> forall a. Logger -> (SamplerSpec -> IO a) -> IO a
parentBasedSamplerSpecOnRoot = forall a. Logger -> (SamplerSpec -> IO a) -> IO a
withOnRoot
    , parentBasedSamplerSpecOnRemoteParentSampled :: ParentBasedSamplerSpec
-> forall a. Logger -> (SamplerSpec -> IO a) -> IO a
parentBasedSamplerSpecOnRemoteParentSampled = forall a. Logger -> (SamplerSpec -> IO a) -> IO a
withOnRemoteParentSampled
    , parentBasedSamplerSpecOnRemoteParentNotSampled :: ParentBasedSamplerSpec
-> forall a. Logger -> (SamplerSpec -> IO a) -> IO a
parentBasedSamplerSpecOnRemoteParentNotSampled = forall a. Logger -> (SamplerSpec -> IO a) -> IO a
withOnRemoteParentNotSampled
    , parentBasedSamplerSpecOnLocalParentSampled :: ParentBasedSamplerSpec
-> forall a. Logger -> (SamplerSpec -> IO a) -> IO a
parentBasedSamplerSpecOnLocalParentSampled = forall a. Logger -> (SamplerSpec -> IO a) -> IO a
withOnLocalParentSampled
    , parentBasedSamplerSpecOnLocalParentNotSampled :: ParentBasedSamplerSpec
-> forall a. Logger -> (SamplerSpec -> IO a) -> IO a
parentBasedSamplerSpecOnLocalParentNotSampled = forall a. Logger -> (SamplerSpec -> IO a) -> IO a
withOnLocalParentNotSampled
    } = ParentBasedSamplerSpec
parentBasedSamplerSpec

constDecisionSampler :: SamplingDecision -> SamplerSpec
constDecisionSampler :: SamplingDecision -> SamplerSpec
constDecisionSampler SamplingDecision
samplingDecision =
  SamplerSpec
    { samplerSpecName :: Text
samplerSpecName = Text
"ConstDecision"
    , samplerSpecDescription :: Text
samplerSpecDescription = Text
"ConstDecision{" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
samplingDecisionText Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"}"
    , samplerSpecShouldSample :: SamplerInput -> SamplerM SamplingResult
samplerSpecShouldSample = SamplerInput -> SamplerM SamplingResult
shouldSample
    , samplerSpecOnException :: OnException SamplingResult
samplerSpecOnException = do
        SomeException e
ex <- OnException SomeException
askException
        [SeriesElem]
pairs <- OnException [SeriesElem]
askExceptionMetadata
        Message -> OnException ()
forall (m :: * -> *).
(HasCallStack, MonadLogger m) =>
Message -> m ()
logError (Message -> OnException ()) -> Message -> OnException ()
forall a b. (a -> b) -> a -> b
$ Text
"Rethrowing unhandled exception from sampler" Text -> [SeriesElem] -> Message
:#
          Key
"exception" Key -> [Char] -> SeriesElem
forall v. ToJSON v => Key -> v -> SeriesElem
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= e -> [Char]
forall e. Exception e => e -> [Char]
displayException e
ex SeriesElem -> [SeriesElem] -> [SeriesElem]
forall a. a -> [a] -> [a]
: [SeriesElem]
pairs
        e -> OnException SamplingResult
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Exception e) =>
e -> m a
throwM e
ex
    }
  where
  shouldSample :: SamplerInput -> SamplerM SamplingResult
shouldSample SamplerInput
samplerInput = do
    TraceState
samplingResultTraceState <- do
      case ContextKey MutableSpan -> Context -> Maybe MutableSpan
forall a. ContextKey a -> Context -> Maybe a
lookupContext ContextKey MutableSpan
contextKeySpan Context
samplerInputContext of
        Maybe MutableSpan
Nothing -> TraceState -> SamplerM TraceState
forall a. a -> SamplerM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TraceState
emptyTraceState
        Just MutableSpan
mutableSpan -> do
          IO TraceState -> SamplerM TraceState
forall a. IO a -> SamplerM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
            (IO TraceState -> SamplerM TraceState)
-> IO TraceState -> SamplerM TraceState
forall a b. (a -> b) -> a -> b
$ (Span AttrsBuilder -> TraceState)
-> IO (Span AttrsBuilder) -> IO TraceState
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SpanContext -> TraceState
spanContextTraceState (SpanContext -> TraceState)
-> (Span AttrsBuilder -> SpanContext)
-> Span AttrsBuilder
-> TraceState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Span AttrsBuilder -> SpanContext
forall (attrs :: AttrsFor -> *). Span attrs -> SpanContext
spanContext)
            (IO (Span AttrsBuilder) -> IO TraceState)
-> IO (Span AttrsBuilder) -> IO TraceState
forall a b. (a -> b) -> a -> b
$ MutableSpan -> IO (Span AttrsBuilder)
unsafeReadMutableSpan MutableSpan
mutableSpan
    SamplingResult -> SamplerM SamplingResult
forall a. a -> SamplerM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SamplingResult
defaultSamplingResult
      { samplingResultDecision = samplingDecision
      , samplingResultSpanAttrs = mempty
      , samplingResultTraceState
      }
    where
    SamplerInput { Context
samplerInputContext :: SamplerInput -> Context
samplerInputContext :: Context
samplerInputContext } = SamplerInput
samplerInput

  samplingDecisionText :: Text
samplingDecisionText =
    case SamplingDecision
samplingDecision of
      SamplingDecision
SamplingDecisionDrop -> Text
"DROP"
      SamplingDecision
SamplingDecisionRecordOnly -> Text
"RECORD_ONLY"
      SamplingDecision
SamplingDecisionRecordAndSample -> Text
"RECORD_AND_SAMPLE"

data SamplerInput = SamplerInput
  { SamplerInput -> Context
samplerInputContext :: Context
  , SamplerInput -> TraceId
samplerInputTraceId :: TraceId
  , SamplerInput -> SpanName
samplerInputSpanName :: SpanName
  , SamplerInput -> SpanKind
samplerInputSpanKind :: SpanKind
  , SamplerInput -> AttrsBuilder 'AttrsForSpan
samplerInputSpanAttrs :: AttrsBuilder 'AttrsForSpan
  , SamplerInput -> SpanLinks AttrsBuilder
samplerInputSpanLinks :: SpanLinks AttrsBuilder
  }

data SamplingResult = SamplingResult
  { SamplingResult -> SamplingDecision
samplingResultDecision :: SamplingDecision
  , SamplingResult -> AttrsBuilder 'AttrsForSpan
samplingResultSpanAttrs :: AttrsBuilder 'AttrsForSpan
  , SamplingResult -> TraceState
samplingResultTraceState :: TraceState
  }

defaultSamplingResult :: SamplingResult
defaultSamplingResult :: SamplingResult
defaultSamplingResult =
  SamplingResult
    { samplingResultDecision :: SamplingDecision
samplingResultDecision = SamplingDecision
SamplingDecisionDrop
    , samplingResultSpanAttrs :: AttrsBuilder 'AttrsForSpan
samplingResultSpanAttrs = AttrsBuilder 'AttrsForSpan
forall a. Monoid a => a
mempty
    , samplingResultTraceState :: TraceState
samplingResultTraceState = TraceState
emptyTraceState
    }

data SamplingDecision
  = SamplingDecisionDrop
  | SamplingDecisionRecordOnly
  | SamplingDecisionRecordAndSample
  deriving stock (SamplingDecision -> SamplingDecision -> Bool
(SamplingDecision -> SamplingDecision -> Bool)
-> (SamplingDecision -> SamplingDecision -> Bool)
-> Eq SamplingDecision
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SamplingDecision -> SamplingDecision -> Bool
== :: SamplingDecision -> SamplingDecision -> Bool
$c/= :: SamplingDecision -> SamplingDecision -> Bool
/= :: SamplingDecision -> SamplingDecision -> Bool
Eq, Int -> SamplingDecision -> ShowS
[SamplingDecision] -> ShowS
SamplingDecision -> [Char]
(Int -> SamplingDecision -> ShowS)
-> (SamplingDecision -> [Char])
-> ([SamplingDecision] -> ShowS)
-> Show SamplingDecision
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SamplingDecision -> ShowS
showsPrec :: Int -> SamplingDecision -> ShowS
$cshow :: SamplingDecision -> [Char]
show :: SamplingDecision -> [Char]
$cshowList :: [SamplingDecision] -> ShowS
showList :: [SamplingDecision] -> ShowS
Show)

samplingDecisionDrop :: SamplingDecision
samplingDecisionDrop :: SamplingDecision
samplingDecisionDrop = SamplingDecision
SamplingDecisionDrop

samplingDecisionRecordOnly :: SamplingDecision
samplingDecisionRecordOnly :: SamplingDecision
samplingDecisionRecordOnly = SamplingDecision
SamplingDecisionRecordOnly

samplingDecisionRecordAndSample :: SamplingDecision
samplingDecisionRecordAndSample :: SamplingDecision
samplingDecisionRecordAndSample = SamplingDecision
SamplingDecisionRecordAndSample

type SpanProcessorM :: Type -> Type
newtype SpanProcessorM a = SpanProcessorM
  { forall a. SpanProcessorM a -> SpanExporter -> LoggingT IO a
unSpanProcessorM :: SpanExporter -> LoggingT IO a
  } deriving
      ( Functor SpanProcessorM
Functor SpanProcessorM =>
(forall a. a -> SpanProcessorM a)
-> (forall a b.
    SpanProcessorM (a -> b) -> SpanProcessorM a -> SpanProcessorM b)
-> (forall a b c.
    (a -> b -> c)
    -> SpanProcessorM a -> SpanProcessorM b -> SpanProcessorM c)
-> (forall a b.
    SpanProcessorM a -> SpanProcessorM b -> SpanProcessorM b)
-> (forall a b.
    SpanProcessorM a -> SpanProcessorM b -> SpanProcessorM a)
-> Applicative SpanProcessorM
forall a. a -> SpanProcessorM a
forall a b.
SpanProcessorM a -> SpanProcessorM b -> SpanProcessorM a
forall a b.
SpanProcessorM a -> SpanProcessorM b -> SpanProcessorM b
forall a b.
SpanProcessorM (a -> b) -> SpanProcessorM a -> SpanProcessorM b
forall a b c.
(a -> b -> c)
-> SpanProcessorM a -> SpanProcessorM b -> SpanProcessorM c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> SpanProcessorM a
pure :: forall a. a -> SpanProcessorM a
$c<*> :: forall a b.
SpanProcessorM (a -> b) -> SpanProcessorM a -> SpanProcessorM b
<*> :: forall a b.
SpanProcessorM (a -> b) -> SpanProcessorM a -> SpanProcessorM b
$cliftA2 :: forall a b c.
(a -> b -> c)
-> SpanProcessorM a -> SpanProcessorM b -> SpanProcessorM c
liftA2 :: forall a b c.
(a -> b -> c)
-> SpanProcessorM a -> SpanProcessorM b -> SpanProcessorM c
$c*> :: forall a b.
SpanProcessorM a -> SpanProcessorM b -> SpanProcessorM b
*> :: forall a b.
SpanProcessorM a -> SpanProcessorM b -> SpanProcessorM b
$c<* :: forall a b.
SpanProcessorM a -> SpanProcessorM b -> SpanProcessorM a
<* :: forall a b.
SpanProcessorM a -> SpanProcessorM b -> SpanProcessorM a
Applicative, (forall a b. (a -> b) -> SpanProcessorM a -> SpanProcessorM b)
-> (forall a b. a -> SpanProcessorM b -> SpanProcessorM a)
-> Functor SpanProcessorM
forall a b. a -> SpanProcessorM b -> SpanProcessorM a
forall a b. (a -> b) -> SpanProcessorM a -> SpanProcessorM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> SpanProcessorM a -> SpanProcessorM b
fmap :: forall a b. (a -> b) -> SpanProcessorM a -> SpanProcessorM b
$c<$ :: forall a b. a -> SpanProcessorM b -> SpanProcessorM a
<$ :: forall a b. a -> SpanProcessorM b -> SpanProcessorM a
Functor, Applicative SpanProcessorM
Applicative SpanProcessorM =>
(forall a b.
 SpanProcessorM a -> (a -> SpanProcessorM b) -> SpanProcessorM b)
-> (forall a b.
    SpanProcessorM a -> SpanProcessorM b -> SpanProcessorM b)
-> (forall a. a -> SpanProcessorM a)
-> Monad SpanProcessorM
forall a. a -> SpanProcessorM a
forall a b.
SpanProcessorM a -> SpanProcessorM b -> SpanProcessorM b
forall a b.
SpanProcessorM a -> (a -> SpanProcessorM b) -> SpanProcessorM b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b.
SpanProcessorM a -> (a -> SpanProcessorM b) -> SpanProcessorM b
>>= :: forall a b.
SpanProcessorM a -> (a -> SpanProcessorM b) -> SpanProcessorM b
$c>> :: forall a b.
SpanProcessorM a -> SpanProcessorM b -> SpanProcessorM b
>> :: forall a b.
SpanProcessorM a -> SpanProcessorM b -> SpanProcessorM b
$creturn :: forall a. a -> SpanProcessorM a
return :: forall a. a -> SpanProcessorM a
Monad, Monad SpanProcessorM
Monad SpanProcessorM =>
(forall a. IO a -> SpanProcessorM a) -> MonadIO SpanProcessorM
forall a. IO a -> SpanProcessorM a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall a. IO a -> SpanProcessorM a
liftIO :: forall a. IO a -> SpanProcessorM a
MonadIO -- @base@
      , MonadThrow SpanProcessorM
MonadThrow SpanProcessorM =>
(forall e a.
 (HasCallStack, Exception e) =>
 SpanProcessorM a -> (e -> SpanProcessorM a) -> SpanProcessorM a)
-> MonadCatch SpanProcessorM
forall e a.
(HasCallStack, Exception e) =>
SpanProcessorM a -> (e -> SpanProcessorM a) -> SpanProcessorM a
forall (m :: * -> *).
MonadThrow m =>
(forall e a.
 (HasCallStack, Exception e) =>
 m a -> (e -> m a) -> m a)
-> MonadCatch m
$ccatch :: forall e a.
(HasCallStack, Exception e) =>
SpanProcessorM a -> (e -> SpanProcessorM a) -> SpanProcessorM a
catch :: forall e a.
(HasCallStack, Exception e) =>
SpanProcessorM a -> (e -> SpanProcessorM a) -> SpanProcessorM a
MonadCatch, MonadCatch SpanProcessorM
MonadCatch SpanProcessorM =>
(forall b.
 HasCallStack =>
 ((forall a. SpanProcessorM a -> SpanProcessorM a)
  -> SpanProcessorM b)
 -> SpanProcessorM b)
-> (forall b.
    HasCallStack =>
    ((forall a. SpanProcessorM a -> SpanProcessorM a)
     -> SpanProcessorM b)
    -> SpanProcessorM b)
-> (forall a b c.
    HasCallStack =>
    SpanProcessorM a
    -> (a -> ExitCase b -> SpanProcessorM c)
    -> (a -> SpanProcessorM b)
    -> SpanProcessorM (b, c))
-> MonadMask SpanProcessorM
forall b.
HasCallStack =>
((forall a. SpanProcessorM a -> SpanProcessorM a)
 -> SpanProcessorM b)
-> SpanProcessorM b
forall a b c.
HasCallStack =>
SpanProcessorM a
-> (a -> ExitCase b -> SpanProcessorM c)
-> (a -> SpanProcessorM b)
-> SpanProcessorM (b, c)
forall (m :: * -> *).
MonadCatch m =>
(forall b. HasCallStack => ((forall a. m a -> m a) -> m b) -> m b)
-> (forall b.
    HasCallStack =>
    ((forall a. m a -> m a) -> m b) -> m b)
-> (forall a b c.
    HasCallStack =>
    m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c))
-> MonadMask m
$cmask :: forall b.
HasCallStack =>
((forall a. SpanProcessorM a -> SpanProcessorM a)
 -> SpanProcessorM b)
-> SpanProcessorM b
mask :: forall b.
HasCallStack =>
((forall a. SpanProcessorM a -> SpanProcessorM a)
 -> SpanProcessorM b)
-> SpanProcessorM b
$cuninterruptibleMask :: forall b.
HasCallStack =>
((forall a. SpanProcessorM a -> SpanProcessorM a)
 -> SpanProcessorM b)
-> SpanProcessorM b
uninterruptibleMask :: forall b.
HasCallStack =>
((forall a. SpanProcessorM a -> SpanProcessorM a)
 -> SpanProcessorM b)
-> SpanProcessorM b
$cgeneralBracket :: forall a b c.
HasCallStack =>
SpanProcessorM a
-> (a -> ExitCase b -> SpanProcessorM c)
-> (a -> SpanProcessorM b)
-> SpanProcessorM (b, c)
generalBracket :: forall a b c.
HasCallStack =>
SpanProcessorM a
-> (a -> ExitCase b -> SpanProcessorM c)
-> (a -> SpanProcessorM b)
-> SpanProcessorM (b, c)
MonadMask, Monad SpanProcessorM
Monad SpanProcessorM =>
(forall e a. (HasCallStack, Exception e) => e -> SpanProcessorM a)
-> MonadThrow SpanProcessorM
forall e a. (HasCallStack, Exception e) => e -> SpanProcessorM a
forall (m :: * -> *).
Monad m =>
(forall e a. (HasCallStack, Exception e) => e -> m a)
-> MonadThrow m
$cthrowM :: forall e a. (HasCallStack, Exception e) => e -> SpanProcessorM a
throwM :: forall e a. (HasCallStack, Exception e) => e -> SpanProcessorM a
MonadThrow -- @exceptions@
      , MonadIO SpanProcessorM
MonadIO SpanProcessorM =>
(forall b.
 ((forall a. SpanProcessorM a -> IO a) -> IO b) -> SpanProcessorM b)
-> MonadUnliftIO SpanProcessorM
forall b.
((forall a. SpanProcessorM a -> IO a) -> IO b) -> SpanProcessorM b
forall (m :: * -> *).
MonadIO m =>
(forall b. ((forall a. m a -> IO a) -> IO b) -> m b)
-> MonadUnliftIO m
$cwithRunInIO :: forall b.
((forall a. SpanProcessorM a -> IO a) -> IO b) -> SpanProcessorM b
withRunInIO :: forall b.
((forall a. SpanProcessorM a -> IO a) -> IO b) -> SpanProcessorM b
MonadUnliftIO -- @unliftio-core@
      , Monad SpanProcessorM
Monad SpanProcessorM =>
(forall msg.
 ToLogStr msg =>
 Loc -> Text -> LogLevel -> msg -> SpanProcessorM ())
-> MonadLogger SpanProcessorM
forall msg.
ToLogStr msg =>
Loc -> Text -> LogLevel -> msg -> SpanProcessorM ()
forall (m :: * -> *).
Monad m =>
(forall msg.
 ToLogStr msg =>
 Loc -> Text -> LogLevel -> msg -> m ())
-> MonadLogger m
$cmonadLoggerLog :: forall msg.
ToLogStr msg =>
Loc -> Text -> LogLevel -> msg -> SpanProcessorM ()
monadLoggerLog :: forall msg.
ToLogStr msg =>
Loc -> Text -> LogLevel -> msg -> SpanProcessorM ()
MonadLogger, MonadIO SpanProcessorM
MonadLogger SpanProcessorM
SpanProcessorM Logger
(MonadLogger SpanProcessorM, MonadIO SpanProcessorM) =>
SpanProcessorM Logger -> MonadLoggerIO SpanProcessorM
forall (m :: * -> *).
(MonadLogger m, MonadIO m) =>
m Logger -> MonadLoggerIO m
$caskLoggerIO :: SpanProcessorM Logger
askLoggerIO :: SpanProcessorM Logger
MonadLoggerIO -- @monad-logger@
      ) via (ReaderT SpanExporter (LoggingT IO))
    deriving
      ( NonEmpty (SpanProcessorM a) -> SpanProcessorM a
SpanProcessorM a -> SpanProcessorM a -> SpanProcessorM a
(SpanProcessorM a -> SpanProcessorM a -> SpanProcessorM a)
-> (NonEmpty (SpanProcessorM a) -> SpanProcessorM a)
-> (forall b.
    Integral b =>
    b -> SpanProcessorM a -> SpanProcessorM a)
-> Semigroup (SpanProcessorM a)
forall b. Integral b => b -> SpanProcessorM a -> SpanProcessorM a
forall a.
Semigroup a =>
NonEmpty (SpanProcessorM a) -> SpanProcessorM a
forall a.
Semigroup a =>
SpanProcessorM a -> SpanProcessorM a -> SpanProcessorM a
forall a b.
(Semigroup a, Integral b) =>
b -> SpanProcessorM a -> SpanProcessorM a
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: forall a.
Semigroup a =>
SpanProcessorM a -> SpanProcessorM a -> SpanProcessorM a
<> :: SpanProcessorM a -> SpanProcessorM a -> SpanProcessorM a
$csconcat :: forall a.
Semigroup a =>
NonEmpty (SpanProcessorM a) -> SpanProcessorM a
sconcat :: NonEmpty (SpanProcessorM a) -> SpanProcessorM a
$cstimes :: forall a b.
(Semigroup a, Integral b) =>
b -> SpanProcessorM a -> SpanProcessorM a
stimes :: forall b. Integral b => b -> SpanProcessorM a -> SpanProcessorM a
Semigroup, Semigroup (SpanProcessorM a)
SpanProcessorM a
Semigroup (SpanProcessorM a) =>
SpanProcessorM a
-> (SpanProcessorM a -> SpanProcessorM a -> SpanProcessorM a)
-> ([SpanProcessorM a] -> SpanProcessorM a)
-> Monoid (SpanProcessorM a)
[SpanProcessorM a] -> SpanProcessorM a
SpanProcessorM a -> SpanProcessorM a -> SpanProcessorM a
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall a. Monoid a => Semigroup (SpanProcessorM a)
forall a. Monoid a => SpanProcessorM a
forall a. Monoid a => [SpanProcessorM a] -> SpanProcessorM a
forall a.
Monoid a =>
SpanProcessorM a -> SpanProcessorM a -> SpanProcessorM a
$cmempty :: forall a. Monoid a => SpanProcessorM a
mempty :: SpanProcessorM a
$cmappend :: forall a.
Monoid a =>
SpanProcessorM a -> SpanProcessorM a -> SpanProcessorM a
mappend :: SpanProcessorM a -> SpanProcessorM a -> SpanProcessorM a
$cmconcat :: forall a. Monoid a => [SpanProcessorM a] -> SpanProcessorM a
mconcat :: [SpanProcessorM a] -> SpanProcessorM a
Monoid -- @base@
      ) via (Ap (ReaderT SpanExporter (LoggingT IO)) a)

askSpanExporter :: SpanProcessorM SpanExporter
askSpanExporter :: SpanProcessorM SpanExporter
askSpanExporter = (SpanExporter -> LoggingT IO SpanExporter)
-> SpanProcessorM SpanExporter
forall a. (SpanExporter -> LoggingT IO a) -> SpanProcessorM a
SpanProcessorM SpanExporter -> LoggingT IO SpanExporter
forall a. a -> LoggingT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

runSpanProcessorM
  :: SpanExporter
  -> Logger
  -> OnTimeout a
  -> OnException a
  -> Int
  -> [SeriesElem]
  -> SpanProcessorM a
  -> IO a
runSpanProcessorM :: forall a.
SpanExporter
-> Logger
-> OnTimeout a
-> OnException a
-> Int
-> [SeriesElem]
-> SpanProcessorM a
-> IO a
runSpanProcessorM SpanExporter
spanExporter Logger
logger OnTimeout a
onTimeout OnException a
onEx Int
timeoutMicros [SeriesElem]
pairs SpanProcessorM a
action = do
  (LoggingT IO a -> Logger -> IO a)
-> Logger -> LoggingT IO a -> IO a
forall a b c. (a -> b -> c) -> b -> a -> c
flip LoggingT IO a -> Logger -> IO a
forall (m :: * -> *) a. LoggingT m a -> Logger -> m a
runLoggingT Logger
logger do
    Maybe a
mResult <- ((forall a. LoggingT IO a -> IO a) -> IO (Maybe a))
-> LoggingT IO (Maybe a)
forall b.
((forall a. LoggingT IO a -> IO a) -> IO b) -> LoggingT IO b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO \forall a. LoggingT IO a -> IO a
runInIO -> do
      Int -> IO a -> IO (Maybe a)
forall a. Int -> IO a -> IO (Maybe a)
timeout Int
timeoutMicros (IO a -> IO (Maybe a)) -> IO a -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ LoggingT IO a -> IO a
forall a. LoggingT IO a -> IO a
runInIO do
        SpanProcessorM a -> SpanExporter -> LoggingT IO a
forall a. SpanProcessorM a -> SpanExporter -> LoggingT IO a
unSpanProcessorM SpanProcessorM a
action SpanExporter
spanExporter LoggingT IO a -> (SomeException -> LoggingT IO a) -> LoggingT IO a
forall (m :: * -> *) a.
(HasCallStack, MonadCatch m) =>
m a -> (SomeException -> m a) -> m a
`catchAny` \SomeException
someEx -> do
          OnException a -> SomeException -> [SeriesElem] -> LoggingT IO a
forall a.
OnException a -> SomeException -> [SeriesElem] -> LoggingT IO a
runOnException OnException a
onEx SomeException
someEx [SeriesElem]
pairs
    case Maybe a
mResult of
      Just a
x -> a -> LoggingT IO a
forall a. a -> LoggingT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
      Maybe a
Nothing -> OnTimeout a -> Int -> [SeriesElem] -> LoggingT IO a
forall a. OnTimeout a -> Int -> [SeriesElem] -> LoggingT IO a
runOnTimeout OnTimeout a
onTimeout Int
timeoutMicros [SeriesElem]
pairs

type SpanExporterM :: Type -> Type
newtype SpanExporterM a = SpanExporterM
  { forall a. SpanExporterM a -> Resource Attrs -> LoggingT IO a
unSpanExporterM :: Resource Attrs -> LoggingT IO a
  } deriving
      ( Functor SpanExporterM
Functor SpanExporterM =>
(forall a. a -> SpanExporterM a)
-> (forall a b.
    SpanExporterM (a -> b) -> SpanExporterM a -> SpanExporterM b)
-> (forall a b c.
    (a -> b -> c)
    -> SpanExporterM a -> SpanExporterM b -> SpanExporterM c)
-> (forall a b.
    SpanExporterM a -> SpanExporterM b -> SpanExporterM b)
-> (forall a b.
    SpanExporterM a -> SpanExporterM b -> SpanExporterM a)
-> Applicative SpanExporterM
forall a. a -> SpanExporterM a
forall a b. SpanExporterM a -> SpanExporterM b -> SpanExporterM a
forall a b. SpanExporterM a -> SpanExporterM b -> SpanExporterM b
forall a b.
SpanExporterM (a -> b) -> SpanExporterM a -> SpanExporterM b
forall a b c.
(a -> b -> c)
-> SpanExporterM a -> SpanExporterM b -> SpanExporterM c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> SpanExporterM a
pure :: forall a. a -> SpanExporterM a
$c<*> :: forall a b.
SpanExporterM (a -> b) -> SpanExporterM a -> SpanExporterM b
<*> :: forall a b.
SpanExporterM (a -> b) -> SpanExporterM a -> SpanExporterM b
$cliftA2 :: forall a b c.
(a -> b -> c)
-> SpanExporterM a -> SpanExporterM b -> SpanExporterM c
liftA2 :: forall a b c.
(a -> b -> c)
-> SpanExporterM a -> SpanExporterM b -> SpanExporterM c
$c*> :: forall a b. SpanExporterM a -> SpanExporterM b -> SpanExporterM b
*> :: forall a b. SpanExporterM a -> SpanExporterM b -> SpanExporterM b
$c<* :: forall a b. SpanExporterM a -> SpanExporterM b -> SpanExporterM a
<* :: forall a b. SpanExporterM a -> SpanExporterM b -> SpanExporterM a
Applicative, (forall a b. (a -> b) -> SpanExporterM a -> SpanExporterM b)
-> (forall a b. a -> SpanExporterM b -> SpanExporterM a)
-> Functor SpanExporterM
forall a b. a -> SpanExporterM b -> SpanExporterM a
forall a b. (a -> b) -> SpanExporterM a -> SpanExporterM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> SpanExporterM a -> SpanExporterM b
fmap :: forall a b. (a -> b) -> SpanExporterM a -> SpanExporterM b
$c<$ :: forall a b. a -> SpanExporterM b -> SpanExporterM a
<$ :: forall a b. a -> SpanExporterM b -> SpanExporterM a
Functor, Applicative SpanExporterM
Applicative SpanExporterM =>
(forall a b.
 SpanExporterM a -> (a -> SpanExporterM b) -> SpanExporterM b)
-> (forall a b.
    SpanExporterM a -> SpanExporterM b -> SpanExporterM b)
-> (forall a. a -> SpanExporterM a)
-> Monad SpanExporterM
forall a. a -> SpanExporterM a
forall a b. SpanExporterM a -> SpanExporterM b -> SpanExporterM b
forall a b.
SpanExporterM a -> (a -> SpanExporterM b) -> SpanExporterM b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b.
SpanExporterM a -> (a -> SpanExporterM b) -> SpanExporterM b
>>= :: forall a b.
SpanExporterM a -> (a -> SpanExporterM b) -> SpanExporterM b
$c>> :: forall a b. SpanExporterM a -> SpanExporterM b -> SpanExporterM b
>> :: forall a b. SpanExporterM a -> SpanExporterM b -> SpanExporterM b
$creturn :: forall a. a -> SpanExporterM a
return :: forall a. a -> SpanExporterM a
Monad, Monad SpanExporterM
Monad SpanExporterM =>
(forall a. IO a -> SpanExporterM a) -> MonadIO SpanExporterM
forall a. IO a -> SpanExporterM a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall a. IO a -> SpanExporterM a
liftIO :: forall a. IO a -> SpanExporterM a
MonadIO -- @base@
      , MonadThrow SpanExporterM
MonadThrow SpanExporterM =>
(forall e a.
 (HasCallStack, Exception e) =>
 SpanExporterM a -> (e -> SpanExporterM a) -> SpanExporterM a)
-> MonadCatch SpanExporterM
forall e a.
(HasCallStack, Exception e) =>
SpanExporterM a -> (e -> SpanExporterM a) -> SpanExporterM a
forall (m :: * -> *).
MonadThrow m =>
(forall e a.
 (HasCallStack, Exception e) =>
 m a -> (e -> m a) -> m a)
-> MonadCatch m
$ccatch :: forall e a.
(HasCallStack, Exception e) =>
SpanExporterM a -> (e -> SpanExporterM a) -> SpanExporterM a
catch :: forall e a.
(HasCallStack, Exception e) =>
SpanExporterM a -> (e -> SpanExporterM a) -> SpanExporterM a
MonadCatch, MonadCatch SpanExporterM
MonadCatch SpanExporterM =>
(forall b.
 HasCallStack =>
 ((forall a. SpanExporterM a -> SpanExporterM a) -> SpanExporterM b)
 -> SpanExporterM b)
-> (forall b.
    HasCallStack =>
    ((forall a. SpanExporterM a -> SpanExporterM a) -> SpanExporterM b)
    -> SpanExporterM b)
-> (forall a b c.
    HasCallStack =>
    SpanExporterM a
    -> (a -> ExitCase b -> SpanExporterM c)
    -> (a -> SpanExporterM b)
    -> SpanExporterM (b, c))
-> MonadMask SpanExporterM
forall b.
HasCallStack =>
((forall a. SpanExporterM a -> SpanExporterM a) -> SpanExporterM b)
-> SpanExporterM b
forall a b c.
HasCallStack =>
SpanExporterM a
-> (a -> ExitCase b -> SpanExporterM c)
-> (a -> SpanExporterM b)
-> SpanExporterM (b, c)
forall (m :: * -> *).
MonadCatch m =>
(forall b. HasCallStack => ((forall a. m a -> m a) -> m b) -> m b)
-> (forall b.
    HasCallStack =>
    ((forall a. m a -> m a) -> m b) -> m b)
-> (forall a b c.
    HasCallStack =>
    m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c))
-> MonadMask m
$cmask :: forall b.
HasCallStack =>
((forall a. SpanExporterM a -> SpanExporterM a) -> SpanExporterM b)
-> SpanExporterM b
mask :: forall b.
HasCallStack =>
((forall a. SpanExporterM a -> SpanExporterM a) -> SpanExporterM b)
-> SpanExporterM b
$cuninterruptibleMask :: forall b.
HasCallStack =>
((forall a. SpanExporterM a -> SpanExporterM a) -> SpanExporterM b)
-> SpanExporterM b
uninterruptibleMask :: forall b.
HasCallStack =>
((forall a. SpanExporterM a -> SpanExporterM a) -> SpanExporterM b)
-> SpanExporterM b
$cgeneralBracket :: forall a b c.
HasCallStack =>
SpanExporterM a
-> (a -> ExitCase b -> SpanExporterM c)
-> (a -> SpanExporterM b)
-> SpanExporterM (b, c)
generalBracket :: forall a b c.
HasCallStack =>
SpanExporterM a
-> (a -> ExitCase b -> SpanExporterM c)
-> (a -> SpanExporterM b)
-> SpanExporterM (b, c)
MonadMask, Monad SpanExporterM
Monad SpanExporterM =>
(forall e a. (HasCallStack, Exception e) => e -> SpanExporterM a)
-> MonadThrow SpanExporterM
forall e a. (HasCallStack, Exception e) => e -> SpanExporterM a
forall (m :: * -> *).
Monad m =>
(forall e a. (HasCallStack, Exception e) => e -> m a)
-> MonadThrow m
$cthrowM :: forall e a. (HasCallStack, Exception e) => e -> SpanExporterM a
throwM :: forall e a. (HasCallStack, Exception e) => e -> SpanExporterM a
MonadThrow -- @exceptions@
      , MonadIO SpanExporterM
MonadIO SpanExporterM =>
(forall b.
 ((forall a. SpanExporterM a -> IO a) -> IO b) -> SpanExporterM b)
-> MonadUnliftIO SpanExporterM
forall b.
((forall a. SpanExporterM a -> IO a) -> IO b) -> SpanExporterM b
forall (m :: * -> *).
MonadIO m =>
(forall b. ((forall a. m a -> IO a) -> IO b) -> m b)
-> MonadUnliftIO m
$cwithRunInIO :: forall b.
((forall a. SpanExporterM a -> IO a) -> IO b) -> SpanExporterM b
withRunInIO :: forall b.
((forall a. SpanExporterM a -> IO a) -> IO b) -> SpanExporterM b
MonadUnliftIO -- @unliftio-core@
      , Monad SpanExporterM
Monad SpanExporterM =>
(forall msg.
 ToLogStr msg =>
 Loc -> Text -> LogLevel -> msg -> SpanExporterM ())
-> MonadLogger SpanExporterM
forall msg.
ToLogStr msg =>
Loc -> Text -> LogLevel -> msg -> SpanExporterM ()
forall (m :: * -> *).
Monad m =>
(forall msg.
 ToLogStr msg =>
 Loc -> Text -> LogLevel -> msg -> m ())
-> MonadLogger m
$cmonadLoggerLog :: forall msg.
ToLogStr msg =>
Loc -> Text -> LogLevel -> msg -> SpanExporterM ()
monadLoggerLog :: forall msg.
ToLogStr msg =>
Loc -> Text -> LogLevel -> msg -> SpanExporterM ()
MonadLogger, MonadIO SpanExporterM
MonadLogger SpanExporterM
SpanExporterM Logger
(MonadLogger SpanExporterM, MonadIO SpanExporterM) =>
SpanExporterM Logger -> MonadLoggerIO SpanExporterM
forall (m :: * -> *).
(MonadLogger m, MonadIO m) =>
m Logger -> MonadLoggerIO m
$caskLoggerIO :: SpanExporterM Logger
askLoggerIO :: SpanExporterM Logger
MonadLoggerIO -- @monad-logger@
      ) via (ReaderT (Resource Attrs) (LoggingT IO))
    deriving
      ( NonEmpty (SpanExporterM a) -> SpanExporterM a
SpanExporterM a -> SpanExporterM a -> SpanExporterM a
(SpanExporterM a -> SpanExporterM a -> SpanExporterM a)
-> (NonEmpty (SpanExporterM a) -> SpanExporterM a)
-> (forall b.
    Integral b =>
    b -> SpanExporterM a -> SpanExporterM a)
-> Semigroup (SpanExporterM a)
forall b. Integral b => b -> SpanExporterM a -> SpanExporterM a
forall a.
Semigroup a =>
NonEmpty (SpanExporterM a) -> SpanExporterM a
forall a.
Semigroup a =>
SpanExporterM a -> SpanExporterM a -> SpanExporterM a
forall a b.
(Semigroup a, Integral b) =>
b -> SpanExporterM a -> SpanExporterM a
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: forall a.
Semigroup a =>
SpanExporterM a -> SpanExporterM a -> SpanExporterM a
<> :: SpanExporterM a -> SpanExporterM a -> SpanExporterM a
$csconcat :: forall a.
Semigroup a =>
NonEmpty (SpanExporterM a) -> SpanExporterM a
sconcat :: NonEmpty (SpanExporterM a) -> SpanExporterM a
$cstimes :: forall a b.
(Semigroup a, Integral b) =>
b -> SpanExporterM a -> SpanExporterM a
stimes :: forall b. Integral b => b -> SpanExporterM a -> SpanExporterM a
Semigroup, Semigroup (SpanExporterM a)
SpanExporterM a
Semigroup (SpanExporterM a) =>
SpanExporterM a
-> (SpanExporterM a -> SpanExporterM a -> SpanExporterM a)
-> ([SpanExporterM a] -> SpanExporterM a)
-> Monoid (SpanExporterM a)
[SpanExporterM a] -> SpanExporterM a
SpanExporterM a -> SpanExporterM a -> SpanExporterM a
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall a. Monoid a => Semigroup (SpanExporterM a)
forall a. Monoid a => SpanExporterM a
forall a. Monoid a => [SpanExporterM a] -> SpanExporterM a
forall a.
Monoid a =>
SpanExporterM a -> SpanExporterM a -> SpanExporterM a
$cmempty :: forall a. Monoid a => SpanExporterM a
mempty :: SpanExporterM a
$cmappend :: forall a.
Monoid a =>
SpanExporterM a -> SpanExporterM a -> SpanExporterM a
mappend :: SpanExporterM a -> SpanExporterM a -> SpanExporterM a
$cmconcat :: forall a. Monoid a => [SpanExporterM a] -> SpanExporterM a
mconcat :: [SpanExporterM a] -> SpanExporterM a
Monoid -- @base@
      ) via (Ap (ReaderT (Resource Attrs) (LoggingT IO)) a)

runSpanExporterM
  :: Resource Attrs
  -> Logger
  -> OnTimeout a
  -> OnException a
  -> Int
  -> [SeriesElem]
  -> SpanExporterM a
  -> IO a
runSpanExporterM :: forall a.
Resource Attrs
-> Logger
-> OnTimeout a
-> OnException a
-> Int
-> [SeriesElem]
-> SpanExporterM a
-> IO a
runSpanExporterM Resource Attrs
res Logger
logger OnTimeout a
onTimeout OnException a
onEx Int
timeoutMicros [SeriesElem]
pairs SpanExporterM a
action = do
  (LoggingT IO a -> Logger -> IO a)
-> Logger -> LoggingT IO a -> IO a
forall a b c. (a -> b -> c) -> b -> a -> c
flip LoggingT IO a -> Logger -> IO a
forall (m :: * -> *) a. LoggingT m a -> Logger -> m a
runLoggingT Logger
logger do
    Maybe a
mResult <- ((forall a. LoggingT IO a -> IO a) -> IO (Maybe a))
-> LoggingT IO (Maybe a)
forall b.
((forall a. LoggingT IO a -> IO a) -> IO b) -> LoggingT IO b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO \forall a. LoggingT IO a -> IO a
runInIO -> do
      Int -> IO a -> IO (Maybe a)
forall a. Int -> IO a -> IO (Maybe a)
timeout Int
timeoutMicros (IO a -> IO (Maybe a)) -> IO a -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ LoggingT IO a -> IO a
forall a. LoggingT IO a -> IO a
runInIO do
        SpanExporterM a -> Resource Attrs -> LoggingT IO a
forall a. SpanExporterM a -> Resource Attrs -> LoggingT IO a
unSpanExporterM SpanExporterM a
action Resource Attrs
res LoggingT IO a -> (SomeException -> LoggingT IO a) -> LoggingT IO a
forall (m :: * -> *) a.
(HasCallStack, MonadCatch m) =>
m a -> (SomeException -> m a) -> m a
`catchAny` \SomeException
someEx -> do
          OnException a -> SomeException -> [SeriesElem] -> LoggingT IO a
forall a.
OnException a -> SomeException -> [SeriesElem] -> LoggingT IO a
runOnException OnException a
onEx SomeException
someEx [SeriesElem]
pairs
    case Maybe a
mResult of
      Just a
x -> a -> LoggingT IO a
forall a. a -> LoggingT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
      Maybe a
Nothing -> OnTimeout a -> Int -> [SeriesElem] -> LoggingT IO a
forall a. OnTimeout a -> Int -> [SeriesElem] -> LoggingT IO a
runOnTimeout OnTimeout a
onTimeout Int
timeoutMicros [SeriesElem]
pairs

askResource :: SpanExporterM (Resource Attrs)
askResource :: SpanExporterM (Resource Attrs)
askResource = (Resource Attrs -> LoggingT IO (Resource Attrs))
-> SpanExporterM (Resource Attrs)
forall a. (Resource Attrs -> LoggingT IO a) -> SpanExporterM a
SpanExporterM Resource Attrs -> LoggingT IO (Resource Attrs)
forall a. a -> LoggingT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

type SamplerM :: Type -> Type
newtype SamplerM a = SamplerM
  { forall a. SamplerM a -> LoggingT IO a
unSamplerM :: LoggingT IO a
  } deriving
      ( Functor SamplerM
Functor SamplerM =>
(forall a. a -> SamplerM a)
-> (forall a b. SamplerM (a -> b) -> SamplerM a -> SamplerM b)
-> (forall a b c.
    (a -> b -> c) -> SamplerM a -> SamplerM b -> SamplerM c)
-> (forall a b. SamplerM a -> SamplerM b -> SamplerM b)
-> (forall a b. SamplerM a -> SamplerM b -> SamplerM a)
-> Applicative SamplerM
forall a. a -> SamplerM a
forall a b. SamplerM a -> SamplerM b -> SamplerM a
forall a b. SamplerM a -> SamplerM b -> SamplerM b
forall a b. SamplerM (a -> b) -> SamplerM a -> SamplerM b
forall a b c.
(a -> b -> c) -> SamplerM a -> SamplerM b -> SamplerM c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> SamplerM a
pure :: forall a. a -> SamplerM a
$c<*> :: forall a b. SamplerM (a -> b) -> SamplerM a -> SamplerM b
<*> :: forall a b. SamplerM (a -> b) -> SamplerM a -> SamplerM b
$cliftA2 :: forall a b c.
(a -> b -> c) -> SamplerM a -> SamplerM b -> SamplerM c
liftA2 :: forall a b c.
(a -> b -> c) -> SamplerM a -> SamplerM b -> SamplerM c
$c*> :: forall a b. SamplerM a -> SamplerM b -> SamplerM b
*> :: forall a b. SamplerM a -> SamplerM b -> SamplerM b
$c<* :: forall a b. SamplerM a -> SamplerM b -> SamplerM a
<* :: forall a b. SamplerM a -> SamplerM b -> SamplerM a
Applicative, (forall a b. (a -> b) -> SamplerM a -> SamplerM b)
-> (forall a b. a -> SamplerM b -> SamplerM a) -> Functor SamplerM
forall a b. a -> SamplerM b -> SamplerM a
forall a b. (a -> b) -> SamplerM a -> SamplerM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> SamplerM a -> SamplerM b
fmap :: forall a b. (a -> b) -> SamplerM a -> SamplerM b
$c<$ :: forall a b. a -> SamplerM b -> SamplerM a
<$ :: forall a b. a -> SamplerM b -> SamplerM a
Functor, Applicative SamplerM
Applicative SamplerM =>
(forall a b. SamplerM a -> (a -> SamplerM b) -> SamplerM b)
-> (forall a b. SamplerM a -> SamplerM b -> SamplerM b)
-> (forall a. a -> SamplerM a)
-> Monad SamplerM
forall a. a -> SamplerM a
forall a b. SamplerM a -> SamplerM b -> SamplerM b
forall a b. SamplerM a -> (a -> SamplerM b) -> SamplerM b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. SamplerM a -> (a -> SamplerM b) -> SamplerM b
>>= :: forall a b. SamplerM a -> (a -> SamplerM b) -> SamplerM b
$c>> :: forall a b. SamplerM a -> SamplerM b -> SamplerM b
>> :: forall a b. SamplerM a -> SamplerM b -> SamplerM b
$creturn :: forall a. a -> SamplerM a
return :: forall a. a -> SamplerM a
Monad, Monad SamplerM
Monad SamplerM =>
(forall a. IO a -> SamplerM a) -> MonadIO SamplerM
forall a. IO a -> SamplerM a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall a. IO a -> SamplerM a
liftIO :: forall a. IO a -> SamplerM a
MonadIO -- @base@
      , MonadThrow SamplerM
MonadThrow SamplerM =>
(forall e a.
 (HasCallStack, Exception e) =>
 SamplerM a -> (e -> SamplerM a) -> SamplerM a)
-> MonadCatch SamplerM
forall e a.
(HasCallStack, Exception e) =>
SamplerM a -> (e -> SamplerM a) -> SamplerM a
forall (m :: * -> *).
MonadThrow m =>
(forall e a.
 (HasCallStack, Exception e) =>
 m a -> (e -> m a) -> m a)
-> MonadCatch m
$ccatch :: forall e a.
(HasCallStack, Exception e) =>
SamplerM a -> (e -> SamplerM a) -> SamplerM a
catch :: forall e a.
(HasCallStack, Exception e) =>
SamplerM a -> (e -> SamplerM a) -> SamplerM a
MonadCatch, MonadCatch SamplerM
MonadCatch SamplerM =>
(forall b.
 HasCallStack =>
 ((forall a. SamplerM a -> SamplerM a) -> SamplerM b) -> SamplerM b)
-> (forall b.
    HasCallStack =>
    ((forall a. SamplerM a -> SamplerM a) -> SamplerM b) -> SamplerM b)
-> (forall a b c.
    HasCallStack =>
    SamplerM a
    -> (a -> ExitCase b -> SamplerM c)
    -> (a -> SamplerM b)
    -> SamplerM (b, c))
-> MonadMask SamplerM
forall b.
HasCallStack =>
((forall a. SamplerM a -> SamplerM a) -> SamplerM b) -> SamplerM b
forall a b c.
HasCallStack =>
SamplerM a
-> (a -> ExitCase b -> SamplerM c)
-> (a -> SamplerM b)
-> SamplerM (b, c)
forall (m :: * -> *).
MonadCatch m =>
(forall b. HasCallStack => ((forall a. m a -> m a) -> m b) -> m b)
-> (forall b.
    HasCallStack =>
    ((forall a. m a -> m a) -> m b) -> m b)
-> (forall a b c.
    HasCallStack =>
    m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c))
-> MonadMask m
$cmask :: forall b.
HasCallStack =>
((forall a. SamplerM a -> SamplerM a) -> SamplerM b) -> SamplerM b
mask :: forall b.
HasCallStack =>
((forall a. SamplerM a -> SamplerM a) -> SamplerM b) -> SamplerM b
$cuninterruptibleMask :: forall b.
HasCallStack =>
((forall a. SamplerM a -> SamplerM a) -> SamplerM b) -> SamplerM b
uninterruptibleMask :: forall b.
HasCallStack =>
((forall a. SamplerM a -> SamplerM a) -> SamplerM b) -> SamplerM b
$cgeneralBracket :: forall a b c.
HasCallStack =>
SamplerM a
-> (a -> ExitCase b -> SamplerM c)
-> (a -> SamplerM b)
-> SamplerM (b, c)
generalBracket :: forall a b c.
HasCallStack =>
SamplerM a
-> (a -> ExitCase b -> SamplerM c)
-> (a -> SamplerM b)
-> SamplerM (b, c)
MonadMask, Monad SamplerM
Monad SamplerM =>
(forall e a. (HasCallStack, Exception e) => e -> SamplerM a)
-> MonadThrow SamplerM
forall e a. (HasCallStack, Exception e) => e -> SamplerM a
forall (m :: * -> *).
Monad m =>
(forall e a. (HasCallStack, Exception e) => e -> m a)
-> MonadThrow m
$cthrowM :: forall e a. (HasCallStack, Exception e) => e -> SamplerM a
throwM :: forall e a. (HasCallStack, Exception e) => e -> SamplerM a
MonadThrow -- @exceptions@
      , MonadIO SamplerM
MonadIO SamplerM =>
(forall b. ((forall a. SamplerM a -> IO a) -> IO b) -> SamplerM b)
-> MonadUnliftIO SamplerM
forall b. ((forall a. SamplerM a -> IO a) -> IO b) -> SamplerM b
forall (m :: * -> *).
MonadIO m =>
(forall b. ((forall a. m a -> IO a) -> IO b) -> m b)
-> MonadUnliftIO m
$cwithRunInIO :: forall b. ((forall a. SamplerM a -> IO a) -> IO b) -> SamplerM b
withRunInIO :: forall b. ((forall a. SamplerM a -> IO a) -> IO b) -> SamplerM b
MonadUnliftIO -- @unliftio-core@
      , Monad SamplerM
Monad SamplerM =>
(forall msg.
 ToLogStr msg =>
 Loc -> Text -> LogLevel -> msg -> SamplerM ())
-> MonadLogger SamplerM
forall msg.
ToLogStr msg =>
Loc -> Text -> LogLevel -> msg -> SamplerM ()
forall (m :: * -> *).
Monad m =>
(forall msg.
 ToLogStr msg =>
 Loc -> Text -> LogLevel -> msg -> m ())
-> MonadLogger m
$cmonadLoggerLog :: forall msg.
ToLogStr msg =>
Loc -> Text -> LogLevel -> msg -> SamplerM ()
monadLoggerLog :: forall msg.
ToLogStr msg =>
Loc -> Text -> LogLevel -> msg -> SamplerM ()
MonadLogger, MonadIO SamplerM
MonadLogger SamplerM
SamplerM Logger
(MonadLogger SamplerM, MonadIO SamplerM) =>
SamplerM Logger -> MonadLoggerIO SamplerM
forall (m :: * -> *).
(MonadLogger m, MonadIO m) =>
m Logger -> MonadLoggerIO m
$caskLoggerIO :: SamplerM Logger
askLoggerIO :: SamplerM Logger
MonadLoggerIO -- @monad-logger@
      ) via (LoggingT IO)
    deriving
      ( NonEmpty (SamplerM a) -> SamplerM a
SamplerM a -> SamplerM a -> SamplerM a
(SamplerM a -> SamplerM a -> SamplerM a)
-> (NonEmpty (SamplerM a) -> SamplerM a)
-> (forall b. Integral b => b -> SamplerM a -> SamplerM a)
-> Semigroup (SamplerM a)
forall b. Integral b => b -> SamplerM a -> SamplerM a
forall a. Semigroup a => NonEmpty (SamplerM a) -> SamplerM a
forall a. Semigroup a => SamplerM a -> SamplerM a -> SamplerM a
forall a b.
(Semigroup a, Integral b) =>
b -> SamplerM a -> SamplerM a
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: forall a. Semigroup a => SamplerM a -> SamplerM a -> SamplerM a
<> :: SamplerM a -> SamplerM a -> SamplerM a
$csconcat :: forall a. Semigroup a => NonEmpty (SamplerM a) -> SamplerM a
sconcat :: NonEmpty (SamplerM a) -> SamplerM a
$cstimes :: forall a b.
(Semigroup a, Integral b) =>
b -> SamplerM a -> SamplerM a
stimes :: forall b. Integral b => b -> SamplerM a -> SamplerM a
Semigroup, Semigroup (SamplerM a)
SamplerM a
Semigroup (SamplerM a) =>
SamplerM a
-> (SamplerM a -> SamplerM a -> SamplerM a)
-> ([SamplerM a] -> SamplerM a)
-> Monoid (SamplerM a)
[SamplerM a] -> SamplerM a
SamplerM a -> SamplerM a -> SamplerM a
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall a. Monoid a => Semigroup (SamplerM a)
forall a. Monoid a => SamplerM a
forall a. Monoid a => [SamplerM a] -> SamplerM a
forall a. Monoid a => SamplerM a -> SamplerM a -> SamplerM a
$cmempty :: forall a. Monoid a => SamplerM a
mempty :: SamplerM a
$cmappend :: forall a. Monoid a => SamplerM a -> SamplerM a -> SamplerM a
mappend :: SamplerM a -> SamplerM a -> SamplerM a
$cmconcat :: forall a. Monoid a => [SamplerM a] -> SamplerM a
mconcat :: [SamplerM a] -> SamplerM a
Monoid -- @base@
      ) via (Ap (LoggingT IO) a)

runSamplerM
  :: Logger
  -> OnException a
  -> [SeriesElem]
  -> SamplerM a
  -> IO a
runSamplerM :: forall a.
Logger -> OnException a -> [SeriesElem] -> SamplerM a -> IO a
runSamplerM Logger
logger OnException a
onEx [SeriesElem]
pairs SamplerM a
action = do
  (LoggingT IO a -> Logger -> IO a)
-> Logger -> LoggingT IO a -> IO a
forall a b c. (a -> b -> c) -> b -> a -> c
flip LoggingT IO a -> Logger -> IO a
forall (m :: * -> *) a. LoggingT m a -> Logger -> m a
runLoggingT Logger
logger do
    SamplerM a -> LoggingT IO a
forall a. SamplerM a -> LoggingT IO a
unSamplerM SamplerM a
action LoggingT IO a -> (SomeException -> LoggingT IO a) -> LoggingT IO a
forall (m :: * -> *) a.
(HasCallStack, MonadCatch m) =>
m a -> (SomeException -> m a) -> m a
`catchAny` \SomeException
someEx -> do
      OnException a -> SomeException -> [SeriesElem] -> LoggingT IO a
forall a.
OnException a -> SomeException -> [SeriesElem] -> LoggingT IO a
runOnException OnException a
onEx SomeException
someEx [SeriesElem]
pairs

type IdGeneratorM :: Type -> Type
newtype IdGeneratorM a = IdGeneratorM
  { forall a. IdGeneratorM a -> PRNG -> LoggingT IO a
unIdGeneratorM :: PRNG -> LoggingT IO a
  } deriving
      ( Functor IdGeneratorM
Functor IdGeneratorM =>
(forall a. a -> IdGeneratorM a)
-> (forall a b.
    IdGeneratorM (a -> b) -> IdGeneratorM a -> IdGeneratorM b)
-> (forall a b c.
    (a -> b -> c)
    -> IdGeneratorM a -> IdGeneratorM b -> IdGeneratorM c)
-> (forall a b. IdGeneratorM a -> IdGeneratorM b -> IdGeneratorM b)
-> (forall a b. IdGeneratorM a -> IdGeneratorM b -> IdGeneratorM a)
-> Applicative IdGeneratorM
forall a. a -> IdGeneratorM a
forall a b. IdGeneratorM a -> IdGeneratorM b -> IdGeneratorM a
forall a b. IdGeneratorM a -> IdGeneratorM b -> IdGeneratorM b
forall a b.
IdGeneratorM (a -> b) -> IdGeneratorM a -> IdGeneratorM b
forall a b c.
(a -> b -> c) -> IdGeneratorM a -> IdGeneratorM b -> IdGeneratorM c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> IdGeneratorM a
pure :: forall a. a -> IdGeneratorM a
$c<*> :: forall a b.
IdGeneratorM (a -> b) -> IdGeneratorM a -> IdGeneratorM b
<*> :: forall a b.
IdGeneratorM (a -> b) -> IdGeneratorM a -> IdGeneratorM b
$cliftA2 :: forall a b c.
(a -> b -> c) -> IdGeneratorM a -> IdGeneratorM b -> IdGeneratorM c
liftA2 :: forall a b c.
(a -> b -> c) -> IdGeneratorM a -> IdGeneratorM b -> IdGeneratorM c
$c*> :: forall a b. IdGeneratorM a -> IdGeneratorM b -> IdGeneratorM b
*> :: forall a b. IdGeneratorM a -> IdGeneratorM b -> IdGeneratorM b
$c<* :: forall a b. IdGeneratorM a -> IdGeneratorM b -> IdGeneratorM a
<* :: forall a b. IdGeneratorM a -> IdGeneratorM b -> IdGeneratorM a
Applicative, (forall a b. (a -> b) -> IdGeneratorM a -> IdGeneratorM b)
-> (forall a b. a -> IdGeneratorM b -> IdGeneratorM a)
-> Functor IdGeneratorM
forall a b. a -> IdGeneratorM b -> IdGeneratorM a
forall a b. (a -> b) -> IdGeneratorM a -> IdGeneratorM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> IdGeneratorM a -> IdGeneratorM b
fmap :: forall a b. (a -> b) -> IdGeneratorM a -> IdGeneratorM b
$c<$ :: forall a b. a -> IdGeneratorM b -> IdGeneratorM a
<$ :: forall a b. a -> IdGeneratorM b -> IdGeneratorM a
Functor, Applicative IdGeneratorM
Applicative IdGeneratorM =>
(forall a b.
 IdGeneratorM a -> (a -> IdGeneratorM b) -> IdGeneratorM b)
-> (forall a b. IdGeneratorM a -> IdGeneratorM b -> IdGeneratorM b)
-> (forall a. a -> IdGeneratorM a)
-> Monad IdGeneratorM
forall a. a -> IdGeneratorM a
forall a b. IdGeneratorM a -> IdGeneratorM b -> IdGeneratorM b
forall a b.
IdGeneratorM a -> (a -> IdGeneratorM b) -> IdGeneratorM b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b.
IdGeneratorM a -> (a -> IdGeneratorM b) -> IdGeneratorM b
>>= :: forall a b.
IdGeneratorM a -> (a -> IdGeneratorM b) -> IdGeneratorM b
$c>> :: forall a b. IdGeneratorM a -> IdGeneratorM b -> IdGeneratorM b
>> :: forall a b. IdGeneratorM a -> IdGeneratorM b -> IdGeneratorM b
$creturn :: forall a. a -> IdGeneratorM a
return :: forall a. a -> IdGeneratorM a
Monad, Monad IdGeneratorM
Monad IdGeneratorM =>
(forall a. IO a -> IdGeneratorM a) -> MonadIO IdGeneratorM
forall a. IO a -> IdGeneratorM a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall a. IO a -> IdGeneratorM a
liftIO :: forall a. IO a -> IdGeneratorM a
MonadIO -- @base@
      , MonadThrow IdGeneratorM
MonadThrow IdGeneratorM =>
(forall e a.
 (HasCallStack, Exception e) =>
 IdGeneratorM a -> (e -> IdGeneratorM a) -> IdGeneratorM a)
-> MonadCatch IdGeneratorM
forall e a.
(HasCallStack, Exception e) =>
IdGeneratorM a -> (e -> IdGeneratorM a) -> IdGeneratorM a
forall (m :: * -> *).
MonadThrow m =>
(forall e a.
 (HasCallStack, Exception e) =>
 m a -> (e -> m a) -> m a)
-> MonadCatch m
$ccatch :: forall e a.
(HasCallStack, Exception e) =>
IdGeneratorM a -> (e -> IdGeneratorM a) -> IdGeneratorM a
catch :: forall e a.
(HasCallStack, Exception e) =>
IdGeneratorM a -> (e -> IdGeneratorM a) -> IdGeneratorM a
MonadCatch, MonadCatch IdGeneratorM
MonadCatch IdGeneratorM =>
(forall b.
 HasCallStack =>
 ((forall a. IdGeneratorM a -> IdGeneratorM a) -> IdGeneratorM b)
 -> IdGeneratorM b)
-> (forall b.
    HasCallStack =>
    ((forall a. IdGeneratorM a -> IdGeneratorM a) -> IdGeneratorM b)
    -> IdGeneratorM b)
-> (forall a b c.
    HasCallStack =>
    IdGeneratorM a
    -> (a -> ExitCase b -> IdGeneratorM c)
    -> (a -> IdGeneratorM b)
    -> IdGeneratorM (b, c))
-> MonadMask IdGeneratorM
forall b.
HasCallStack =>
((forall a. IdGeneratorM a -> IdGeneratorM a) -> IdGeneratorM b)
-> IdGeneratorM b
forall a b c.
HasCallStack =>
IdGeneratorM a
-> (a -> ExitCase b -> IdGeneratorM c)
-> (a -> IdGeneratorM b)
-> IdGeneratorM (b, c)
forall (m :: * -> *).
MonadCatch m =>
(forall b. HasCallStack => ((forall a. m a -> m a) -> m b) -> m b)
-> (forall b.
    HasCallStack =>
    ((forall a. m a -> m a) -> m b) -> m b)
-> (forall a b c.
    HasCallStack =>
    m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c))
-> MonadMask m
$cmask :: forall b.
HasCallStack =>
((forall a. IdGeneratorM a -> IdGeneratorM a) -> IdGeneratorM b)
-> IdGeneratorM b
mask :: forall b.
HasCallStack =>
((forall a. IdGeneratorM a -> IdGeneratorM a) -> IdGeneratorM b)
-> IdGeneratorM b
$cuninterruptibleMask :: forall b.
HasCallStack =>
((forall a. IdGeneratorM a -> IdGeneratorM a) -> IdGeneratorM b)
-> IdGeneratorM b
uninterruptibleMask :: forall b.
HasCallStack =>
((forall a. IdGeneratorM a -> IdGeneratorM a) -> IdGeneratorM b)
-> IdGeneratorM b
$cgeneralBracket :: forall a b c.
HasCallStack =>
IdGeneratorM a
-> (a -> ExitCase b -> IdGeneratorM c)
-> (a -> IdGeneratorM b)
-> IdGeneratorM (b, c)
generalBracket :: forall a b c.
HasCallStack =>
IdGeneratorM a
-> (a -> ExitCase b -> IdGeneratorM c)
-> (a -> IdGeneratorM b)
-> IdGeneratorM (b, c)
MonadMask, Monad IdGeneratorM
Monad IdGeneratorM =>
(forall e a. (HasCallStack, Exception e) => e -> IdGeneratorM a)
-> MonadThrow IdGeneratorM
forall e a. (HasCallStack, Exception e) => e -> IdGeneratorM a
forall (m :: * -> *).
Monad m =>
(forall e a. (HasCallStack, Exception e) => e -> m a)
-> MonadThrow m
$cthrowM :: forall e a. (HasCallStack, Exception e) => e -> IdGeneratorM a
throwM :: forall e a. (HasCallStack, Exception e) => e -> IdGeneratorM a
MonadThrow -- @exceptions@
      , MonadIO IdGeneratorM
MonadIO IdGeneratorM =>
(forall b.
 ((forall a. IdGeneratorM a -> IO a) -> IO b) -> IdGeneratorM b)
-> MonadUnliftIO IdGeneratorM
forall b.
((forall a. IdGeneratorM a -> IO a) -> IO b) -> IdGeneratorM b
forall (m :: * -> *).
MonadIO m =>
(forall b. ((forall a. m a -> IO a) -> IO b) -> m b)
-> MonadUnliftIO m
$cwithRunInIO :: forall b.
((forall a. IdGeneratorM a -> IO a) -> IO b) -> IdGeneratorM b
withRunInIO :: forall b.
((forall a. IdGeneratorM a -> IO a) -> IO b) -> IdGeneratorM b
MonadUnliftIO -- @unliftio-core@
      , Monad IdGeneratorM
Monad IdGeneratorM =>
(forall msg.
 ToLogStr msg =>
 Loc -> Text -> LogLevel -> msg -> IdGeneratorM ())
-> MonadLogger IdGeneratorM
forall msg.
ToLogStr msg =>
Loc -> Text -> LogLevel -> msg -> IdGeneratorM ()
forall (m :: * -> *).
Monad m =>
(forall msg.
 ToLogStr msg =>
 Loc -> Text -> LogLevel -> msg -> m ())
-> MonadLogger m
$cmonadLoggerLog :: forall msg.
ToLogStr msg =>
Loc -> Text -> LogLevel -> msg -> IdGeneratorM ()
monadLoggerLog :: forall msg.
ToLogStr msg =>
Loc -> Text -> LogLevel -> msg -> IdGeneratorM ()
MonadLogger, MonadIO IdGeneratorM
MonadLogger IdGeneratorM
IdGeneratorM Logger
(MonadLogger IdGeneratorM, MonadIO IdGeneratorM) =>
IdGeneratorM Logger -> MonadLoggerIO IdGeneratorM
forall (m :: * -> *).
(MonadLogger m, MonadIO m) =>
m Logger -> MonadLoggerIO m
$caskLoggerIO :: IdGeneratorM Logger
askLoggerIO :: IdGeneratorM Logger
MonadLoggerIO -- @monad-logger@
      ) via (ReaderT PRNG (LoggingT IO))
    deriving
      ( NonEmpty (IdGeneratorM a) -> IdGeneratorM a
IdGeneratorM a -> IdGeneratorM a -> IdGeneratorM a
(IdGeneratorM a -> IdGeneratorM a -> IdGeneratorM a)
-> (NonEmpty (IdGeneratorM a) -> IdGeneratorM a)
-> (forall b. Integral b => b -> IdGeneratorM a -> IdGeneratorM a)
-> Semigroup (IdGeneratorM a)
forall b. Integral b => b -> IdGeneratorM a -> IdGeneratorM a
forall a.
Semigroup a =>
NonEmpty (IdGeneratorM a) -> IdGeneratorM a
forall a.
Semigroup a =>
IdGeneratorM a -> IdGeneratorM a -> IdGeneratorM a
forall a b.
(Semigroup a, Integral b) =>
b -> IdGeneratorM a -> IdGeneratorM a
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: forall a.
Semigroup a =>
IdGeneratorM a -> IdGeneratorM a -> IdGeneratorM a
<> :: IdGeneratorM a -> IdGeneratorM a -> IdGeneratorM a
$csconcat :: forall a.
Semigroup a =>
NonEmpty (IdGeneratorM a) -> IdGeneratorM a
sconcat :: NonEmpty (IdGeneratorM a) -> IdGeneratorM a
$cstimes :: forall a b.
(Semigroup a, Integral b) =>
b -> IdGeneratorM a -> IdGeneratorM a
stimes :: forall b. Integral b => b -> IdGeneratorM a -> IdGeneratorM a
Semigroup, Semigroup (IdGeneratorM a)
IdGeneratorM a
Semigroup (IdGeneratorM a) =>
IdGeneratorM a
-> (IdGeneratorM a -> IdGeneratorM a -> IdGeneratorM a)
-> ([IdGeneratorM a] -> IdGeneratorM a)
-> Monoid (IdGeneratorM a)
[IdGeneratorM a] -> IdGeneratorM a
IdGeneratorM a -> IdGeneratorM a -> IdGeneratorM a
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall a. Monoid a => Semigroup (IdGeneratorM a)
forall a. Monoid a => IdGeneratorM a
forall a. Monoid a => [IdGeneratorM a] -> IdGeneratorM a
forall a.
Monoid a =>
IdGeneratorM a -> IdGeneratorM a -> IdGeneratorM a
$cmempty :: forall a. Monoid a => IdGeneratorM a
mempty :: IdGeneratorM a
$cmappend :: forall a.
Monoid a =>
IdGeneratorM a -> IdGeneratorM a -> IdGeneratorM a
mappend :: IdGeneratorM a -> IdGeneratorM a -> IdGeneratorM a
$cmconcat :: forall a. Monoid a => [IdGeneratorM a] -> IdGeneratorM a
mconcat :: [IdGeneratorM a] -> IdGeneratorM a
Monoid -- @base@
      ) via (Ap (ReaderT PRNG (LoggingT IO)) a)

runIdGeneratorM
  :: PRNG
  -> Logger
  -> IdGeneratorM a
  -> IO a
runIdGeneratorM :: forall a. PRNG -> Logger -> IdGeneratorM a -> IO a
runIdGeneratorM PRNG
prng Logger
logger IdGeneratorM a
action = do
  (LoggingT IO a -> Logger -> IO a)
-> Logger -> LoggingT IO a -> IO a
forall a b c. (a -> b -> c) -> b -> a -> c
flip LoggingT IO a -> Logger -> IO a
forall (m :: * -> *) a. LoggingT m a -> Logger -> m a
runLoggingT Logger
logger do
    IdGeneratorM a -> PRNG -> LoggingT IO a
forall a. IdGeneratorM a -> PRNG -> LoggingT IO a
unIdGeneratorM IdGeneratorM a
action PRNG
prng

data IdGenerator = IdGenerator
  { IdGenerator -> PRNG -> IO TraceId
idGeneratorGenTraceId :: PRNG -> IO TraceId
  , IdGenerator -> PRNG -> IO SpanId
idGeneratorGenSpanId :: PRNG -> IO SpanId
  }

buildIdGenerator
  :: forall m
   . (MonadIO m)
  => Logger
  -> IdGeneratorSpec
  -> m IdGenerator
buildIdGenerator :: forall (m :: * -> *).
MonadIO m =>
Logger -> IdGeneratorSpec -> m IdGenerator
buildIdGenerator Logger
logger IdGeneratorSpec
idGeneratorSpec = do
  (LoggingT m () -> Logger -> m ())
-> Logger -> LoggingT m () -> m ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip LoggingT m () -> Logger -> m ()
forall (m :: * -> *) a. LoggingT m a -> Logger -> m a
runLoggingT Logger
logger do
    Message -> LoggingT m ()
forall (m :: * -> *).
(HasCallStack, MonadLogger m) =>
Message -> m ()
logDebug (Message -> LoggingT m ()) -> Message -> LoggingT m ()
forall a b. (a -> b) -> a -> b
$ Text
"Building ID generator" Text -> [SeriesElem] -> Message
:#
      [ Key
"name" Key -> Text -> SeriesElem
forall v. ToJSON v => Key -> v -> SeriesElem
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
name
      ]
  IdGenerator -> m IdGenerator
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure IdGenerator
    { idGeneratorGenTraceId :: PRNG -> IO TraceId
idGeneratorGenTraceId = \PRNG
prng -> do
        PRNG -> Logger -> IdGeneratorM TraceId -> IO TraceId
forall a. PRNG -> Logger -> IdGeneratorM a -> IO a
runIdGeneratorM PRNG
prng Logger
logger IdGeneratorM TraceId
genTraceId
    , idGeneratorGenSpanId :: PRNG -> IO SpanId
idGeneratorGenSpanId = \PRNG
prng -> do
        PRNG -> Logger -> IdGeneratorM SpanId -> IO SpanId
forall a. PRNG -> Logger -> IdGeneratorM a -> IO a
runIdGeneratorM PRNG
prng Logger
logger IdGeneratorM SpanId
genSpanId
    }
  where
  IdGeneratorSpec
    { idGeneratorSpecName :: IdGeneratorSpec -> Text
idGeneratorSpecName = Text
name
    , idGeneratorSpecGenTraceId :: IdGeneratorSpec -> IdGeneratorM TraceId
idGeneratorSpecGenTraceId = IdGeneratorM TraceId
genTraceId
    , idGeneratorSpecGenSpanId :: IdGeneratorSpec -> IdGeneratorM SpanId
idGeneratorSpecGenSpanId = IdGeneratorM SpanId
genSpanId
    } = IdGeneratorSpec
idGeneratorSpec

data IdGeneratorSpec = IdGeneratorSpec
  { IdGeneratorSpec -> Text
idGeneratorSpecName :: Text
  , IdGeneratorSpec -> IdGeneratorM TraceId
idGeneratorSpecGenTraceId :: IdGeneratorM TraceId
  , IdGeneratorSpec -> IdGeneratorM SpanId
idGeneratorSpecGenSpanId :: IdGeneratorM SpanId
  }

defaultIdGeneratorSpec :: IdGeneratorSpec
defaultIdGeneratorSpec :: IdGeneratorSpec
defaultIdGeneratorSpec =
  IdGeneratorSpec
    { idGeneratorSpecName :: Text
idGeneratorSpecName = Text
"default"
    , idGeneratorSpecGenTraceId :: IdGeneratorM TraceId
idGeneratorSpecGenTraceId = (Word64 -> Word64 -> TraceId)
-> IdGeneratorM Word64
-> IdGeneratorM Word64
-> IdGeneratorM TraceId
forall a b c.
(a -> b -> c) -> IdGeneratorM a -> IdGeneratorM b -> IdGeneratorM c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Word64 -> Word64 -> TraceId
traceIdFromWords IdGeneratorM Word64
forall a. Variate a => IdGeneratorM a
genUniform IdGeneratorM Word64
forall a. Variate a => IdGeneratorM a
genUniform
    , idGeneratorSpecGenSpanId :: IdGeneratorM SpanId
idGeneratorSpecGenSpanId = (Word64 -> SpanId) -> IdGeneratorM Word64 -> IdGeneratorM SpanId
forall a b. (a -> b) -> IdGeneratorM a -> IdGeneratorM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Word64 -> SpanId
spanIdFromWords IdGeneratorM Word64
forall a. Variate a => IdGeneratorM a
genUniform
    }

newtype PRNG = PRNG
  { PRNG -> GenIO
unPRNG :: GenIO
  }

genUniform :: forall a. (Variate a) => IdGeneratorM a
genUniform :: forall a. Variate a => IdGeneratorM a
genUniform =
  (PRNG -> LoggingT IO a) -> IdGeneratorM a
forall a. (PRNG -> LoggingT IO a) -> IdGeneratorM a
IdGeneratorM \PRNG { unPRNG :: PRNG -> GenIO
unPRNG = GenIO
gen } -> IO a -> LoggingT IO a
forall a. IO a -> LoggingT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> LoggingT IO a) -> IO a -> LoggingT IO a
forall a b. (a -> b) -> a -> b
$ GenIO -> IO a
forall a (m :: * -> *).
(Variate a, PrimMonad m) =>
Gen (PrimState m) -> m a
forall (m :: * -> *). PrimMonad m => Gen (PrimState m) -> m a
uniform GenIO
gen

newPRNGRef :: Seed -> IO (MVar PRNG)
newPRNGRef :: Seed -> IO (MVar PRNG)
newPRNGRef Seed
seed = do
  PRNG
prng <- (Gen RealWorld -> PRNG) -> IO (Gen RealWorld) -> IO PRNG
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Gen RealWorld -> PRNG
GenIO -> PRNG
PRNG (IO (Gen RealWorld) -> IO PRNG) -> IO (Gen RealWorld) -> IO PRNG
forall a b. (a -> b) -> a -> b
$ Vector Word32 -> IO GenIO
forall (m :: * -> *) (v :: * -> *).
(PrimMonad m, Vector v Word32) =>
v Word32 -> m (Gen (PrimState m))
initialize (Vector Word32 -> IO GenIO) -> Vector Word32 -> IO GenIO
forall a b. (a -> b) -> a -> b
$ Seed -> Vector Word32
fromSeed Seed
seed
  PRNG -> IO (MVar PRNG)
forall a. a -> IO (MVar a)
newMVar PRNG
prng

newtype OnSpansExported a = OnSpansExported
  { forall a.
OnSpansExported a
-> Batch (Span Attrs)
-> SpanExportResult
-> [SeriesElem]
-> LoggingT IO a
runOnSpansExported :: Batch (Span Attrs) -> SpanExportResult -> [SeriesElem] -> LoggingT IO a
  } deriving
      ( Functor OnSpansExported
Functor OnSpansExported =>
(forall a. a -> OnSpansExported a)
-> (forall a b.
    OnSpansExported (a -> b) -> OnSpansExported a -> OnSpansExported b)
-> (forall a b c.
    (a -> b -> c)
    -> OnSpansExported a -> OnSpansExported b -> OnSpansExported c)
-> (forall a b.
    OnSpansExported a -> OnSpansExported b -> OnSpansExported b)
-> (forall a b.
    OnSpansExported a -> OnSpansExported b -> OnSpansExported a)
-> Applicative OnSpansExported
forall a. a -> OnSpansExported a
forall a b.
OnSpansExported a -> OnSpansExported b -> OnSpansExported a
forall a b.
OnSpansExported a -> OnSpansExported b -> OnSpansExported b
forall a b.
OnSpansExported (a -> b) -> OnSpansExported a -> OnSpansExported b
forall a b c.
(a -> b -> c)
-> OnSpansExported a -> OnSpansExported b -> OnSpansExported c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> OnSpansExported a
pure :: forall a. a -> OnSpansExported a
$c<*> :: forall a b.
OnSpansExported (a -> b) -> OnSpansExported a -> OnSpansExported b
<*> :: forall a b.
OnSpansExported (a -> b) -> OnSpansExported a -> OnSpansExported b
$cliftA2 :: forall a b c.
(a -> b -> c)
-> OnSpansExported a -> OnSpansExported b -> OnSpansExported c
liftA2 :: forall a b c.
(a -> b -> c)
-> OnSpansExported a -> OnSpansExported b -> OnSpansExported c
$c*> :: forall a b.
OnSpansExported a -> OnSpansExported b -> OnSpansExported b
*> :: forall a b.
OnSpansExported a -> OnSpansExported b -> OnSpansExported b
$c<* :: forall a b.
OnSpansExported a -> OnSpansExported b -> OnSpansExported a
<* :: forall a b.
OnSpansExported a -> OnSpansExported b -> OnSpansExported a
Applicative, (forall a b. (a -> b) -> OnSpansExported a -> OnSpansExported b)
-> (forall a b. a -> OnSpansExported b -> OnSpansExported a)
-> Functor OnSpansExported
forall a b. a -> OnSpansExported b -> OnSpansExported a
forall a b. (a -> b) -> OnSpansExported a -> OnSpansExported b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> OnSpansExported a -> OnSpansExported b
fmap :: forall a b. (a -> b) -> OnSpansExported a -> OnSpansExported b
$c<$ :: forall a b. a -> OnSpansExported b -> OnSpansExported a
<$ :: forall a b. a -> OnSpansExported b -> OnSpansExported a
Functor, Applicative OnSpansExported
Applicative OnSpansExported =>
(forall a b.
 OnSpansExported a -> (a -> OnSpansExported b) -> OnSpansExported b)
-> (forall a b.
    OnSpansExported a -> OnSpansExported b -> OnSpansExported b)
-> (forall a. a -> OnSpansExported a)
-> Monad OnSpansExported
forall a. a -> OnSpansExported a
forall a b.
OnSpansExported a -> OnSpansExported b -> OnSpansExported b
forall a b.
OnSpansExported a -> (a -> OnSpansExported b) -> OnSpansExported b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b.
OnSpansExported a -> (a -> OnSpansExported b) -> OnSpansExported b
>>= :: forall a b.
OnSpansExported a -> (a -> OnSpansExported b) -> OnSpansExported b
$c>> :: forall a b.
OnSpansExported a -> OnSpansExported b -> OnSpansExported b
>> :: forall a b.
OnSpansExported a -> OnSpansExported b -> OnSpansExported b
$creturn :: forall a. a -> OnSpansExported a
return :: forall a. a -> OnSpansExported a
Monad, Monad OnSpansExported
Monad OnSpansExported =>
(forall a. IO a -> OnSpansExported a) -> MonadIO OnSpansExported
forall a. IO a -> OnSpansExported a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall a. IO a -> OnSpansExported a
liftIO :: forall a. IO a -> OnSpansExported a
MonadIO -- @base@
      , MonadThrow OnSpansExported
MonadThrow OnSpansExported =>
(forall e a.
 (HasCallStack, Exception e) =>
 OnSpansExported a -> (e -> OnSpansExported a) -> OnSpansExported a)
-> MonadCatch OnSpansExported
forall e a.
(HasCallStack, Exception e) =>
OnSpansExported a -> (e -> OnSpansExported a) -> OnSpansExported a
forall (m :: * -> *).
MonadThrow m =>
(forall e a.
 (HasCallStack, Exception e) =>
 m a -> (e -> m a) -> m a)
-> MonadCatch m
$ccatch :: forall e a.
(HasCallStack, Exception e) =>
OnSpansExported a -> (e -> OnSpansExported a) -> OnSpansExported a
catch :: forall e a.
(HasCallStack, Exception e) =>
OnSpansExported a -> (e -> OnSpansExported a) -> OnSpansExported a
MonadCatch, MonadCatch OnSpansExported
MonadCatch OnSpansExported =>
(forall b.
 HasCallStack =>
 ((forall a. OnSpansExported a -> OnSpansExported a)
  -> OnSpansExported b)
 -> OnSpansExported b)
-> (forall b.
    HasCallStack =>
    ((forall a. OnSpansExported a -> OnSpansExported a)
     -> OnSpansExported b)
    -> OnSpansExported b)
-> (forall a b c.
    HasCallStack =>
    OnSpansExported a
    -> (a -> ExitCase b -> OnSpansExported c)
    -> (a -> OnSpansExported b)
    -> OnSpansExported (b, c))
-> MonadMask OnSpansExported
forall b.
HasCallStack =>
((forall a. OnSpansExported a -> OnSpansExported a)
 -> OnSpansExported b)
-> OnSpansExported b
forall a b c.
HasCallStack =>
OnSpansExported a
-> (a -> ExitCase b -> OnSpansExported c)
-> (a -> OnSpansExported b)
-> OnSpansExported (b, c)
forall (m :: * -> *).
MonadCatch m =>
(forall b. HasCallStack => ((forall a. m a -> m a) -> m b) -> m b)
-> (forall b.
    HasCallStack =>
    ((forall a. m a -> m a) -> m b) -> m b)
-> (forall a b c.
    HasCallStack =>
    m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c))
-> MonadMask m
$cmask :: forall b.
HasCallStack =>
((forall a. OnSpansExported a -> OnSpansExported a)
 -> OnSpansExported b)
-> OnSpansExported b
mask :: forall b.
HasCallStack =>
((forall a. OnSpansExported a -> OnSpansExported a)
 -> OnSpansExported b)
-> OnSpansExported b
$cuninterruptibleMask :: forall b.
HasCallStack =>
((forall a. OnSpansExported a -> OnSpansExported a)
 -> OnSpansExported b)
-> OnSpansExported b
uninterruptibleMask :: forall b.
HasCallStack =>
((forall a. OnSpansExported a -> OnSpansExported a)
 -> OnSpansExported b)
-> OnSpansExported b
$cgeneralBracket :: forall a b c.
HasCallStack =>
OnSpansExported a
-> (a -> ExitCase b -> OnSpansExported c)
-> (a -> OnSpansExported b)
-> OnSpansExported (b, c)
generalBracket :: forall a b c.
HasCallStack =>
OnSpansExported a
-> (a -> ExitCase b -> OnSpansExported c)
-> (a -> OnSpansExported b)
-> OnSpansExported (b, c)
MonadMask, Monad OnSpansExported
Monad OnSpansExported =>
(forall e a. (HasCallStack, Exception e) => e -> OnSpansExported a)
-> MonadThrow OnSpansExported
forall e a. (HasCallStack, Exception e) => e -> OnSpansExported a
forall (m :: * -> *).
Monad m =>
(forall e a. (HasCallStack, Exception e) => e -> m a)
-> MonadThrow m
$cthrowM :: forall e a. (HasCallStack, Exception e) => e -> OnSpansExported a
throwM :: forall e a. (HasCallStack, Exception e) => e -> OnSpansExported a
MonadThrow -- @exceptions@
      , MonadIO OnSpansExported
MonadIO OnSpansExported =>
(forall b.
 ((forall a. OnSpansExported a -> IO a) -> IO b)
 -> OnSpansExported b)
-> MonadUnliftIO OnSpansExported
forall b.
((forall a. OnSpansExported a -> IO a) -> IO b)
-> OnSpansExported b
forall (m :: * -> *).
MonadIO m =>
(forall b. ((forall a. m a -> IO a) -> IO b) -> m b)
-> MonadUnliftIO m
$cwithRunInIO :: forall b.
((forall a. OnSpansExported a -> IO a) -> IO b)
-> OnSpansExported b
withRunInIO :: forall b.
((forall a. OnSpansExported a -> IO a) -> IO b)
-> OnSpansExported b
MonadUnliftIO -- @unliftio-core@
      , Monad OnSpansExported
Monad OnSpansExported =>
(forall msg.
 ToLogStr msg =>
 Loc -> Text -> LogLevel -> msg -> OnSpansExported ())
-> MonadLogger OnSpansExported
forall msg.
ToLogStr msg =>
Loc -> Text -> LogLevel -> msg -> OnSpansExported ()
forall (m :: * -> *).
Monad m =>
(forall msg.
 ToLogStr msg =>
 Loc -> Text -> LogLevel -> msg -> m ())
-> MonadLogger m
$cmonadLoggerLog :: forall msg.
ToLogStr msg =>
Loc -> Text -> LogLevel -> msg -> OnSpansExported ()
monadLoggerLog :: forall msg.
ToLogStr msg =>
Loc -> Text -> LogLevel -> msg -> OnSpansExported ()
MonadLogger, MonadIO OnSpansExported
MonadLogger OnSpansExported
OnSpansExported Logger
(MonadLogger OnSpansExported, MonadIO OnSpansExported) =>
OnSpansExported Logger -> MonadLoggerIO OnSpansExported
forall (m :: * -> *).
(MonadLogger m, MonadIO m) =>
m Logger -> MonadLoggerIO m
$caskLoggerIO :: OnSpansExported Logger
askLoggerIO :: OnSpansExported Logger
MonadLoggerIO -- @monad-logger@
      ) via (ReaderT (Batch (Span Attrs)) (ReaderT SpanExportResult (ReaderT [SeriesElem] (LoggingT IO))))
    deriving
      ( NonEmpty (OnSpansExported a) -> OnSpansExported a
OnSpansExported a -> OnSpansExported a -> OnSpansExported a
(OnSpansExported a -> OnSpansExported a -> OnSpansExported a)
-> (NonEmpty (OnSpansExported a) -> OnSpansExported a)
-> (forall b.
    Integral b =>
    b -> OnSpansExported a -> OnSpansExported a)
-> Semigroup (OnSpansExported a)
forall b. Integral b => b -> OnSpansExported a -> OnSpansExported a
forall a.
Semigroup a =>
NonEmpty (OnSpansExported a) -> OnSpansExported a
forall a.
Semigroup a =>
OnSpansExported a -> OnSpansExported a -> OnSpansExported a
forall a b.
(Semigroup a, Integral b) =>
b -> OnSpansExported a -> OnSpansExported a
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: forall a.
Semigroup a =>
OnSpansExported a -> OnSpansExported a -> OnSpansExported a
<> :: OnSpansExported a -> OnSpansExported a -> OnSpansExported a
$csconcat :: forall a.
Semigroup a =>
NonEmpty (OnSpansExported a) -> OnSpansExported a
sconcat :: NonEmpty (OnSpansExported a) -> OnSpansExported a
$cstimes :: forall a b.
(Semigroup a, Integral b) =>
b -> OnSpansExported a -> OnSpansExported a
stimes :: forall b. Integral b => b -> OnSpansExported a -> OnSpansExported a
Semigroup, Semigroup (OnSpansExported a)
OnSpansExported a
Semigroup (OnSpansExported a) =>
OnSpansExported a
-> (OnSpansExported a -> OnSpansExported a -> OnSpansExported a)
-> ([OnSpansExported a] -> OnSpansExported a)
-> Monoid (OnSpansExported a)
[OnSpansExported a] -> OnSpansExported a
OnSpansExported a -> OnSpansExported a -> OnSpansExported a
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall a. Monoid a => Semigroup (OnSpansExported a)
forall a. Monoid a => OnSpansExported a
forall a. Monoid a => [OnSpansExported a] -> OnSpansExported a
forall a.
Monoid a =>
OnSpansExported a -> OnSpansExported a -> OnSpansExported a
$cmempty :: forall a. Monoid a => OnSpansExported a
mempty :: OnSpansExported a
$cmappend :: forall a.
Monoid a =>
OnSpansExported a -> OnSpansExported a -> OnSpansExported a
mappend :: OnSpansExported a -> OnSpansExported a -> OnSpansExported a
$cmconcat :: forall a. Monoid a => [OnSpansExported a] -> OnSpansExported a
mconcat :: [OnSpansExported a] -> OnSpansExported a
Monoid -- @base@
      ) via (Ap (ReaderT (Batch (Span Attrs)) (ReaderT SpanExportResult (ReaderT [SeriesElem] (LoggingT IO)))) a)

askSpansExported :: OnSpansExported (Batch (Span Attrs))
askSpansExported :: OnSpansExported (Batch (Span Attrs))
askSpansExported = (Batch (Span Attrs)
 -> SpanExportResult
 -> [SeriesElem]
 -> LoggingT IO (Batch (Span Attrs)))
-> OnSpansExported (Batch (Span Attrs))
forall a.
(Batch (Span Attrs)
 -> SpanExportResult -> [SeriesElem] -> LoggingT IO a)
-> OnSpansExported a
OnSpansExported \Batch (Span Attrs)
spans SpanExportResult
_spanExportResult [SeriesElem]
_pairs -> Batch (Span Attrs) -> LoggingT IO (Batch (Span Attrs))
forall a. a -> LoggingT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Batch (Span Attrs)
spans

askSpansExportedResult :: OnSpansExported SpanExportResult
askSpansExportedResult :: OnSpansExported SpanExportResult
askSpansExportedResult = (Batch (Span Attrs)
 -> SpanExportResult
 -> [SeriesElem]
 -> LoggingT IO SpanExportResult)
-> OnSpansExported SpanExportResult
forall a.
(Batch (Span Attrs)
 -> SpanExportResult -> [SeriesElem] -> LoggingT IO a)
-> OnSpansExported a
OnSpansExported \Batch (Span Attrs)
_spans SpanExportResult
spanExportResult [SeriesElem]
_pairs -> SpanExportResult -> LoggingT IO SpanExportResult
forall a. a -> LoggingT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SpanExportResult
spanExportResult

askSpansExportedMetadata :: OnSpansExported [SeriesElem]
askSpansExportedMetadata :: OnSpansExported [SeriesElem]
askSpansExportedMetadata = (Batch (Span Attrs)
 -> SpanExportResult -> [SeriesElem] -> LoggingT IO [SeriesElem])
-> OnSpansExported [SeriesElem]
forall a.
(Batch (Span Attrs)
 -> SpanExportResult -> [SeriesElem] -> LoggingT IO a)
-> OnSpansExported a
OnSpansExported \Batch (Span Attrs)
_spans SpanExportResult
_spanExportResult [SeriesElem]
pairs -> [SeriesElem] -> LoggingT IO [SeriesElem]
forall a. a -> LoggingT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [SeriesElem]
pairs

newtype Batch a = Batch
  { forall a. Batch a -> [a]
unBatch :: [a]
  } deriving stock (Batch a -> Batch a -> Bool
(Batch a -> Batch a -> Bool)
-> (Batch a -> Batch a -> Bool) -> Eq (Batch a)
forall a. Eq a => Batch a -> Batch a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Batch a -> Batch a -> Bool
== :: Batch a -> Batch a -> Bool
$c/= :: forall a. Eq a => Batch a -> Batch a -> Bool
/= :: Batch a -> Batch a -> Bool
Eq, Int -> Batch a -> ShowS
[Batch a] -> ShowS
Batch a -> [Char]
(Int -> Batch a -> ShowS)
-> (Batch a -> [Char]) -> ([Batch a] -> ShowS) -> Show (Batch a)
forall a. Show a => Int -> Batch a -> ShowS
forall a. Show a => [Batch a] -> ShowS
forall a. Show a => Batch a -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Batch a -> ShowS
showsPrec :: Int -> Batch a -> ShowS
$cshow :: forall a. Show a => Batch a -> [Char]
show :: Batch a -> [Char]
$cshowList :: forall a. Show a => [Batch a] -> ShowS
showList :: [Batch a] -> ShowS
Show)
    deriving (Semigroup (Batch a)
Batch a
Semigroup (Batch a) =>
Batch a
-> (Batch a -> Batch a -> Batch a)
-> ([Batch a] -> Batch a)
-> Monoid (Batch a)
[Batch a] -> Batch a
Batch a -> Batch a -> Batch a
forall a. Semigroup (Batch a)
forall a. Batch a
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall a. [Batch a] -> Batch a
forall a. Batch a -> Batch a -> Batch a
$cmempty :: forall a. Batch a
mempty :: Batch a
$cmappend :: forall a. Batch a -> Batch a -> Batch a
mappend :: Batch a -> Batch a -> Batch a
$cmconcat :: forall a. [Batch a] -> Batch a
mconcat :: [Batch a] -> Batch a
Monoid, NonEmpty (Batch a) -> Batch a
Batch a -> Batch a -> Batch a
(Batch a -> Batch a -> Batch a)
-> (NonEmpty (Batch a) -> Batch a)
-> (forall b. Integral b => b -> Batch a -> Batch a)
-> Semigroup (Batch a)
forall b. Integral b => b -> Batch a -> Batch a
forall a. NonEmpty (Batch a) -> Batch a
forall a. Batch a -> Batch a -> Batch a
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall a b. Integral b => b -> Batch a -> Batch a
$c<> :: forall a. Batch a -> Batch a -> Batch a
<> :: Batch a -> Batch a -> Batch a
$csconcat :: forall a. NonEmpty (Batch a) -> Batch a
sconcat :: NonEmpty (Batch a) -> Batch a
$cstimes :: forall a b. Integral b => b -> Batch a -> Batch a
stimes :: forall b. Integral b => b -> Batch a -> Batch a
Semigroup, [Batch a] -> Value
[Batch a] -> Encoding
Batch a -> Bool
Batch a -> Value
Batch a -> Encoding
(Batch a -> Value)
-> (Batch a -> Encoding)
-> ([Batch a] -> Value)
-> ([Batch a] -> Encoding)
-> (Batch a -> Bool)
-> ToJSON (Batch a)
forall a. ToJSON a => [Batch a] -> Value
forall a. ToJSON a => [Batch a] -> Encoding
forall a. ToJSON a => Batch a -> Bool
forall a. ToJSON a => Batch a -> Value
forall a. ToJSON a => Batch a -> Encoding
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: forall a. ToJSON a => Batch a -> Value
toJSON :: Batch a -> Value
$ctoEncoding :: forall a. ToJSON a => Batch a -> Encoding
toEncoding :: Batch a -> Encoding
$ctoJSONList :: forall a. ToJSON a => [Batch a] -> Value
toJSONList :: [Batch a] -> Value
$ctoEncodingList :: forall a. ToJSON a => [Batch a] -> Encoding
toEncodingList :: [Batch a] -> Encoding
$comitField :: forall a. ToJSON a => Batch a -> Bool
omitField :: Batch a -> Bool
ToJSON) via [a]
    deriving ((forall m. Monoid m => Batch m -> m)
-> (forall m a. Monoid m => (a -> m) -> Batch a -> m)
-> (forall m a. Monoid m => (a -> m) -> Batch a -> m)
-> (forall a b. (a -> b -> b) -> b -> Batch a -> b)
-> (forall a b. (a -> b -> b) -> b -> Batch a -> b)
-> (forall b a. (b -> a -> b) -> b -> Batch a -> b)
-> (forall b a. (b -> a -> b) -> b -> Batch a -> b)
-> (forall a. (a -> a -> a) -> Batch a -> a)
-> (forall a. (a -> a -> a) -> Batch a -> a)
-> (forall a. Batch a -> [a])
-> (forall a. Batch a -> Bool)
-> (forall a. Batch a -> Int)
-> (forall a. Eq a => a -> Batch a -> Bool)
-> (forall a. Ord a => Batch a -> a)
-> (forall a. Ord a => Batch a -> a)
-> (forall a. Num a => Batch a -> a)
-> (forall a. Num a => Batch a -> a)
-> Foldable Batch
forall a. Eq a => a -> Batch a -> Bool
forall a. Num a => Batch a -> a
forall a. Ord a => Batch a -> a
forall m. Monoid m => Batch m -> m
forall a. Batch a -> Bool
forall a. Batch a -> Int
forall a. Batch a -> [a]
forall a. (a -> a -> a) -> Batch a -> a
forall m a. Monoid m => (a -> m) -> Batch a -> m
forall b a. (b -> a -> b) -> b -> Batch a -> b
forall a b. (a -> b -> b) -> b -> Batch a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => Batch m -> m
fold :: forall m. Monoid m => Batch m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Batch a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> Batch a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Batch a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> Batch a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> Batch a -> b
foldr :: forall a b. (a -> b -> b) -> b -> Batch a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Batch a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> Batch a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Batch a -> b
foldl :: forall b a. (b -> a -> b) -> b -> Batch a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Batch a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> Batch a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> Batch a -> a
foldr1 :: forall a. (a -> a -> a) -> Batch a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Batch a -> a
foldl1 :: forall a. (a -> a -> a) -> Batch a -> a
$ctoList :: forall a. Batch a -> [a]
toList :: forall a. Batch a -> [a]
$cnull :: forall a. Batch a -> Bool
null :: forall a. Batch a -> Bool
$clength :: forall a. Batch a -> Int
length :: forall a. Batch a -> Int
$celem :: forall a. Eq a => a -> Batch a -> Bool
elem :: forall a. Eq a => a -> Batch a -> Bool
$cmaximum :: forall a. Ord a => Batch a -> a
maximum :: forall a. Ord a => Batch a -> a
$cminimum :: forall a. Ord a => Batch a -> a
minimum :: forall a. Ord a => Batch a -> a
$csum :: forall a. Num a => Batch a -> a
sum :: forall a. Num a => Batch a -> a
$cproduct :: forall a. Num a => Batch a -> a
product :: forall a. Num a => Batch a -> a
Foldable, (forall a b. (a -> b) -> Batch a -> Batch b)
-> (forall a b. a -> Batch b -> Batch a) -> Functor Batch
forall a b. a -> Batch b -> Batch a
forall a b. (a -> b) -> Batch a -> Batch b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Batch a -> Batch b
fmap :: forall a b. (a -> b) -> Batch a -> Batch b
$c<$ :: forall a b. a -> Batch b -> Batch a
<$ :: forall a b. a -> Batch b -> Batch a
Functor, Functor Batch
Functor Batch =>
(forall a. a -> Batch a)
-> (forall a b. Batch (a -> b) -> Batch a -> Batch b)
-> (forall a b c. (a -> b -> c) -> Batch a -> Batch b -> Batch c)
-> (forall a b. Batch a -> Batch b -> Batch b)
-> (forall a b. Batch a -> Batch b -> Batch a)
-> Applicative Batch
forall a. a -> Batch a
forall a b. Batch a -> Batch b -> Batch a
forall a b. Batch a -> Batch b -> Batch b
forall a b. Batch (a -> b) -> Batch a -> Batch b
forall a b c. (a -> b -> c) -> Batch a -> Batch b -> Batch c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> Batch a
pure :: forall a. a -> Batch a
$c<*> :: forall a b. Batch (a -> b) -> Batch a -> Batch b
<*> :: forall a b. Batch (a -> b) -> Batch a -> Batch b
$cliftA2 :: forall a b c. (a -> b -> c) -> Batch a -> Batch b -> Batch c
liftA2 :: forall a b c. (a -> b -> c) -> Batch a -> Batch b -> Batch c
$c*> :: forall a b. Batch a -> Batch b -> Batch b
*> :: forall a b. Batch a -> Batch b -> Batch b
$c<* :: forall a b. Batch a -> Batch b -> Batch a
<* :: forall a b. Batch a -> Batch b -> Batch a
Applicative, Applicative Batch
Applicative Batch =>
(forall a b. Batch a -> (a -> Batch b) -> Batch b)
-> (forall a b. Batch a -> Batch b -> Batch b)
-> (forall a. a -> Batch a)
-> Monad Batch
forall a. a -> Batch a
forall a b. Batch a -> Batch b -> Batch b
forall a b. Batch a -> (a -> Batch b) -> Batch b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. Batch a -> (a -> Batch b) -> Batch b
>>= :: forall a b. Batch a -> (a -> Batch b) -> Batch b
$c>> :: forall a b. Batch a -> Batch b -> Batch b
>> :: forall a b. Batch a -> Batch b -> Batch b
$creturn :: forall a. a -> Batch a
return :: forall a. a -> Batch a
Monad) via []

instance Traversable Batch where
  traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Batch a -> f (Batch b)
traverse a -> f b
f (Batch [a]
xs) = ([b] -> Batch b) -> f [b] -> f (Batch b)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [b] -> Batch b
forall a. [a] -> Batch a
Batch (f [b] -> f (Batch b)) -> f [b] -> f (Batch b)
forall a b. (a -> b) -> a -> b
$ (a -> f b) -> [a] -> f [b]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse a -> f b
f [a]
xs

singletonBatch :: a -> Batch a
singletonBatch :: forall a. a -> Batch a
singletonBatch = [a] -> Batch a
forall a. [a] -> Batch a
Batch ([a] -> Batch a) -> (a -> [a]) -> a -> Batch a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [a]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure

fromListBatch :: [a] -> Batch a
fromListBatch :: forall a. [a] -> Batch a
fromListBatch = [a] -> Batch a
forall a. [a] -> Batch a
Batch

data ConcurrentWorkersSpec item = ConcurrentWorkersSpec
  { forall item. ConcurrentWorkersSpec item -> Int
concurrentWorkersSpecQueueSize :: Int
  , forall item. ConcurrentWorkersSpec item -> Int
concurrentWorkersSpecWorkerCount :: Int
  , forall item. ConcurrentWorkersSpec item -> item -> IO ()
concurrentWorkersSpecProcessItem :: item -> IO ()
  , forall item. ConcurrentWorkersSpec item -> Logger
concurrentWorkersSpecLogger :: Logger
  , forall item. ConcurrentWorkersSpec item -> [SeriesElem]
concurrentWorkersSpecLoggingMeta :: [SeriesElem]
  , forall item. ConcurrentWorkersSpec item -> item -> OnException ()
concurrentWorkersSpecOnException :: item -> OnException ()
  }

defaultConcurrentWorkersSpec :: ConcurrentWorkersSpec item
defaultConcurrentWorkersSpec :: forall item. ConcurrentWorkersSpec item
defaultConcurrentWorkersSpec =
  ConcurrentWorkersSpec
    { concurrentWorkersSpecQueueSize :: Int
concurrentWorkersSpecQueueSize = Int
2048
    , concurrentWorkersSpecWorkerCount :: Int
concurrentWorkersSpecWorkerCount = Int
5
    , concurrentWorkersSpecProcessItem :: item -> IO ()
concurrentWorkersSpecProcessItem = item -> IO ()
forall a. Monoid a => a
mempty
    , concurrentWorkersSpecLogger :: Logger
concurrentWorkersSpecLogger = Logger
forall a. Monoid a => a
mempty
    , concurrentWorkersSpecLoggingMeta :: [SeriesElem]
concurrentWorkersSpecLoggingMeta = [SeriesElem]
forall a. Monoid a => a
mempty
    , concurrentWorkersSpecOnException :: item -> OnException ()
concurrentWorkersSpecOnException = \item
_item -> do
        SomeException e
ex <- OnException SomeException
askException
        [SeriesElem]
pairs <- OnException [SeriesElem]
askExceptionMetadata
        Message -> OnException ()
forall (m :: * -> *).
(HasCallStack, MonadLogger m) =>
Message -> m ()
logError (Message -> OnException ()) -> Message -> OnException ()
forall a b. (a -> b) -> a -> b
$ Text
"Concurrent worker ignoring exception from processing item" Text -> [SeriesElem] -> Message
:#
          Key
"exception" Key -> [Char] -> SeriesElem
forall v. ToJSON v => Key -> v -> SeriesElem
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= e -> [Char]
forall e. Exception e => e -> [Char]
displayException e
ex SeriesElem -> [SeriesElem] -> [SeriesElem]
forall a. a -> [a] -> [a]
: [SeriesElem]
pairs
    }

data ConcurrentWorkers item = ConcurrentWorkers
  { forall item. ConcurrentWorkers item -> item -> IO ()
concurrentWorkersEnqueueItem :: item -> IO ()
  , forall item. ConcurrentWorkers item -> IO ()
concurrentWorkersStopWorkers :: IO ()
  }

withConcurrentWorkers
  :: forall item a
   . (ToJSON item, Typeable item)
  => ConcurrentWorkersSpec item
  -> (ConcurrentWorkers item -> IO a)
  -> IO a
withConcurrentWorkers :: forall item a.
(ToJSON item, Typeable item) =>
ConcurrentWorkersSpec item
-> (ConcurrentWorkers item -> IO a) -> IO a
withConcurrentWorkers ConcurrentWorkersSpec item
concurrentWorkersSpec ConcurrentWorkers item -> IO a
action = do
  (LoggingT IO () -> Logger -> IO ())
-> Logger -> LoggingT IO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip LoggingT IO () -> Logger -> IO ()
forall (m :: * -> *) a. LoggingT m a -> Logger -> m a
runLoggingT Logger
logger do
    Message -> LoggingT IO ()
forall (m :: * -> *).
(HasCallStack, MonadLogger m) =>
Message -> m ()
logDebug (Message -> LoggingT IO ()) -> Message -> LoggingT IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Starting concurrent workers" Text -> [SeriesElem] -> Message
:# [SeriesElem]
loggingMeta
  TBMQueue item
queue <- Int -> IO (TBMQueue item)
forall a. Int -> IO (TBMQueue a)
newTBMQueueIO Int
queueSize
  TBMQueue item -> ([Async ()] -> IO a) -> IO a
withWorkers TBMQueue item
queue \[Async ()]
workers -> do
    (LoggingT IO () -> Logger -> IO ())
-> Logger -> LoggingT IO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip LoggingT IO () -> Logger -> IO ()
forall (m :: * -> *) a. LoggingT m a -> Logger -> m a
runLoggingT Logger
logger do
      Message -> LoggingT IO ()
forall (m :: * -> *).
(HasCallStack, MonadLogger m) =>
Message -> m ()
logDebug (Message -> LoggingT IO ()) -> Message -> LoggingT IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Concurrent workers started" Text -> [SeriesElem] -> Message
:# [SeriesElem]
loggingMeta
    ConcurrentWorkers item -> IO a
action ConcurrentWorkers
      { concurrentWorkersEnqueueItem :: item -> IO ()
concurrentWorkersEnqueueItem = TBMQueue item -> item -> IO ()
enqueueItem TBMQueue item
queue
      , concurrentWorkersStopWorkers :: IO ()
concurrentWorkersStopWorkers = TBMQueue item -> [Async ()] -> IO ()
stopWorkers TBMQueue item
queue [Async ()]
workers
      }
  where
  enqueueItem :: TBMQueue item -> item -> IO ()
  enqueueItem :: TBMQueue item -> item -> IO ()
enqueueItem TBMQueue item
queue item
item = do
    STM (Maybe Bool) -> IO (Maybe Bool)
forall a. STM a -> IO a
atomically (TBMQueue item -> item -> STM (Maybe Bool)
forall a. TBMQueue a -> a -> STM (Maybe Bool)
tryWriteTBMQueue TBMQueue item
queue item
item) IO (Maybe Bool) -> (Maybe Bool -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Just Bool
True -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just Bool
False -> do
        (LoggingT IO () -> Logger -> IO ())
-> Logger -> LoggingT IO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip LoggingT IO () -> Logger -> IO ()
forall (m :: * -> *) a. LoggingT m a -> Logger -> m a
runLoggingT Logger
logger do
          Message -> LoggingT IO ()
forall (m :: * -> *).
(HasCallStack, MonadLogger m) =>
Message -> m ()
logError (Message -> LoggingT IO ()) -> Message -> LoggingT IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Dropped item as queue was full" Text -> [SeriesElem] -> Message
:# [SeriesElem]
loggingMeta
      Maybe Bool
Nothing -> do
        (LoggingT IO () -> Logger -> IO ())
-> Logger -> LoggingT IO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip LoggingT IO () -> Logger -> IO ()
forall (m :: * -> *) a. LoggingT m a -> Logger -> m a
runLoggingT Logger
logger do
          Message -> LoggingT IO ()
forall (m :: * -> *).
(HasCallStack, MonadLogger m) =>
Message -> m ()
logError (Message -> LoggingT IO ()) -> Message -> LoggingT IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Dropped item as queue was closed" Text -> [SeriesElem] -> Message
:#
            Key
"item" Key -> item -> SeriesElem
forall v. ToJSON v => Key -> v -> SeriesElem
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= item
item SeriesElem -> [SeriesElem] -> [SeriesElem]
forall a. a -> [a] -> [a]
: [SeriesElem]
loggingMeta

  withWorkers :: TBMQueue item -> ([Async ()] -> IO a) -> IO a
  withWorkers :: TBMQueue item -> ([Async ()] -> IO a) -> IO a
withWorkers TBMQueue item
queue [Async ()] -> IO a
f =
    [(Async () -> IO a) -> IO a] -> ([Async ()] -> IO a) -> IO a
forall a b. [(a -> b) -> b] -> ([a] -> b) -> b
withAll (Int -> ((Async () -> IO a) -> IO a) -> [(Async () -> IO a) -> IO a]
forall a. Int -> a -> [a]
replicate Int
workerCount (((Async () -> IO a) -> IO a) -> [(Async () -> IO a) -> IO a])
-> ((Async () -> IO a) -> IO a) -> [(Async () -> IO a) -> IO a]
forall a b. (a -> b) -> a -> b
$ IO () -> (Async () -> IO a) -> IO a
forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync (IO () -> (Async () -> IO a) -> IO a)
-> IO () -> (Async () -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ TBMQueue item -> IO ()
mkWorker TBMQueue item
queue) \[Async ()]
workers -> do
      [Async ()] -> IO a
f [Async ()]
workers IO a -> IO () -> IO a
forall (m :: * -> *) a b.
(HasCallStack, MonadMask m) =>
m a -> m b -> m a
`finally` TBMQueue item -> [Async ()] -> IO ()
stopWorkers TBMQueue item
queue [Async ()]
workers

  stopWorkers :: TBMQueue item -> [Async ()] -> IO ()
  stopWorkers :: TBMQueue item -> [Async ()] -> IO ()
stopWorkers TBMQueue item
queue [Async ()]
workers = do
    STM Bool -> STM (IO ()) -> IO ()
forall a. Monoid a => STM Bool -> STM (IO a) -> IO a
unlessSTM (TBMQueue item -> STM Bool
forall a. TBMQueue a -> STM Bool
isClosedTBMQueue TBMQueue item
queue) do
      TBMQueue item -> STM ()
forall a. TBMQueue a -> STM ()
closeTBMQueue TBMQueue item
queue
      IO () -> STM (IO ())
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure do
        (LoggingT IO () -> Logger -> IO ())
-> Logger -> LoggingT IO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip LoggingT IO () -> Logger -> IO ()
forall (m :: * -> *) a. LoggingT m a -> Logger -> m a
runLoggingT Logger
logger do
          Message -> LoggingT IO ()
forall (m :: * -> *).
(HasCallStack, MonadLogger m) =>
Message -> m ()
logDebug (Message -> LoggingT IO ()) -> Message -> LoggingT IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Stopping concurrent workers" Text -> [SeriesElem] -> Message
:# [SeriesElem]
loggingMeta
          [Async ()] -> (Async () -> LoggingT IO ()) -> LoggingT IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Async ()]
workers \Async ()
worker -> do
            IO (Either SomeException ())
-> LoggingT IO (Either SomeException ())
forall a. IO a -> LoggingT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Async () -> IO (Either SomeException ())
forall a. Async a -> IO (Either SomeException a)
waitCatch Async ()
worker) LoggingT IO (Either SomeException ())
-> (Either SomeException () -> LoggingT IO ()) -> LoggingT IO ()
forall a b. LoggingT IO a -> (a -> LoggingT IO b) -> LoggingT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              Right () -> () -> LoggingT IO ()
forall a. a -> LoggingT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
              Left (SomeException e
ex) -> do
                Message -> LoggingT IO ()
forall (m :: * -> *).
(HasCallStack, MonadLogger m) =>
Message -> m ()
logError (Message -> LoggingT IO ()) -> Message -> LoggingT IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Concurrent worker previously died due to unhandled exception" Text -> [SeriesElem] -> Message
:#
                  Key
"exception" Key -> [Char] -> SeriesElem
forall v. ToJSON v => Key -> v -> SeriesElem
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= e -> [Char]
forall e. Exception e => e -> [Char]
displayException e
ex SeriesElem -> [SeriesElem] -> [SeriesElem]
forall a. a -> [a] -> [a]
: [SeriesElem]
loggingMeta

  mkWorker :: TBMQueue item -> IO ()
  mkWorker :: TBMQueue item -> IO ()
mkWorker TBMQueue item
queue = IO ()
go
    where
    go :: IO ()
go = do
      Maybe item
mItem <- STM (Maybe item) -> IO (Maybe item)
forall a. STM a -> IO a
atomically (STM (Maybe item) -> IO (Maybe item))
-> STM (Maybe item) -> IO (Maybe item)
forall a b. (a -> b) -> a -> b
$ TBMQueue item -> STM (Maybe item)
forall a. TBMQueue a -> STM (Maybe a)
readTBMQueue TBMQueue item
queue
      Maybe item -> (item -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe item
mItem \item
item -> do
        (LoggingT IO () -> Logger -> IO ())
-> Logger -> LoggingT IO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip LoggingT IO () -> Logger -> IO ()
forall (m :: * -> *) a. LoggingT m a -> Logger -> m a
runLoggingT Logger
logger do
          IO () -> LoggingT IO ()
forall a. IO a -> LoggingT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (() -> IO ()
forall a. a -> IO a
evaluate (() -> IO ()) -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< item -> IO ()
processItem item
item) LoggingT IO ()
-> (SomeException -> LoggingT IO ()) -> LoggingT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadCatch m) =>
m a -> (SomeException -> m a) -> m a
`catchAny` \SomeException
someEx -> do
              OnException () -> SomeException -> [SeriesElem] -> LoggingT IO ()
forall a.
OnException a -> SomeException -> [SeriesElem] -> LoggingT IO a
runOnException (item -> OnException ()
onEx item
item) SomeException
someEx [SeriesElem]
pairs
        IO ()
go

  loggingMeta :: [SeriesElem]
  loggingMeta :: [SeriesElem]
loggingMeta =
    Key
"itemType" Key -> [Char] -> SeriesElem
forall v. ToJSON v => Key -> v -> SeriesElem
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= TypeRep -> [Char]
forall a. Show a => a -> [Char]
show (Proxy item -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy item -> TypeRep) -> Proxy item -> TypeRep
forall a b. (a -> b) -> a -> b
$ forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @item)
      SeriesElem -> [SeriesElem] -> [SeriesElem]
forall a. a -> [a] -> [a]
: Key
"workerCount" Key -> Int -> SeriesElem
forall v. ToJSON v => Key -> v -> SeriesElem
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Int
workerCount
      SeriesElem -> [SeriesElem] -> [SeriesElem]
forall a. a -> [a] -> [a]
: Key
"queueSize" Key -> Int -> SeriesElem
forall v. ToJSON v => Key -> v -> SeriesElem
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Int
queueSize
      SeriesElem -> [SeriesElem] -> [SeriesElem]
forall a. a -> [a] -> [a]
: [SeriesElem]
pairs

  ConcurrentWorkersSpec
    { concurrentWorkersSpecQueueSize :: forall item. ConcurrentWorkersSpec item -> Int
concurrentWorkersSpecQueueSize = Int
queueSize
    , concurrentWorkersSpecWorkerCount :: forall item. ConcurrentWorkersSpec item -> Int
concurrentWorkersSpecWorkerCount = Int
workerCount
    , concurrentWorkersSpecProcessItem :: forall item. ConcurrentWorkersSpec item -> item -> IO ()
concurrentWorkersSpecProcessItem = item -> IO ()
processItem
    , concurrentWorkersSpecLogger :: forall item. ConcurrentWorkersSpec item -> Logger
concurrentWorkersSpecLogger = Logger
logger
    , concurrentWorkersSpecLoggingMeta :: forall item. ConcurrentWorkersSpec item -> [SeriesElem]
concurrentWorkersSpecLoggingMeta = [SeriesElem]
pairs
    , concurrentWorkersSpecOnException :: forall item. ConcurrentWorkersSpec item -> item -> OnException ()
concurrentWorkersSpecOnException = item -> OnException ()
onEx
    } = ConcurrentWorkersSpec item
concurrentWorkersSpec

unlessSTM :: (Monoid a) => STM Bool -> STM (IO a) -> IO a
unlessSTM :: forall a. Monoid a => STM Bool -> STM (IO a) -> IO a
unlessSTM STM Bool
isShutdownSTM STM (IO a)
actionSTM =
  IO (IO a) -> IO a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO a) -> IO a) -> IO (IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ STM (IO a) -> IO (IO a)
forall a. STM a -> IO a
atomically (STM (IO a) -> IO (IO a)) -> STM (IO a) -> IO (IO a)
forall a b. (a -> b) -> a -> b
$ STM Bool
isShutdownSTM STM Bool -> (Bool -> STM (IO a)) -> STM (IO a)
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Bool
True -> IO a -> STM (IO a)
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure IO a
forall a. Monoid a => a
mempty
    Bool
False -> STM (IO a)
actionSTM

withAll
  :: forall a b
   . [(a -> b) -> b]
  -> ([a] -> b)
  -> b
withAll :: forall a b. [(a -> b) -> b] -> ([a] -> b) -> b
withAll = Cont b [a] -> ([a] -> b) -> b
forall r a. Cont r a -> (a -> r) -> r
runCont (Cont b [a] -> ([a] -> b) -> b)
-> ([(a -> b) -> b] -> Cont b [a])
-> [(a -> b) -> b]
-> ([a] -> b)
-> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((a -> b) -> b) -> ContT b Identity a)
-> [(a -> b) -> b] -> Cont b [a]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((a -> b) -> b) -> ContT b Identity a
forall a r. ((a -> r) -> r) -> Cont r a
cont

defaultSystemSeed :: Seed
defaultSystemSeed :: Seed
defaultSystemSeed = IO Seed -> Seed
forall a. IO a -> a
unsafePerformIO IO Seed
createSystemSeed
{-# NOINLINE defaultSystemSeed #-}

defaultManager :: Manager
defaultManager :: Manager
defaultManager = IO Manager -> Manager
forall a. IO a -> a
unsafePerformIO IO Manager
forall (m :: * -> *). MonadIO m => m Manager
newTlsManager
{-# NOINLINE defaultManager #-}

spanSummary :: Span attrs -> Value
spanSummary :: forall (attrs :: AttrsFor -> *). Span attrs -> Value
spanSummary Span attrs
s =
  [Pair] -> Value
object
    [ Key
"lineage" Key -> SpanLineage -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Span attrs -> SpanLineage
forall (attrs :: AttrsFor -> *). Span attrs -> SpanLineage
spanLineage Span attrs
s
    , Key
"spanContext" Key -> SpanContext -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Span attrs -> SpanContext
forall (attrs :: AttrsFor -> *). Span attrs -> SpanContext
spanContext Span attrs
s
    , Key
"name" Key -> SpanName -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Span attrs -> SpanName
forall (attrs :: AttrsFor -> *). Span attrs -> SpanName
spanName Span attrs
s
    ]

redactHttpExceptionHeaders
  :: Set HeaderName
  -> Set HeaderName
  -> SomeException
  -> SomeException
redactHttpExceptionHeaders :: Set HeaderName -> Set HeaderName -> SomeException -> SomeException
redactHttpExceptionHeaders Set HeaderName
redactsForReq Set HeaderName
redactsForResp SomeException
someEx =
  SomeException -> Maybe SomeException -> SomeException
forall a. a -> Maybe a -> a
fromMaybe SomeException
someEx do
    HttpExceptionRequest Request
req HttpExceptionContent
content <- SomeException -> Maybe HttpException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
someEx
    SomeException -> Maybe SomeException
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SomeException -> Maybe SomeException)
-> SomeException -> Maybe SomeException
forall a b. (a -> b) -> a -> b
$ HttpException -> SomeException
forall e. Exception e => e -> SomeException
toException (HttpException -> SomeException) -> HttpException -> SomeException
forall a b. (a -> b) -> a -> b
$ Request -> HttpExceptionContent -> HttpException
go Request
req HttpExceptionContent
content
  where
  go
    :: Request
    -> HttpExceptionContent
    -> HttpException
  go :: Request -> HttpExceptionContent -> HttpException
go Request
req HttpExceptionContent
content =
    Request -> HttpExceptionContent -> HttpException
HttpExceptionRequest (Request -> Request
redactReqHeaders Request
req)
      case HttpExceptionContent
content of
        StatusCodeException Response ()
resp ByteString
bs ->
          Response () -> ByteString -> HttpExceptionContent
StatusCodeException (Response () -> Response ()
forall a. Response a -> Response a
redactRespHeaders Response ()
resp) ByteString
bs
        TooManyRedirects [Response ByteString]
resps ->
          [Response ByteString] -> HttpExceptionContent
TooManyRedirects ([Response ByteString] -> HttpExceptionContent)
-> [Response ByteString] -> HttpExceptionContent
forall a b. (a -> b) -> a -> b
$ (Response ByteString -> Response ByteString)
-> [Response ByteString] -> [Response ByteString]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Response ByteString -> Response ByteString
forall a. Response a -> Response a
redactRespHeaders [Response ByteString]
resps
        HttpExceptionContent
x -> HttpExceptionContent
x

  redactReqHeaders :: Request -> Request
  redactReqHeaders :: Request -> Request
redactReqHeaders Request
req =
    Request
req
      { requestHeaders =
          redactSensitiveHeader redactsForReq <$> requestHeaders req
      }

  redactRespHeaders :: Response a -> Response a
  redactRespHeaders :: forall a. Response a -> Response a
redactRespHeaders Response a
resp =
    Response a
resp
      { responseHeaders =
          redactSensitiveHeader redactsForResp <$> responseHeaders resp
      , responseOriginalRequest =
          (responseOriginalRequest resp)
            { requestHeaders =
                redactSensitiveHeader redactsForReq <$> requestHeaders (responseOriginalRequest resp)
            }
      }

  -- This function exists in @Network.HTTP.Client.Types@ but is not exported. We
  -- inline it here and use it rather than relying on the user having
  -- @http-client.0.7.13@ which would let us use @redactHeaders@ on the request
  -- directly. There also isn't a @Response@ analogue of @redactHeaders@, so
  -- we'd need a more general-purpose function like @redactSensitiveHeader@
  -- anyways.
  redactSensitiveHeader :: Set HeaderName -> Header -> Header
  redactSensitiveHeader :: Set HeaderName -> Header -> Header
redactSensitiveHeader Set HeaderName
toRedact h :: Header
h@(HeaderName
name, ByteString
_) =
    if HeaderName
name HeaderName -> Set HeaderName -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set HeaderName
toRedact then
      (HeaderName
name, ByteString
"<REDACTED>")
    else
      Header
h

-- $disclaimer
--
-- In general, changes to this module will not be reflected in the library's
-- version updates. Direct use of this module should be done with utmost care,
-- otherwise invariants will easily be violated.