Set exception details when using WAI and Yesod instrumentation together

instrumentation/yesod/src/OpenTelemetry/Instrumentation/Yesod.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE TemplateHaskell #-}
@@ -22,6 +23,7 @@ module OpenTelemetry.Instrumentation.Yesod (
   handlerEnvL,
 ) where
 
+import Control.Monad (when)
 import qualified Data.HashMap.Strict as H
 import Data.List (intercalate)
 import Data.Maybe (catMaybes)
@@ -32,8 +34,6 @@ import Language.Haskell.TH.Syntax
 import Lens.Micro
 import Network.Wai (requestHeaders)
 import qualified OpenTelemetry.Context as Context
-import OpenTelemetry.Context.ThreadLocal
-import OpenTelemetry.Contrib.SpanTraversals
 import OpenTelemetry.Instrumentation.Wai (requestContext)
 import OpenTelemetry.SemanticsConfig
 import OpenTelemetry.Trace.Core hiding (inSpan, inSpan', inSpan'')
@@ -57,7 +57,7 @@ rheSiteL = lens rheSite (\rhe new -> rhe {rheSite = new})
 instance MonadTracer (HandlerFor site) where
   getTracer = do
     tp <- getGlobalTracerProvider
-    OpenTelemetry.Trace.Core.getTracer tp "hs-opentelemetry-instrumentation-yesod" tracerOptions
+    pure $ makeTracer tp "hs-opentelemetry-instrumentation-yesod" tracerOptions
 
 
 {- | Template Haskell to generate a function named routeToRendererFunction.
@@ -181,11 +181,9 @@ renderPattern FlatResource {..} =
           pieces -> pieces
       , case frDispatch of
           Methods {..} ->
-            concat
-              [ case methodsMulti of
-                  Nothing -> []
-                  Just t -> ["/+", t]
-              ]
+            case methodsMulti of
+              Nothing -> []
+              Just t -> ["/+", t]
           Subsite {} -> []
       ]
   where
@@ -249,18 +247,29 @@ openTelemetryYesodMiddleware rr m = do
           }
   case mspan of
     Nothing -> do
-      eResult <- inSpan' (maybe "notFound" (\r -> nameRender rr r) mr) args $ \_s -> do
+      eResult <- inSpan' (maybe "notFound" (nameRender rr) mr) args $ \_s -> do
         catch (Right <$> m) $ \e -> do
-          -- We want to mark the span as an error if it's an InternalError,
-          -- the other HCError values are 4xx status codes which don't
-          -- really count as a server error in OpenTelemetry spec parlance.
-          case e of
-            HCError (InternalError _) -> throwIO e
-            _ -> pure ()
+          when (isInternalError e) $ throwIO e
           pure (Left (e :: HandlerContents))
       case eResult of
         Left hc -> throwIO hc
         Right normal -> pure normal
     Just waiSpan -> do
       addAttributes waiSpan sharedAttributes
-      m
+      withException m $ \ex -> do
+        when (shouldMarkException ex) $ do
+          recordException waiSpan mempty Nothing ex
+          setStatus waiSpan $ Error $ T.pack $ displayException ex
+
+
+shouldMarkException :: SomeException -> Bool
+shouldMarkException = maybe True isInternalError . fromException
+
+
+-- We want to mark the span as an error if it's an InternalError, the other
+-- HCError values are 4xx status codes which don't really count as a server
+-- error in OpenTelemetry spec parlance.
+isInternalError :: HandlerContents -> Bool
+isInternalError = \case
+  HCError (InternalError _) -> True
+  _ -> False