-- | Instrumentation for Hspec test suites
{-# LANGUAGE OverloadedStrings #-}

module OpenTelemetry.Instrumentation.Hspec
  ( wrapSpec,
    wrapExampleInSpan,
  )
where

import Control.Monad.IO.Class
import Control.Monad.Reader
import Data.Text (Text)
import qualified Data.Text as T
import OpenTelemetry.Attributes (Attributes)
import OpenTelemetry.Context
import OpenTelemetry.Context.ThreadLocal (adjustContext, attachContext, getContext)
import OpenTelemetry.Trace.Core
import Test.Hspec.Core.Spec (ActionWith, Item (..), Spec, SpecWith, mapSpecItem_)

-- | Creates a wrapper function that you can pass a spec into.
--
--   This function will wrap each @it@ test case with a span with the name of
--   the test case.
--
--   The context in which this is called determines the parent span of all of
--   the spec items.
wrapSpec :: MonadIO m => m (SpecWith a -> SpecWith a)
wrapSpec :: m (SpecWith a -> SpecWith a)
wrapSpec = do
  TracerProvider
tp <- m TracerProvider
forall (m :: * -> *). MonadIO m => m TracerProvider
getGlobalTracerProvider
  let tracer :: Tracer
tracer = TracerProvider -> InstrumentationLibrary -> TracerOptions -> Tracer
makeTracer TracerProvider
tp InstrumentationLibrary
"hs-opentelemetry-instrumentation-hspec" TracerOptions
tracerOptions
  Context
context <- m Context
forall (m :: * -> *). MonadIO m => m Context
getContext

  -- FIXME: this kind of just dumps everything flat into one span per `it`. We
  -- could possibly do better, e.g. finding the `describe`s and making them into
  -- spans but I am not sure how that would be achieved.
  (SpecWith a -> SpecWith a) -> m (SpecWith a -> SpecWith a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((SpecWith a -> SpecWith a) -> m (SpecWith a -> SpecWith a))
-> (SpecWith a -> SpecWith a) -> m (SpecWith a -> SpecWith a)
forall a b. (a -> b) -> a -> b
$ \SpecWith a
spec -> (Item a -> Item a) -> SpecWith a -> SpecWith a
forall a b. (Item a -> Item b) -> SpecWith a -> SpecWith b
mapSpecItem_ (Tracer -> Context -> Item a -> Item a
forall a. Tracer -> Context -> Item a -> Item a
wrapExampleInSpan Tracer
tracer Context
context) SpecWith a
spec

-- | Wraps one example in a span parented by the specified context, and ensures
--   the thread running the spec item will have a context available.
wrapExampleInSpan :: Tracer -> Context -> Item a -> Item a
wrapExampleInSpan :: Tracer -> Context -> Item a -> Item a
wrapExampleInSpan Tracer
tp Context
traceContext item :: Item a
item@Item {itemExample :: forall a.
Item a
-> Params
-> (ActionWith a -> IO ())
-> ProgressCallback
-> IO Result
itemExample = Params -> (ActionWith a -> IO ()) -> ProgressCallback -> IO Result
ex, itemRequirement :: forall a. Item a -> String
itemRequirement = String
req} =
  Item a
item
    { itemExample :: Params -> (ActionWith a -> IO ()) -> ProgressCallback -> IO Result
itemExample = \Params
params ActionWith a -> IO ()
aroundAction ProgressCallback
pcb -> do
        let aroundAction' :: ActionWith a -> IO ()
aroundAction' ActionWith a
a = do
              -- we need to reattach the context, since we are on a forked thread
              IO (Maybe Context) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe Context) -> IO ()) -> IO (Maybe Context) -> IO ()
forall a b. (a -> b) -> a -> b
$ Context -> IO (Maybe Context)
forall (m :: * -> *). MonadIO m => Context -> m (Maybe Context)
attachContext Context
traceContext
              Tracer -> Text -> SpanArguments -> IO () -> IO ()
forall (m :: * -> *) a.
(MonadUnliftIO m, HasCallStack) =>
Tracer -> Text -> SpanArguments -> m a -> m a
inSpan Tracer
tp (String -> Text
T.pack String
req) SpanArguments
defaultSpanArguments (ActionWith a -> IO ()
aroundAction ActionWith a
a)

        Params -> (ActionWith a -> IO ()) -> ProgressCallback -> IO Result
ex Params
params ActionWith a -> IO ()
aroundAction' ProgressCallback
pcb
    }