{-# LANGUAGE StandaloneDeriving #-}
{-# OPTIONS_GHC -Wno-name-shadowing #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Arbitrary where
import Data.Aeson (toJSON)
import Data.Aeson.Key qualified as Key
import Data.Functor.Syntax ((<$$>), (<&&>))
import Data.List.Extra (nubOrd)
import Data.Scientific
import Data.Text (Text)
import Data.Text qualified as Text
import Effectful.Exception (AssertionFailed (..))
import Effectful.OpenTelemetry.Logging.Severity (Severity)
import Effectful.OpenTelemetry.Metrics.Measurement (AggregationTemporality)
import Effectful.OpenTelemetry.Metrics.Metadata (Metadata (..))
import Effectful.OpenTelemetry.Protocol.AnyValue (AnyValue (..))
import Effectful.OpenTelemetry.Protocol.Attributes (Attributes)
import Effectful.OpenTelemetry.Protocol.Attributes qualified as Attributes
import Effectful.OpenTelemetry.Protocol.Transport (Compression (..))
import Effectful.OpenTelemetry.Timestamp (Timestamp (..))
import Effectful.OpenTelemetry.Tracing.Span.Context
import Effectful.OpenTelemetry.Tracing.Span.Event (Event (..))
import Effectful.OpenTelemetry.Tracing.Span.ID qualified as Span (ID)
import Effectful.OpenTelemetry.Tracing.Span.Kind qualified as Span (Kind)
import Effectful.OpenTelemetry.Tracing.Span.Status qualified as Status (Code)
import Effectful.OpenTelemetry.Tracing.Trace.Flags qualified as Trace (Flags (Flags))
import Effectful.OpenTelemetry.Tracing.Trace.Flags qualified as Trace.Flags
import Effectful.OpenTelemetry.Tracing.Trace.ID qualified as Trace (ID)
import Effectful.OpenTelemetry.Tracing.Trace.State qualified as Trace (State)
import Effectful.OpenTelemetry.Tracing.Trace.State qualified as Trace.State
import Effectful.QuickCheck
import GHC.IsList (fromList)
import System.Random (Random (..))
import Prelude
instance Random Scientific where
random g = (scientific c e, g2)
where
(c, g1) = random g
(e, g2) = random g1
randomR (lo, hi) g = (fromFloatDigits x, g')
where
x :: Double
(x, g') = randomR (toRealFloat lo, toRealFloat hi) g
instance Arbitrary Scientific where
arbitrary = frequency [(70, getSmall <$> arbitrary), (30, getLarge <$> arbitrary)]
shrink s = uncurry scientific <$> shrink (coefficient s, base10Exponent s)
instance {-# OVERLAPPING #-} Arbitrary (NonNegative Scientific) where
arbitrary = NonNegative <$> ((scientific . getNonNegative <$> arbitrary) <*> arbitrary)
instance {-# OVERLAPPING #-} Arbitrary (Positive Scientific) where
arbitrary = Positive <$> ((scientific . getPositive <$> arbitrary) <*> arbitrary)
-- | Integral values in the 'Int' range, floating values in the 'Float' range.
instance {-# OVERLAPPING #-} Arbitrary (Small Scientific) where
arbitrary =
Small
<$> oneof
[ fromIntegral . getSmall <$> (arbitrary :: Gen (Small Int))
, fromFloatDigits <$> (arbitrary :: Gen Float)
]
instance {-# OVERLAPPING #-} Arbitrary (Large Scientific) where
arbitrary = fmap Large $ scientific <$> arbitrary <*> arbitrary
newtype HistogramSamples = HistogramSamples [Scientific]
deriving newtype (Eq)
deriving stock (Show)
instance Arbitrary HistogramSamples where
arbitrary = do
n <- chooseInt (4, 12)
HistogramSamples <$> vectorOf n (getSmall . getPositive <$> arbitrary)
newtype HistogramBounds = HistogramBounds [Scientific]
deriving newtype (Eq)
deriving stock (Show)
instance Arbitrary HistogramBounds where
arbitrary = do
n <- chooseInt (1, 5)
HistogramBounds . nubOrd <$> vectorOf n (getSmall . getPositive <$> arbitrary)
newtype HistogramObservations = HistogramObservations [Scientific]
deriving newtype (Eq)
deriving stock (Show)
instance Arbitrary HistogramObservations where
arbitrary = do
n <- chooseInt (3, 20)
HistogramObservations <$> vectorOf n (getSmall . getPositive <$> arbitrary)
data BucketedObservations = BucketedObservations
{ bounds :: [Scientific]
, observations :: [[Scientific]]
}
deriving stock (Show, Eq)
instance Arbitrary BucketedObservations where
arbitrary = do
lo <- choose (1.0, 50.0)
hi <- choose (lo + 1.0, lo + 500.0)
below <- chooseInt (1, 5)
between <- chooseInt (1, 5)
above <- chooseInt (1, 5)
belowSamples <- vectorOf below $ choose (lo - 100.0, lo - 0.001)
betweenSamples <- vectorOf between $ choose (lo + 0.001, hi - 0.001)
aboveSamples <- vectorOf above $ choose (hi + 0.001, hi + 100.0)
pure
BucketedObservations
{ bounds = [lo, hi]
, observations = [belowSamples, betweenSamples, aboveSamples]
}
data ConcurrentObservation = ConcurrentObservation
{ repeats :: Int
, value :: Scientific
}
deriving stock (Show, Eq)
instance Arbitrary ConcurrentObservation where
arbitrary = do
repeats <- chooseInt (50, 500)
Positive (Small value) <- arbitrary
pure ConcurrentObservation{..}
deriving via String instance Eq AssertionFailed
instance Arbitrary Attributes where
arbitrary = Attributes.fromList <$> resize 5 arbitrary
instance Arbitrary AnyValue where
arbitrary = AnyValue <$> resize 5 arbitrary
instance Arbitrary Text where
arbitrary = Text.pack <$> arbitrary
shrink = fmap Text.pack . shrink . Text.unpack
instance Arbitrary Metadata where
arbitrary = do
attributes <- do
n <- chooseInt (0, 3)
Attributes.fromList <$> vectorOf n do
key <- do
c <- elements $ ['a' .. 'z'] <> ['A' .. 'Z']
Marker rest <- arbitrary
pure . Key.fromText $ Text.cons c rest
Marker (toJSON -> value) <- arbitrary
pure (key, value)
description <- getMarker <$$> arbitrary
unit <- arbitrary <&&> \(Marker u) -> "{" <> u <> "}"
pure Metadata{..}
instance Arbitrary Trace.ID where
arbitrary = chooseAny
instance Arbitrary Span.ID where
arbitrary = chooseAny
instance Arbitrary Span.Kind where
arbitrary = arbitraryBoundedEnum
instance Arbitrary Status.Code where
arbitrary = arbitraryBoundedEnum
instance Arbitrary Compression where
arbitrary = arbitraryBoundedEnum
instance Arbitrary Severity where
arbitrary = arbitraryBoundedEnum
instance Arbitrary AggregationTemporality where
arbitrary = arbitraryBoundedEnum
instance Arbitrary Trace.Flags.Remote where
arbitrary = arbitraryBoundedEnum
instance Arbitrary Trace.Flags where
arbitrary = do
sampled <- arbitrary
random <- arbitrary
remote <- arbitrary
pure Trace.Flags{..}
instance Arbitrary Context where
arbitrary = do
traceId <- arbitrary
spanId <- arbitrary
traceFlags <- arbitrary
traceState <- arbitrary
pure Context{..}
instance Arbitrary Trace.State.Key where
arbitrary = oneof [simpleKey, tenantKey]
where
simpleKey = do
firstChar <- elements ['a' .. 'z']
len <- chooseInt (0, 30)
rest <- vectorOf len genSimpleChar
maybe (error "Simple key generation failed") pure . Trace.State.key $ Text.pack (firstChar : rest)
tenantKey = do
tenant <- boundedSimpleKey 241
system <- boundedSimpleKey 14
maybe (error "Tenant key generation failed") pure . Trace.State.key $ tenant <> "@" <> system
boundedSimpleKey maxLen = do
firstChar <- elements ['a' .. 'z']
len <- chooseInt (0, maxLen - 1)
rest <- vectorOf len genSimpleChar
pure $ Text.pack (firstChar : rest)
genSimpleChar :: Gen Char
genSimpleChar = elements $ ['a' .. 'z'] ++ ['0' .. '9'] ++ ['_', '-', '*', '/']
instance Arbitrary Trace.State.Value where
arbitrary = do
len <- chooseInt (0, 255)
chars <- vectorOf len $ elements [c | c <- ['\x20' .. '\x7E'], c /= ',', c /= '=']
maybe (error "Trace.State.Value generation failed") pure . Trace.State.value $ Text.pack chars
instance Arbitrary Trace.State where
arbitrary = fmap fromList . flip vectorOf arbitrary =<< chooseInt (0, 32)
-- | Small alphanumeric 'Text', good enough for keys, values and names that
-- don't need to exercise anything beyond "some text arrived intact".
newtype Marker = Marker {getMarker :: Text}
deriving newtype (Eq)
deriving stock (Show)
instance Arbitrary Marker where
arbitrary = Marker . Text.pack <$> vectorOf 8 (elements alphabet)
where
alphabet = ['a' .. 'z'] <> ['A' .. 'Z'] <> ['0' .. '9']
newtype MarkerAttributes = MarkerAttributes Attributes
deriving newtype (Eq)
deriving stock (Show)
instance Arbitrary MarkerAttributes where
arbitrary = do
n <- chooseInt (0, 3)
MarkerAttributes . Attributes.fromList <$> vectorOf n do
Marker (Key.fromText -> key) <- arbitrary
Marker (toJSON -> value) <- arbitrary
pure (key, value)
instance Arbitrary Timestamp where
arbitrary = Timestamp <$> arbitrary
instance Arbitrary Event where
arbitrary = do
time <- arbitrary
Marker name <- arbitrary
MarkerAttributes attributes <- arbitrary
pure Event{..}