{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}

module OpenTelemetry.Instrumentation.Conduit where

import Conduit
import Control.Exception (SomeException, throwIO)
import Data.Text (Text)
import GHC.Stack (HasCallStack)
import OpenTelemetry.Context.ThreadLocal
import OpenTelemetry.Trace.Core hiding (getTracer)


inSpan
  :: (MonadResource m, MonadUnliftIO m, HasCallStack)
  => Tracer
  -> Text
  -> SpanArguments
  -> (Span -> ConduitM i o m a)
  -> ConduitM i o m a
inSpan :: forall (m :: * -> *) i o a.
(MonadResource m, MonadUnliftIO m, HasCallStack) =>
Tracer
-> Text
-> SpanArguments
-> (Span -> ConduitM i o m a)
-> ConduitM i o m a
inSpan Tracer
t Text
n SpanArguments
args Span -> ConduitM i o m a
f = do
  Context
ctx <- m Context -> ConduitT i o m Context
forall (m :: * -> *) a. Monad m => m a -> ConduitT i o m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Context
forall (m :: * -> *). MonadIO m => m Context
getContext
  IO Span
-> (Span -> IO ())
-> (Span -> ConduitM i o m a)
-> ConduitM i o m a
forall (m :: * -> *) a i o r.
MonadResource m =>
IO a -> (a -> IO ()) -> (a -> ConduitT i o m r) -> ConduitT i o m r
bracketP
    (Tracer -> Context -> Text -> SpanArguments -> IO Span
forall (m :: * -> *).
MonadIO m =>
Tracer -> Context -> Text -> SpanArguments -> m Span
createSpanWithoutCallStack Tracer
t Context
ctx Text
n (SpanArguments -> IO Span) -> SpanArguments -> IO Span
forall a b. (a -> b) -> a -> b
$ HashMap Text Attribute -> SpanArguments -> SpanArguments
addAttributesToSpanArguments HashMap Text Attribute
HasCallStack => HashMap Text Attribute
callerAttributes SpanArguments
args)
    (Span -> Maybe Timestamp -> IO ()
forall (m :: * -> *). MonadIO m => Span -> Maybe Timestamp -> m ()
`endSpan` Maybe Timestamp
forall a. Maybe a
Nothing)
    ((Span -> ConduitM i o m a) -> ConduitM i o m a)
-> (Span -> ConduitM i o m a) -> ConduitM i o m a
forall a b. (a -> b) -> a -> b
$ \Span
span_ -> do
      ConduitM i o m a
-> (SomeException -> ConduitM i o m a) -> ConduitM i o m a
forall (m :: * -> *) e i o r.
(MonadUnliftIO m, Exception e) =>
ConduitT i o m r -> (e -> ConduitT i o m r) -> ConduitT i o m r
catchC (Span -> ConduitM i o m a
f Span
span_) ((SomeException -> ConduitM i o m a) -> ConduitM i o m a)
-> (SomeException -> ConduitM i o m a) -> ConduitM i o m a
forall a b. (a -> b) -> a -> b
$ \SomeException
e -> do
        IO a -> ConduitM i o m a
forall a. IO a -> ConduitT i o m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> ConduitM i o m a) -> IO a -> ConduitM i o m a
forall a b. (a -> b) -> a -> b
$ do
          Span
-> HashMap Text Attribute
-> Maybe Timestamp
-> SomeException
-> IO ()
forall (m :: * -> *) e.
(MonadIO m, Exception e) =>
Span -> HashMap Text Attribute -> Maybe Timestamp -> e -> m ()
recordException Span
span_ [(Text
"exception.escaped", Bool -> Attribute
forall a. ToAttribute a => a -> Attribute
toAttribute Bool
True)] Maybe Timestamp
forall a. Maybe a
Nothing (SomeException
e :: SomeException)
          SomeException -> IO a
forall e a. Exception e => e -> IO a
throwIO SomeException
e