diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # Changelog for exceptions +## 1.0.0.0 - 2026-05-29 + +- Promoted to 1.0.0.0 for the hs-opentelemetry 1.0 release. + ## 0.2.0.2 - Relax `hs-opentelemetry-api` bounds to support 0.3.x diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright Ian Duncan (c) 2022 +Copyright Ian Duncan (c) 2022-2026 All rights reserved. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,6 +1,7 @@ -# OpenTelemetry Utils Exceptions +# OpenTelemetry Utilities for Haskell Exceptions +[![hs-opentelemetry-utils-exceptions](https://img.shields.io/hackage/v/hs-opentelemetry-utils-exceptions?style=flat-square&logo=haskell&label=hs-opentelemetry-utils-exceptions&labelColor=5D4F85)](https://hackage.haskell.org/package/hs-opentelemetry-utils-exceptions) + This package provides utilities for using OpenTelemetry with the `exceptions` package. -See https://github.com/yesodweb/yesod/issues/1533 for discussion on some subtle issues that may -arise from using MonadMask. +See https://github.com/yesodweb/yesod/issues/1533 for discussion on some subtle issues that may arise from using `MonadMask`. diff --git a/hs-opentelemetry-utils-exceptions.cabal b/hs-opentelemetry-utils-exceptions.cabal --- a/hs-opentelemetry-utils-exceptions.cabal +++ b/hs-opentelemetry-utils-exceptions.cabal @@ -1,20 +1,22 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.37.0. +-- This file has been generated from package.yaml by hpack version 0.38.3. -- -- see: https://github.com/sol/hpack -name: hs-opentelemetry-utils-exceptions -version: 0.2.0.2 -description: Please see the README on GitHub at -homepage: https://github.com/iand675/hs-opentelemetry#readme -bug-reports: https://github.com/iand675/hs-opentelemetry/issues -author: Ian Duncan, Jade Lovelace -maintainer: ian@iankduncan.com -copyright: 2024 Ian Duncan, Mercury Technologies -license: BSD3 -license-file: LICENSE -build-type: Simple +name: hs-opentelemetry-utils-exceptions +version: 1.0.0.0 +synopsis: Exception utilities for OpenTelemetry instrumentation +description: Please see the README on GitHub at +category: OpenTelemetry, Telemetry, Error Handling +homepage: https://github.com/iand675/hs-opentelemetry#readme +bug-reports: https://github.com/iand675/hs-opentelemetry/issues +author: Ian Duncan, Jade Lovelace +maintainer: ian@iankduncan.com +copyright: 2024 Ian Duncan, Mercury Technologies +license: BSD3 +license-file: LICENSE +build-type: Simple extra-source-files: README.md ChangeLog.md @@ -33,8 +35,8 @@ build-depends: base >=4.7 && <5 , exceptions - , hs-opentelemetry-api ==0.3.* - , hs-opentelemetry-sdk ==0.1.* + , hs-opentelemetry-api ==1.0.* + , hs-opentelemetry-sdk ==1.0.* , text default-language: Haskell2010 @@ -48,4 +50,10 @@ ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: base >=4.7 && <5 + , hs-opentelemetry-api ==1.0.* + , hs-opentelemetry-exporter-in-memory ==1.0.* + , hs-opentelemetry-sdk ==1.0.* + , hs-opentelemetry-utils-exceptions ==1.0.* + , hspec + , text default-language: Haskell2010 diff --git a/src/OpenTelemetry/Utils/Exceptions.hs b/src/OpenTelemetry/Utils/Exceptions.hs --- a/src/OpenTelemetry/Utils/Exceptions.hs +++ b/src/OpenTelemetry/Utils/Exceptions.hs @@ -2,22 +2,28 @@ {-# 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) +import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Text (Text) import qualified Data.Text as T -import GHC.Exception (SrcLoc (..), getCallStack) +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 (..), endSpan, recordException, setStatus, whenSpanIsRecording) +import OpenTelemetry.Trace.Core (ToAttribute (..), codeAttributes, endSpan, recordException, setStatus, whenSpanIsRecording) import qualified OpenTelemetry.Trace.Core as TraceCore @@ -47,12 +53,14 @@ -> 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. + {- ^ 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. + {- ^ 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) @@ -72,8 +80,9 @@ :: (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. + {- ^ 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 @@ -89,14 +98,8 @@ case getCallStack cs of [] -> pure () (fn, loc) : _ -> do - TraceCore.addAttributes - s - [ ("code.function", toAttribute $ T.pack fn) - , ("code.namespace", toAttribute $ T.pack $ srcLocModule loc) - , ("code.filepath", toAttribute $ T.pack $ srcLocFile loc) - , ("code.lineno", toAttribute $ srcLocStartLine loc) - , ("code.package", toAttribute $ T.pack $ srcLocPackage loc) - ] + opt <- liftIO $ codeOption <$> getSemanticsOptions + TraceCore.addAttributes s (codeAttributes opt fn loc) pure (lookupSpan ctx, s) after e (parent, s) = do diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,3 +1,109 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Main where + +import Control.Exception (IOException, throwIO, try) +import Control.Monad (filterM) +import Data.IORef +import Data.Text (Text) +import OpenTelemetry.Attributes (Attributes, lookupAttribute) +import OpenTelemetry.Attributes.Attribute (Attribute (..), PrimitiveAttribute (..)) +import OpenTelemetry.Exporter.InMemory.Span (inMemoryListExporter) +import OpenTelemetry.Trace.Core +import OpenTelemetry.Utils.Exceptions +import Test.Hspec + + main :: IO () -main = putStrLn "Test suite not yet implemented" +main = hspec spec + + +withTracer :: (Tracer -> IO a) -> IO ([ImmutableSpan], a) +withTracer action = do + (processor, ref) <- inMemoryListExporter + tp <- createTracerProvider [processor] emptyTracerProviderOptions + let tracer = makeTracer tp "test-exceptions" tracerOptions + result <- action tracer + _ <- shutdownTracerProvider tp Nothing + spans <- readIORef ref + pure (spans, result) + + +firstSpan :: [ImmutableSpan] -> ImmutableSpan +firstSpan (s : _) = s +firstSpan [] = error "No spans recorded" + + +getSpanName :: ImmutableSpan -> IO Text +getSpanName s = hotName <$> readIORef (spanHot s) + + +getSpanStatus :: ImmutableSpan -> IO SpanStatus +getSpanStatus s = hotStatus <$> readIORef (spanHot s) + + +getSpanAttrs :: ImmutableSpan -> IO Attributes +getSpanAttrs s = hotAttributes <$> readIORef (spanHot s) + + +spec :: Spec +spec = describe "OpenTelemetry.Utils.Exceptions" $ do + describe "inSpanM" $ do + it "creates a span with the given name" $ do + (spans, _) <- withTracer $ \t -> + inSpanM t "test-operation" defaultSpanArguments (pure ()) + name <- getSpanName (firstSpan spans) + name `shouldBe` "test-operation" + + it "returns the action's result" $ do + (_, result) <- withTracer $ \t -> + inSpanM t "compute" defaultSpanArguments (pure (42 :: Int)) + result `shouldBe` 42 + + it "records exception and rethrows on failure" $ do + (spans, result) <- withTracer $ \t -> do + r <- + try $ + inSpanM t "failing" defaultSpanArguments $ + throwIO (userError "boom") + pure (r :: Either IOException ()) + case result of + Left _ -> pure () + Right _ -> expectationFailure "expected exception" + let s = firstSpan spans + status <- getSpanStatus s + status `shouldBe` Error "user error (boom)" + + it "sets code.function attribute from callstack" $ do + (spans, _) <- withTracer $ \t -> + inSpanM t "traced" defaultSpanArguments (pure ()) + let s = firstSpan spans + attrs <- getSpanAttrs s + lookupAttribute attrs "code.function" + `shouldSatisfy` (/= Nothing) + + describe "inSpanM'" $ do + it "provides the span to the callback" $ do + spanRef <- newIORef (Nothing :: Maybe Span) + (spans, _) <- withTracer $ \t -> + inSpanM' t "with-span" defaultSpanArguments $ \s -> do + writeIORef spanRef (Just s) + addAttribute s ("custom.attr" :: Text) ("hello" :: Text) + let s = firstSpan spans + attrs <- getSpanAttrs s + lookupAttribute attrs "custom.attr" + `shouldBe` Just (AttributeValue (TextAttribute "hello")) + + describe "inSpanM''" $ do + it "restores parent context after span ends" $ do + (spans, _) <- withTracer $ \t -> do + inSpanM t "outer" defaultSpanArguments $ do + inSpanM t "inner" defaultSpanArguments (pure ()) + length spans `shouldSatisfy` (>= 2) + innerSpans <- filterM (\s -> (== "inner") <$> getSpanName s) spans + case innerSpans of + [] -> expectationFailure "no span named 'inner'" + (inner : _) -> case spanParent inner of + Nothing -> expectationFailure "expected inner span to have a parent" + Just _ -> pure ()