hs-opentelemetry-utils-exceptions (empty) → 0.1.0.0

raw patch · 7 files changed

+202/−0 lines, 7 filesdep +basedep +exceptionsdep +hs-opentelemetry-apisetup-changed

Dependencies added: base, exceptions, hs-opentelemetry-api, hs-opentelemetry-sdk, text

Files

ChangeLog.md +3/−0
LICENSE +30/−0
README.md +6/−0
Setup.hs +2/−0
hs-opentelemetry-utils-exceptions.cabal +55/−0
src/OpenTelemetry/Utils/Exceptions.hs +104/−0
test/Spec.hs +2/−0

+ ChangeLog.md view

@@ -0,0 +1,3 @@+# Changelog for exceptions++## Unreleased changes

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright Ian Duncan (c) 2022++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Ian Duncan nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ README.md view

@@ -0,0 +1,6 @@+# 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.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ hs-opentelemetry-utils-exceptions.cabal view

@@ -0,0 +1,55 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.34.5.+--+-- see: https://github.com/sol/hpack++name:           hs-opentelemetry-utils-exceptions+version:        0.1.0.0+description:    Please see the README on GitHub at <https://github.com/iand675/hs-opentelemetry/tree/main/utils/exceptions#readme>+homepage:       https://github.com/iand675/hs-opentelemetry#readme+bug-reports:    https://github.com/iand675/hs-opentelemetry/issues+author:         Ian Duncan+maintainer:     ian@iankduncan.com+copyright:      2021 Ian Duncan+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+  type: git+  location: https://github.com/iand675/hs-opentelemetry++library+  exposed-modules:+      OpenTelemetry.Utils.Exceptions+  other-modules:+      Paths_hs_opentelemetry_utils_exceptions+  hs-source-dirs:+      src+  build-depends:+      base >=4.7 && <5+    , exceptions+    , hs-opentelemetry-api ==0.0.3.*+    , hs-opentelemetry-sdk ==0.0.3.*+    , text+  default-language: Haskell2010++test-suite exceptions-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_hs_opentelemetry_utils_exceptions+  hs-source-dirs:+      test+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.7 && <5+    , exceptions+    , hs-opentelemetry-api ==0.0.3.*+    , hs-opentelemetry-sdk ==0.0.3.*+    , text+  default-language: Haskell2010

+ src/OpenTelemetry/Utils/Exceptions.hs view

@@ -0,0 +1,104 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++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 Data.Text (Text)+import qualified Data.Text as T+import GHC.Exception (SrcLoc (..), 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 qualified OpenTelemetry.Trace as Trace+import OpenTelemetry.Trace.Core (ToAttribute (..), 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 ->+  -- | The name of the span. This may be updated later via 'updateName'+  Text ->+  -- | Additional options for creating the span, such as 'SpanKind',+  -- span links, starting attributes, etc.+  Trace.SpanArguments ->+  -- | 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 ->+  m a+inSpanM t n args m = inSpanM'' t callStack n args (const m)++inSpanM' ::+  (MonadIO m, MonadMask m, HasCallStack) =>+  Trace.Tracer ->+  -- | The name of the span. This may be updated later via 'updateName'+  Text ->+  Trace.SpanArguments ->+  (Trace.Span -> m a) ->+  m a+inSpanM' t = inSpanM'' t callStack++inSpanM'' ::+  (MonadMask m, HasCallStack, MonadIO m) =>+  Trace.Tracer ->+  -- | Record the location of the span in the codebase using the provided+  -- callstack for source location info.+  CallStack ->+  -- | The name of the span. This may be updated later via 'updateName'+  Text ->+  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+            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)+              ]+      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 [] Nothing inner+      endSpan s Nothing+      adjustContext $ \ctx ->+        maybe (removeSpan ctx) (`insertSpan` ctx) parent

+ test/Spec.hs view

@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"