{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{- |
Module : OpenTelemetry.Utils.Exceptions
Description : Utility for recording exceptions as span events following the OpenTelemetry semantic conventions.
Stability : experimental
-}
module OpenTelemetry.Utils.Exceptions (inSpanM, inSpanM', inSpanM'') where
import Control.Monad (forM_)
import Control.Monad.Catch (MonadMask, SomeException)
import qualified Control.Monad.Catch as MonadMask
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Text (Text)
import qualified Data.Text as T
import GHC.Exception (getCallStack)
import GHC.Stack (CallStack, callStack)
import GHC.Stack.Types (HasCallStack)
import OpenTelemetry.Context (insertSpan, lookupSpan, removeSpan)
import OpenTelemetry.Context.ThreadLocal (adjustContext)
import qualified OpenTelemetry.Context.ThreadLocal as TraceCore.SpanContext
import OpenTelemetry.SemanticsConfig (codeOption, getSemanticsOptions)
import qualified OpenTelemetry.Trace as Trace
import OpenTelemetry.Trace.Core (ToAttribute (..), codeAttributes, endSpan, recordException, setStatus, whenSpanIsRecording)
import qualified OpenTelemetry.Trace.Core as TraceCore
bracketError' :: (MonadMask m) => m a -> (Maybe SomeException -> a -> m b) -> (a -> m c) -> m c
bracketError' before after thing = MonadMask.mask $ \restore -> do
x <- before
res1 <- MonadMask.try $ restore $ thing x
case res1 of
Left (e1 :: SomeException) -> do
-- explicitly ignore exceptions from after. We know that
-- no async exceptions were thrown there, so therefore
-- the stronger exception must come from thing
--
-- https://github.com/fpco/safe-exceptions/issues/2
_ :: Either SomeException b <-
MonadMask.try $ MonadMask.uninterruptibleMask_ $ after (Just e1) x
MonadMask.throwM e1
Right y -> do
MonadMask.uninterruptibleMask_ $ after Nothing x
return y
-- | The simplest function for annotating code with trace information.
inSpanM
:: (MonadIO m, MonadMask m, HasCallStack)
=> Trace.Tracer
-> Text
-- ^ The name of the span. This may be updated later via 'updateName'
-> Trace.SpanArguments
{- ^ Additional options for creating the span, such as 'SpanKind',
span links, starting attributes, etc.
-}
-> m a
{- ^ The action to perform. 'inSpan' will record the time spent on the
action without forcing strict evaluation of the result. Any uncaught
exceptions will be recorded and rethrown.
-}
-> m a
inSpanM t n args m = inSpanM'' t callStack n args (const m)
inSpanM'
:: (MonadIO m, MonadMask m, HasCallStack)
=> Trace.Tracer
-> Text
-- ^ The name of the span. This may be updated later via 'updateName'
-> Trace.SpanArguments
-> (Trace.Span -> m a)
-> m a
inSpanM' t = inSpanM'' t callStack
inSpanM''
:: (MonadMask m, HasCallStack, MonadIO m)
=> Trace.Tracer
-> CallStack
{- ^ Record the location of the span in the codebase using the provided
callstack for source location info.
-}
-> Text
-- ^ The name of the span. This may be updated later via 'updateName'
-> Trace.SpanArguments
-> (Trace.Span -> m a)
-> m a
inSpanM'' t cs n args f = bracketError' before after (f . snd)
where
before = do
ctx <- TraceCore.SpanContext.getContext
s <- TraceCore.createSpanWithoutCallStack t ctx n args
adjustContext (insertSpan s)
whenSpanIsRecording s $ do
case getCallStack cs of
[] -> pure ()
(fn, loc) : _ -> do
opt <- liftIO $ codeOption <$> getSemanticsOptions
TraceCore.addAttributes s (codeAttributes opt fn loc)
pure (lookupSpan ctx, s)
after e (parent, s) = do
forM_ e $ \(MonadMask.SomeException inner) -> do
setStatus s $ Trace.Error $ T.pack $ MonadMask.displayException inner
recordException s [("exception.escaped", toAttribute True)] Nothing inner
endSpan s Nothing
adjustContext $ \ctx ->
maybe (removeSpan ctx) (`insertSpan` ctx) parent