{-# LANGUAGE OverloadedStrings #-}
module OpenTelemetry.Instrumentation.Hspec (
wrapSpec,
wrapExampleInSpan,
instrumentSpec,
) where
import Control.Monad (void)
import Control.Monad.IO.Class
import Control.Monad.Reader
import qualified Data.List as List
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, Tree (..), mapSpecForest, mapSpecItem_)
wrapSpec :: (MonadIO m) => m (SpecWith a -> SpecWith a)
wrapSpec :: forall (m :: * -> *) a. MonadIO m => m (SpecWith a -> SpecWith a)
wrapSpec = do
TracerProvider
tp <- 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 <- forall (m :: * -> *). MonadIO m => m Context
getContext
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ \SpecWith a
spec -> forall a b. (Item a -> Item b) -> SpecWith a -> SpecWith b
mapSpecItem_ (forall a. Tracer -> Context -> Item a -> Item a
wrapExampleInSpan Tracer
tracer Context
context) SpecWith a
spec
wrapExampleInSpan :: Tracer -> Context -> Item a -> Item a
wrapExampleInSpan :: forall a. 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
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadIO m => Context -> m (Maybe Context)
attachContext Context
traceContext
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
}
instrumentSpec :: Tracer -> Context -> SpecWith a -> SpecWith a
instrumentSpec :: forall a. Tracer -> Context -> SpecWith a -> SpecWith a
instrumentSpec Tracer
tracer Context
traceContext SpecWith a
spec = do
forall a b r.
([SpecTree a] -> [SpecTree b]) -> SpecM a r -> SpecM b r
mapSpecForest (forall a b. (a -> b) -> [a] -> [b]
map (forall {c} {a}. [String] -> Tree c (Item a) -> Tree c (Item a)
go [])) SpecWith a
spec
where
go :: [String] -> Tree c (Item a) -> Tree c (Item a)
go [String]
spans Tree c (Item a)
t = case Tree c (Item a)
t of
Node String
str [Tree c (Item a)]
rest ->
forall c a. String -> [Tree c a] -> Tree c a
Node String
str (forall a b. (a -> b) -> [a] -> [b]
map ([String] -> Tree c (Item a) -> Tree c (Item a)
go (String
str forall a. a -> [a] -> [a]
: [String]
spans)) [Tree c (Item a)]
rest)
NodeWithCleanup Maybe (String, Location)
mloc c
c [Tree c (Item a)]
rest ->
forall c a. Maybe (String, Location) -> c -> [Tree c a] -> Tree c a
NodeWithCleanup Maybe (String, Location)
mloc c
c (forall a b. (a -> b) -> [a] -> [b]
map ([String] -> Tree c (Item a) -> Tree c (Item a)
go [String]
spans) [Tree c (Item a)]
rest)
Leaf Item a
item ->
forall c a. a -> Tree c a
Leaf
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
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadIO m => Context -> m (Maybe Context)
attachContext Context
traceContext
forall {t :: * -> *} {m :: * -> *} {a}.
(Foldable t, MonadUnliftIO m) =>
t String -> m a -> m a
addSpans [String]
spans forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadUnliftIO m, HasCallStack) =>
Tracer -> Text -> SpanArguments -> m a -> m a
inSpan Tracer
tracer (String -> Text
T.pack (forall a. Item a -> String
itemRequirement Item a
item)) SpanArguments
defaultSpanArguments (ActionWith a -> IO ()
aroundAction ActionWith a
a)
forall a.
Item a
-> Params
-> (ActionWith a -> IO ())
-> ProgressCallback
-> IO Result
itemExample Item a
item Params
params ActionWith a -> IO ()
aroundAction' ProgressCallback
pcb
}
addSpans :: t String -> m a -> m a
addSpans t String
spans m a
k =
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' (\m a
acc String
x -> forall (m :: * -> *) a.
(MonadUnliftIO m, HasCallStack) =>
Tracer -> Text -> SpanArguments -> m a -> m a
inSpan Tracer
tracer (String -> Text
T.pack String
x) SpanArguments
defaultSpanArguments m a
acc) m a
k t String
spans