{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE RecordWildCards #-}

{- |
 Module      :  OpenTelemetry.Trace.Sampler
 Copyright   :  (c) Ian Duncan, 2021
 License     :  BSD-3
 Description :  Sampling strategies for reducing tracing overhead
 Maintainer  :  Ian Duncan
 Stability   :  experimental
 Portability :  non-portable (GHC extensions)

 This module provides several built-in sampling strategies, as well as the ability to define custom samplers.

 Sampling is the concept of selecting a few elements from a large collection and learning about the entire collection by extrapolating from the selected set. It's widely used throughout the world whenever trying to tackle a problem of scale: for example, a survey assumes that by asking a small group of people a set of questions, you can learn something about the opinions of the entire populace.

 While it's nice to believe that every event is precious, the reality of monitoring high volume production infrastructure is that there are some attributes to events that make them more interesting than the rest. Failures are often more interesting than successes! Rare events are more interesting than common events! Capturing some traffic from all customers can be better than capturing all traffic from some customers.

 Sampling as a basic technique for instrumentation is no different. By recording information about a representative subset of requests flowing through a system, you can learn about the overall performance of the system. And as with surveys and air monitoring, the way you choose your representative set (the sample set) can greatly influence the accuracy of your results.

 Sampling is widespread in observability systems because it lowers the cost of producing, collecting, and analyzing data in systems anywhere cost is a concern. Developers and operators in an observability system apply or attach key=value properties to observability data, spans and metrics, and we use these properties to investigate hypotheses about our systems after the fact. It is interesting to look at how sampling impacts our ability to analyze observability data, using key=value restrictions for some keys and grouping the output based on other keys.

 Sampling schemes let observability systems collect examples of data that are not merely exemplary, but also representative. Sampling schemes compute a set of representative items and, in doing so, score each item with what is commonly called the item's "sampling rate." A sampling rate of 10 indicates that the item represents an estimated 10 individuals in the original data set.
-}
module OpenTelemetry.Trace.Sampler (
  -- * Types
  Sampler (..),
  SamplingResult (..),
  SamplingDecision (..),
  ParentBasedOptions (..),

  -- * Running samplers
  shouldSample,
  getDescription,

  -- * Built-in samplers
  alwaysOn,
  alwaysOff,
  traceIdRatioBased,
  parentBased,
  parentBasedOptions,
  alwaysRecord,
) where

import Data.Bits
import qualified Data.HashMap.Strict as H
import Data.Text (Text)
import qualified Data.Text.Lazy as TL
import Data.Text.Lazy.Builder (toLazyText)
import Data.Text.Lazy.Builder.RealFloat (realFloat)
import Data.Word (Word64, byteSwap64)
import GHC.ByteOrder (ByteOrder (..), targetByteOrder)
import OpenTelemetry.Attributes (toAttribute)
import OpenTelemetry.Context
import OpenTelemetry.Internal.Common.Types (InstrumentationLibrary)
import OpenTelemetry.Internal.Trace.Id (TraceId (..))
import OpenTelemetry.Internal.Trace.Types
import OpenTelemetry.Trace.Id
import OpenTelemetry.Trace.TraceState as TraceState


{- | Returns @RecordAndSample@ always.

 Description returns AlwaysOnSampler.

 @since 0.1.0.0
-}
alwaysOn :: Sampler
alwaysOn :: Sampler
alwaysOn = Sampler
AlwaysOnSampler


{- | Returns @Drop@ always.

 Description returns AlwaysOffSampler.

 @since 0.1.0.0
-}
alwaysOff :: Sampler
alwaysOff :: Sampler
alwaysOff = Sampler
AlwaysOffSampler


{- | The TraceIdRatioBased ignores the parent SampledFlag. To respect the parent SampledFlag,
 the TraceIdRatioBased should be used as a delegate of the @parentBased@ sampler specified below.

 Description returns a string of the form "TraceIdRatioBased{RATIO}" with RATIO replaced with the Sampler
 instance's trace sampling ratio represented as a decimal number.

 @since 0.1.0.0
-}
traceIdRatioBased :: Double -> Sampler
traceIdRatioBased :: Double -> Sampler
traceIdRatioBased Double
fraction =
  Double -> Word64 -> Attribute -> Sampler
TraceIdRatioSampler Double
safeFraction Word64
traceIdUpperBound Attribute
sampleRate
  where
    safeFraction :: Double
safeFraction = Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
0 (Double -> Double -> Double
forall a. Ord a => a -> a -> a
min Double
1 Double
fraction)
    sampleRate :: Attribute
sampleRate =
      if Double
safeFraction Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0
        then Int -> Attribute
forall a. ToAttribute a => a -> Attribute
toAttribute ((Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Double
1 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
safeFraction)) :: Int)
        else Int -> Attribute
forall a. ToAttribute a => a -> Attribute
toAttribute (Int
0 :: Int)
    traceIdUpperBound :: Word64
traceIdUpperBound = Double -> Word64
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double
safeFraction Double -> Double -> Double
forall a. Num a => a -> a -> a
* Word64 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Word64
1 :: Word64) Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` Int
63)) :: Word64


{- | This is a composite sampler. ParentBased helps distinguish between the following cases:

 No parent (root span).

 Remote parent (SpanContext.IsRemote() == true) with SampledFlag equals true

 Remote parent (SpanContext.IsRemote() == true) with SampledFlag equals false

 Local parent (SpanContext.IsRemote() == false) with SampledFlag equals true

 Local parent (SpanContext.IsRemote() == false) with SampledFlag equals false

 @since 0.1.0.0
-}

{- | A smart constructor for 'ParentBasedOptions' with reasonable starting
 defaults.

 @since 0.1.0.0
-}
parentBasedOptions
  :: Sampler
  -- ^ Root sampler
  -> ParentBasedOptions
parentBasedOptions :: Sampler -> ParentBasedOptions
parentBasedOptions Sampler
root =
  ParentBasedOptions
    { rootSampler :: Sampler
rootSampler = Sampler
root
    , remoteParentSampled :: Sampler
remoteParentSampled = Sampler
alwaysOn
    , remoteParentNotSampled :: Sampler
remoteParentNotSampled = Sampler
alwaysOff
    , localParentSampled :: Sampler
localParentSampled = Sampler
alwaysOn
    , localParentNotSampled :: Sampler
localParentNotSampled = Sampler
alwaysOff
    }


{- | A sampler which behaves differently based on the incoming sampling decision.

 In general, this will sample spans that have parents that were sampled, and will not sample spans whose parents were not sampled.

 @since 0.1.0.0
-}
parentBased :: ParentBasedOptions -> Sampler
parentBased :: ParentBasedOptions -> Sampler
parentBased = ParentBasedOptions -> Sampler
ParentBasedSampler


{- | A decorator that ensures spans always reach processors (IsRecording=true)
even when the wrapped sampler would DROP them. Per spec:

  - DROP         -> RECORD_ONLY (upgraded: processors see it, exporters don't)
  - RECORD_ONLY  -> RECORD_ONLY (unchanged)
  - RECORD_AND_SAMPLE -> RECORD_AND_SAMPLE (unchanged)

Useful for span-to-metrics processors or debugging processors that need
visibility into all spans without increasing export volume.

@since 0.2.0.0
-}
alwaysRecord :: Sampler -> Sampler
alwaysRecord :: Sampler -> Sampler
alwaysRecord = Sampler -> Sampler
AlwaysRecordSampler


{- | Execute the sampling decision for a 'Sampler'.

The 'InstrumentationLibrary' parameter is the instrumentation scope of the
'Tracer' creating the span, as required by the spec.
Spec: <https://opentelemetry.io/docs/specs/otel/trace/sdk/#shouldsample>

Non-recursive wrapper handles the two most common leaf samplers
(AlwaysOn / AlwaysOff) inline.

@since 0.0.1.0
-}
shouldSample :: Sampler -> Context -> TraceId -> Text -> SpanArguments -> InstrumentationLibrary -> IO SamplingDecision
shouldSample :: Sampler
-> Context
-> TraceId
-> Text
-> SpanArguments
-> InstrumentationLibrary
-> IO SamplingDecision
shouldSample Sampler
AlwaysOnSampler Context
ctxt TraceId
_tid Text
_name SpanArguments
_args InstrumentationLibrary
_scope =
  let !ts :: TraceState
ts = Context -> TraceState
parentTraceState Context
ctxt
  in SamplingDecision -> IO SamplingDecision
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SamplingDecision -> IO SamplingDecision)
-> SamplingDecision -> IO SamplingDecision
forall a b. (a -> b) -> a -> b
$! SamplingResult -> AttributeMap -> TraceState -> SamplingDecision
SamplingDecision SamplingResult
RecordAndSample AttributeMap
forall k v. HashMap k v
H.empty TraceState
ts
shouldSample Sampler
AlwaysOffSampler Context
ctxt TraceId
_tid Text
_name SpanArguments
_args InstrumentationLibrary
_scope =
  let !ts :: TraceState
ts = Context -> TraceState
parentTraceState Context
ctxt
  in SamplingDecision -> IO SamplingDecision
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SamplingDecision -> IO SamplingDecision)
-> SamplingDecision -> IO SamplingDecision
forall a b. (a -> b) -> a -> b
$! SamplingResult -> AttributeMap -> TraceState -> SamplingDecision
SamplingDecision SamplingResult
Drop AttributeMap
forall k v. HashMap k v
H.empty TraceState
ts
shouldSample Sampler
sampler Context
ctxt TraceId
tid Text
name SpanArguments
args InstrumentationLibrary
scope =
  Sampler
-> Context
-> TraceId
-> Text
-> SpanArguments
-> InstrumentationLibrary
-> IO SamplingDecision
shouldSampleComplex Sampler
sampler Context
ctxt TraceId
tid Text
name SpanArguments
args InstrumentationLibrary
scope
{-# INLINE shouldSample #-}


shouldSampleComplex :: Sampler -> Context -> TraceId -> Text -> SpanArguments -> InstrumentationLibrary -> IO SamplingDecision
shouldSampleComplex :: Sampler
-> Context
-> TraceId
-> Text
-> SpanArguments
-> InstrumentationLibrary
-> IO SamplingDecision
shouldSampleComplex (TraceIdRatioSampler Double
frac Word64
upperBound Attribute
sampleRateAttr) Context
ctxt TraceId
tid Text
_name SpanArguments
_args InstrumentationLibrary
_scope =
  let !ts :: TraceState
ts = Context -> TraceState
parentTraceState Context
ctxt
  in if Double
frac Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
1
       then SamplingDecision -> IO SamplingDecision
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SamplingDecision -> IO SamplingDecision)
-> SamplingDecision -> IO SamplingDecision
forall a b. (a -> b) -> a -> b
$! SamplingResult -> AttributeMap -> TraceState -> SamplingDecision
SamplingDecision SamplingResult
RecordAndSample (Text -> Attribute -> AttributeMap
forall k v. Hashable k => k -> v -> HashMap k v
H.singleton Text
"sampleRate" Attribute
sampleRateAttr) TraceState
ts
       else
         let !(TraceId Word64
_ Word64
lo) = TraceId
tid
             !loBE :: Word64
loBE = case ByteOrder
targetByteOrder of
               ByteOrder
BigEndian -> Word64
lo
               ByteOrder
LittleEndian -> Word64 -> Word64
byteSwap64 Word64
lo
             !x :: Word64
x = Word64
loBE Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
1
         in if Word64
x Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
< Word64
upperBound
              then SamplingDecision -> IO SamplingDecision
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SamplingDecision -> IO SamplingDecision)
-> SamplingDecision -> IO SamplingDecision
forall a b. (a -> b) -> a -> b
$! SamplingResult -> AttributeMap -> TraceState -> SamplingDecision
SamplingDecision SamplingResult
RecordAndSample (Text -> Attribute -> AttributeMap
forall k v. Hashable k => k -> v -> HashMap k v
H.singleton Text
"sampleRate" Attribute
sampleRateAttr) TraceState
ts
              else SamplingDecision -> IO SamplingDecision
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SamplingDecision -> IO SamplingDecision)
-> SamplingDecision -> IO SamplingDecision
forall a b. (a -> b) -> a -> b
$! SamplingResult -> AttributeMap -> TraceState -> SamplingDecision
SamplingDecision SamplingResult
Drop AttributeMap
forall k v. HashMap k v
H.empty TraceState
ts
shouldSampleComplex (ParentBasedSampler ParentBasedOptions {Sampler
rootSampler :: ParentBasedOptions -> Sampler
remoteParentSampled :: ParentBasedOptions -> Sampler
remoteParentNotSampled :: ParentBasedOptions -> Sampler
localParentSampled :: ParentBasedOptions -> Sampler
localParentNotSampled :: ParentBasedOptions -> Sampler
rootSampler :: Sampler
remoteParentSampled :: Sampler
remoteParentNotSampled :: Sampler
localParentSampled :: Sampler
localParentNotSampled :: Sampler
..}) Context
ctxt TraceId
tid Text
name SpanArguments
args InstrumentationLibrary
scope =
  case Context -> Maybe SpanContext
parentSpanContext Context
ctxt of
    Maybe SpanContext
Nothing -> Sampler
-> Context
-> TraceId
-> Text
-> SpanArguments
-> InstrumentationLibrary
-> IO SamplingDecision
shouldSample Sampler
rootSampler Context
ctxt TraceId
tid Text
name SpanArguments
args InstrumentationLibrary
scope
    Just SpanContext
sc ->
      if SpanContext -> Bool
OpenTelemetry.Internal.Trace.Types.isRemote SpanContext
sc
        then
          if TraceFlags -> Bool
isSampled (SpanContext -> TraceFlags
traceFlags SpanContext
sc)
            then Sampler
-> Context
-> TraceId
-> Text
-> SpanArguments
-> InstrumentationLibrary
-> IO SamplingDecision
shouldSample Sampler
remoteParentSampled Context
ctxt TraceId
tid Text
name SpanArguments
args InstrumentationLibrary
scope
            else Sampler
-> Context
-> TraceId
-> Text
-> SpanArguments
-> InstrumentationLibrary
-> IO SamplingDecision
shouldSample Sampler
remoteParentNotSampled Context
ctxt TraceId
tid Text
name SpanArguments
args InstrumentationLibrary
scope
        else
          if TraceFlags -> Bool
isSampled (SpanContext -> TraceFlags
traceFlags SpanContext
sc)
            then Sampler
-> Context
-> TraceId
-> Text
-> SpanArguments
-> InstrumentationLibrary
-> IO SamplingDecision
shouldSample Sampler
localParentSampled Context
ctxt TraceId
tid Text
name SpanArguments
args InstrumentationLibrary
scope
            else Sampler
-> Context
-> TraceId
-> Text
-> SpanArguments
-> InstrumentationLibrary
-> IO SamplingDecision
shouldSample Sampler
localParentNotSampled Context
ctxt TraceId
tid Text
name SpanArguments
args InstrumentationLibrary
scope
shouldSampleComplex (AlwaysRecordSampler Sampler
inner) Context
ctxt TraceId
tid Text
name SpanArguments
args InstrumentationLibrary
scope = do
  decision <- Sampler
-> Context
-> TraceId
-> Text
-> SpanArguments
-> InstrumentationLibrary
-> IO SamplingDecision
shouldSample Sampler
inner Context
ctxt TraceId
tid Text
name SpanArguments
args InstrumentationLibrary
scope
  let !outcome' = case SamplingDecision -> SamplingResult
samplingOutcome SamplingDecision
decision of
        SamplingResult
Drop -> SamplingResult
RecordOnly
        SamplingResult
other -> SamplingResult
other
  pure $! decision {samplingOutcome = outcome'}
shouldSampleComplex (CustomSampler Text
_ Context
-> TraceId
-> Text
-> SpanArguments
-> InstrumentationLibrary
-> IO SamplingDecision
f) Context
ctxt TraceId
tid Text
name SpanArguments
args InstrumentationLibrary
scope = Context
-> TraceId
-> Text
-> SpanArguments
-> InstrumentationLibrary
-> IO SamplingDecision
f Context
ctxt TraceId
tid Text
name SpanArguments
args InstrumentationLibrary
scope
shouldSampleComplex Sampler
AlwaysOnSampler Context
ctxt TraceId
tid Text
name SpanArguments
args InstrumentationLibrary
scope = Sampler
-> Context
-> TraceId
-> Text
-> SpanArguments
-> InstrumentationLibrary
-> IO SamplingDecision
shouldSample Sampler
AlwaysOnSampler Context
ctxt TraceId
tid Text
name SpanArguments
args InstrumentationLibrary
scope
shouldSampleComplex Sampler
AlwaysOffSampler Context
ctxt TraceId
tid Text
name SpanArguments
args InstrumentationLibrary
scope = Sampler
-> Context
-> TraceId
-> Text
-> SpanArguments
-> InstrumentationLibrary
-> IO SamplingDecision
shouldSample Sampler
AlwaysOffSampler Context
ctxt TraceId
tid Text
name SpanArguments
args InstrumentationLibrary
scope
{-# NOINLINE shouldSampleComplex #-}


{- | Get the sampler's description string.

@since 0.0.1.0
-}
getDescription :: Sampler -> Text
getDescription :: Sampler -> Text
getDescription Sampler
AlwaysOnSampler = Text
"AlwaysOnSampler"
getDescription Sampler
AlwaysOffSampler = Text
"AlwaysOffSampler"
getDescription (TraceIdRatioSampler Double
frac Word64
_ Attribute
_) =
  Text
"TraceIdRatioBased{" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> LazyText -> Text
TL.toStrict (Builder -> LazyText
toLazyText (Double -> Builder
forall a. RealFloat a => a -> Builder
realFloat Double
frac)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"}"
getDescription (ParentBasedSampler ParentBasedOptions {Sampler
rootSampler :: ParentBasedOptions -> Sampler
remoteParentSampled :: ParentBasedOptions -> Sampler
remoteParentNotSampled :: ParentBasedOptions -> Sampler
localParentSampled :: ParentBasedOptions -> Sampler
localParentNotSampled :: ParentBasedOptions -> Sampler
rootSampler :: Sampler
remoteParentSampled :: Sampler
remoteParentNotSampled :: Sampler
localParentSampled :: Sampler
localParentNotSampled :: Sampler
..}) =
  Text
"ParentBased{root="
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Sampler -> Text
getDescription Sampler
rootSampler
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", remoteParentSampled="
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Sampler -> Text
getDescription Sampler
remoteParentSampled
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", remoteParentNotSampled="
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Sampler -> Text
getDescription Sampler
remoteParentNotSampled
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", localParentSampled="
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Sampler -> Text
getDescription Sampler
localParentSampled
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", localParentNotSampled="
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Sampler -> Text
getDescription Sampler
localParentNotSampled
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"}"
getDescription (AlwaysRecordSampler Sampler
inner) =
  Text
"AlwaysRecord{" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Sampler -> Text
getDescription Sampler
inner Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"}"
getDescription (CustomSampler Text
desc Context
-> TraceId
-> Text
-> SpanArguments
-> InstrumentationLibrary
-> IO SamplingDecision
_) = Text
desc


{- | Extract the parent's 'SpanContext' from the 'Context', if present.
Pure: 'getSpanContext' on all 'Span' constructors is non-effectful.
-}
parentSpanContext :: Context -> Maybe SpanContext
parentSpanContext :: Context -> Maybe SpanContext
parentSpanContext Context
ctxt = case Context -> Maybe Span
lookupSpan Context
ctxt of
  Maybe Span
Nothing -> Maybe SpanContext
forall a. Maybe a
Nothing
  Just (Span ImmutableSpan
imm) -> SpanContext -> Maybe SpanContext
forall a. a -> Maybe a
Just (ImmutableSpan -> SpanContext
spanContext ImmutableSpan
imm)
  Just (FrozenSpan SpanContext
sc) -> SpanContext -> Maybe SpanContext
forall a. a -> Maybe a
Just SpanContext
sc
  Just (Dropped SpanContext
sc) -> SpanContext -> Maybe SpanContext
forall a. a -> Maybe a
Just SpanContext
sc
{-# INLINE parentSpanContext #-}


-- | Extract the parent's 'TraceState', defaulting to empty.
parentTraceState :: Context -> TraceState
parentTraceState :: Context -> TraceState
parentTraceState Context
ctxt = case Context -> Maybe SpanContext
parentSpanContext Context
ctxt of
  Maybe SpanContext
Nothing -> TraceState
TraceState.empty
  Just SpanContext
sc -> SpanContext -> TraceState
traceState SpanContext
sc
{-# INLINE parentTraceState #-}