Merge remote-tracking branch 'upstream/main' into yesod-subsite

.github/workflows/haskell.yml

@@ -94,4 +94,6 @@ jobs:
     runs-on: ubuntu-latest
     steps:
       - uses: actions/checkout@v2
-      - uses: fourmolu/fourmolu-action@v6
+      - uses: fourmolu/fourmolu-action@v9
+        with:
+          version: "0.13.1.0"

Makefile

@@ -37,6 +37,7 @@ build.all.stack-9.2:
 build.all.cabal-9.0:
 	cabal build --jobs --enable-tests --enable-benchmarks all
 
+# format requires fourmolu 0.13.1.0 or later
 .PHONY: format
 format:
 	fourmolu --mode inplace $$(git ls-files | grep -E "\.hs$$")

README.md

@@ -43,6 +43,7 @@ Fully instrumented application examples are available in the [examples](examples
 | yesod-core        | [hs-opentelemetry-instrumentation-yesod](instrumentation/yesod)                         |
 | persistent        | [hs-opentelemetry-instrumentation-persistent](instrumentation/persistent)               |
 | esqueleto         | [hs-opentelemetry-instrumentation-persistent](instrumentation/persistent)               |
+| persistent-mysql  | [hs-opentelemetry-instrumentation-persistent-mysql](instrumentation/persistent-mysql)   |
 | postgresql-simple | [hs-opentelemetry-instrumentation-postgresql-simple](instrumentation/postgresql-simple) |
 | http-client       | [hs-opentelemetry-instrumentation-http-client](instrumentation/http-client)             |
 | http-conduit      | [hs-opentelemetry-instrumentation-http-client](instrumentation/http-client)             |

api/ChangeLog.md

@@ -1,5 +1,11 @@
 # Changelog for hs-opentelemetry-api
 
+## Unreleased changes
+
+### Breaking changes
+
+- Use `HashMap Text Attribute` instead of `[(Text, Attribute)]` as attributes
+
 ## 0.0.3.6
 
 - GHC 9.4 support
@@ -23,5 +29,3 @@
 ## 0.0.1.0
 
 - Initial release
-
-## Unreleased changes

api/hs-opentelemetry-api.cabal

@@ -5,7 +5,7 @@ cabal-version: 1.12
 -- see: https://github.com/sol/hpack
 
 name:           hs-opentelemetry-api
-version:        0.0.3.6
+version:        0.1.0.0
 synopsis:       OpenTelemetry API for use by libraries for direct instrumentation or wrapper packages.
 description:    Please see the README on GitHub at <https://github.com/iand675/hs-opentelemetry/tree/main/api#readme>
 category:       OpenTelemetry, Telemetry, Monitoring, Observability, Metrics

api/package.yaml

@@ -1,7 +1,7 @@
 _common/lib: !include "../package-common.yaml"
 
 name:                hs-opentelemetry-api
-version:             0.0.3.6
+version:             0.1.0.0
 
 <<: *preface
 

api/src/OpenTelemetry/Attributes.hs

@@ -7,10 +7,6 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE StrictData #-}
 
------------------------------------------------------------------------------
-
------------------------------------------------------------------------------
-
 {- |
  Module      :  OpenTelemetry.Attributes
  Copyright   :  (c) Ian Duncan, 2021
@@ -49,15 +45,14 @@ module OpenTelemetry.Attributes (
   unsafeMergeAttributesIgnoringLimits,
 ) where
 
-import Data.Data
+import Data.Data (Data)
 import qualified Data.HashMap.Strict as H
-import Data.Hashable
+import Data.Hashable (Hashable)
 import Data.Int (Int64)
-import Data.List (foldl')
-import Data.String
+import Data.String (IsString (..))
 import Data.Text (Text)
 import qualified Data.Text as T
-import GHC.Generics
+import GHC.Generics (Generic)
 
 
 {- | Default attribute limits used in the global attribute limit configuration if no environment variables are set.
@@ -95,29 +90,34 @@ addAttribute AttributeLimits {..} Attributes {..} !k !v = case attributeCountLim
       then Attributes attributes attributesCount (attributesDropped + 1)
       else Attributes newAttrs newCount attributesDropped
   where
-    newAttrs = H.insert k (limitLengths $ toAttribute v) attributes
-    newCount =
-      if H.member k attributes
-        then attributesCount
-        else attributesCount + 1
-
-    limitPrimAttr limit_ (TextAttribute t) = TextAttribute (T.take limit_ t)
-    limitPrimAttr _ attr = attr
-
-    limitLengths attr = case attributeLengthLimit of
-      Nothing -> attr
-      Just limit_ -> case attr of
-        AttributeValue val -> AttributeValue $ limitPrimAttr limit_ val
-        AttributeArray arr -> AttributeArray $ fmap (limitPrimAttr limit_) arr
+    newAttrs = H.insert k (maybe id limitLengths attributeCountLimit $ toAttribute v) attributes
+    newCount = H.size newAttrs
 {-# INLINE addAttribute #-}
 
 
-addAttributes :: ToAttribute a => AttributeLimits -> Attributes -> [(Text, a)] -> Attributes
--- TODO, this could be done more efficiently
-addAttributes limits = foldl' (\(!attrs') (!k, !v) -> addAttribute limits attrs' k v)
+addAttributes :: (ToAttribute a) => AttributeLimits -> Attributes -> H.HashMap Text a -> Attributes
+addAttributes AttributeLimits {..} Attributes {..} attrs = case attributeCountLimit of
+  Nothing -> Attributes newAttrs newCount attributesDropped
+  Just limit_ ->
+    if newCount > limit_
+      then Attributes attributes attributesCount (attributesDropped + H.size attrs)
+      else Attributes newAttrs newCount attributesDropped
+  where
+    newAttrs = H.union attributes $ H.map toAttribute attrs
+    newCount = H.size newAttrs
 {-# INLINE addAttributes #-}
 
 
+limitPrimAttr :: Int -> PrimitiveAttribute -> PrimitiveAttribute
+limitPrimAttr limit (TextAttribute t) = TextAttribute (T.take limit t)
+limitPrimAttr _ attr = attr
+
+
+limitLengths :: Int -> Attribute -> Attribute
+limitLengths limit (AttributeValue val) = AttributeValue $ limitPrimAttr limit val
+limitLengths limit (AttributeArray arr) = AttributeArray $ fmap (limitPrimAttr limit) arr
+
+
 getAttributes :: Attributes -> (Int, H.HashMap Text Attribute)
 getAttributes Attributes {..} = (attributesCount, attributes)
 

api/src/OpenTelemetry/Internal/Trace/Types.hs

@@ -12,6 +12,7 @@ import Control.Exception (SomeException)
 import Control.Monad.IO.Class
 import Data.Bits
 import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as H
 import Data.Hashable (Hashable)
 import Data.IORef (IORef, readIORef)
 import Data.String (IsString (..))
@@ -179,7 +180,7 @@ This is not the case in scatter/gather and batch scenarios.
 data NewLink = NewLink
   { linkContext :: !SpanContext
   -- ^ @SpanContext@ of the @Span@ to link to.
-  , linkAttributes :: [(Text, Attribute)]
+  , linkAttributes :: H.HashMap Text Attribute
   -- ^ Zero or more Attributes further describing the link.
   }
   deriving (Show)
@@ -220,7 +221,7 @@ data SpanArguments = SpanArguments
   { kind :: SpanKind
   -- ^ The kind of the span. See 'SpanKind's documentation for the semantics
   -- of the various values that may be specified.
-  , attributes :: [(Text, Attribute)]
+  , attributes :: H.HashMap Text Attribute
   -- ^ An initial set of attributes that may be set on initial 'Span' creation.
   -- These attributes are provided to 'Processor's, so they may be useful in some
   -- scenarios where calling `addAttribute` or `addAttributes` is too late.
@@ -467,7 +468,7 @@ newtype NonRecordingSpan = NonRecordingSpan SpanContext
 data NewEvent = NewEvent
   { newEventName :: Text
   -- ^ The name of an event. Ideally this should be a relatively unique, but low cardinality value.
-  , newEventAttributes :: [(Text, Attribute)]
+  , newEventAttributes :: H.HashMap Text Attribute
   -- ^ Additional context or metadata related to the event, (stack traces, callsites, etc.).
   , newEventTimestamp :: Maybe Timestamp
   -- ^ The time that the event occurred.
@@ -518,7 +519,7 @@ data SamplingResult
 data Sampler = Sampler
   { getDescription :: Text
   -- ^ Returns the sampler name or short description with the configuration. This may be displayed on debug pages or in the logs.
-  , shouldSample :: Context -> TraceId -> Text -> SpanArguments -> IO (SamplingResult, [(Text, Attribute)], TraceState)
+  , shouldSample :: Context -> TraceId -> Text -> SpanArguments -> IO (SamplingResult, H.HashMap Text Attribute, TraceState)
   }
 
 

api/src/OpenTelemetry/Trace/Core.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
@@ -145,6 +146,7 @@ import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.IO.Unlift
 import Data.Coerce
+import qualified Data.HashMap.Strict as H
 import Data.IORef
 import Data.Maybe (fromMaybe, isJust, isNothing)
 import Data.Text (Text)
@@ -203,18 +205,21 @@ createSpan t c n args = do
   createSpanWithoutCallStack t c n $ case getCallStack callStack of
     [] -> args
     (_, loc) : rest ->
-      let addFunction = case rest of
-            (fn, _) : _ -> (("code.function", toAttribute $ T.pack fn) :)
-            [] -> id
-       in args
-            { attributes =
-                addFunction $
-                  ("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)
-                    : attributes args
-            }
+      args
+        { attributes =
+            H.unions
+              [
+                [ ("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)
+                ]
+              , case rest of
+                  (fn, _) : _ -> [("code.function", toAttribute $ T.pack fn)]
+                  [] -> []
+              , attributes args
+              ]
+        }
 
 
 -- | The same thing as 'createSpan', except that it does not have a 'HasCallStack' constraint.
@@ -283,7 +288,7 @@ createSpanWithoutCallStack t ctxt n args@SpanArguments {..} = liftIO $ do
                         A.addAttributes
                           (limitBy t spanAttributeCountLimit)
                           emptyAttributes
-                          (concat [additionalInfo, attrs, attributes])
+                          (H.unions [additionalInfo, attrs, attributes])
                     , spanLinks =
                         let limitedLinks = fromMaybe 128 (linkCountLimit $ tracerProviderSpanLimits $ tracerProvider t)
                          in frozenBoundedCollection limitedLinks $ fmap freezeLink links
@@ -446,7 +451,7 @@ addAttribute (Dropped _) _ _ = pure ()
 
  @since 0.0.1.0
 -}
-addAttributes :: MonadIO m => Span -> [(Text, A.Attribute)] -> m ()
+addAttributes :: (MonadIO m) => Span -> H.HashMap Text A.Attribute -> m ()
 addAttributes (Span s) attrs = liftIO $ modifyIORef' s $ \(!i) ->
   i
     { spanAttributes =
@@ -490,7 +495,7 @@ addEvent (Dropped _) _ = pure ()
 
  @since 0.0.1.0
 -}
-setStatus :: MonadIO m => Span -> SpanStatus -> m ()
+setStatus :: (MonadIO m) => Span -> SpanStatus -> m ()
 setStatus (Span s) st = liftIO $ modifyIORef' s $ \(!i) ->
   i
     { spanStatus =
@@ -558,19 +563,20 @@ endSpan (Dropped _) _ = pure ()
 
  @since 0.0.1.0
 -}
-recordException :: (MonadIO m, Exception e) => Span -> [(Text, Attribute)] -> Maybe Timestamp -> e -> m ()
+recordException :: (MonadIO m, Exception e) => Span -> H.HashMap Text Attribute -> Maybe Timestamp -> e -> m ()
 recordException s attrs ts e = liftIO $ do
   cs <- whoCreated e
   let message = T.pack $ show e
   addEvent s $
     NewEvent
       { newEventName = "exception"
       , newEventAttributes =
-          attrs
-            ++ [ ("exception.type", A.toAttribute $ T.pack $ show $ typeOf e)
-               , ("exception.message", A.toAttribute message)
-               , ("exception.stacktrace", A.toAttribute $ T.unlines $ map T.pack cs)
-               ]
+          H.union
+            attrs
+            [ ("exception.type", A.toAttribute $ T.pack $ show $ typeOf e)
+            , ("exception.message", A.toAttribute message)
+            , ("exception.stacktrace", A.toAttribute $ T.unlines $ map T.pack cs)
+            ]
       , newEventTimestamp = ts
       }
 

api/src/OpenTelemetry/Trace/Sampler.hs

@@ -1,6 +1,4 @@
------------------------------------------------------------------------------
-
------------------------------------------------------------------------------
+{-# LANGUAGE OverloadedLists #-}
 
 {- |
  Module      :  OpenTelemetry.Trace.Sampler

cabal.project

@@ -14,6 +14,7 @@ packages:
   , instrumentation/hspec
   , instrumentation/http-client
   , instrumentation/persistent
+  , instrumentation/persistent-mysql
   , instrumentation/postgresql-simple
   , instrumentation/yesod
   , instrumentation/wai

examples/yesod-minimal/src/Minimal.hs

@@ -94,7 +94,7 @@ instance YesodPersist Minimal where
       runSqlPoolWithExtensibleHooks m (minimalConnectionPool app) Nothing $ setAlterBackend defaultSqlPoolHooks $ \conn -> do
         -- TODO, could probably not do this on each runDB call.
         staticAttrs <- case getSimpleConn conn of
-          Nothing -> pure []
+          Nothing -> pure mempty
           Just pgConn -> staticConnectionAttributes pgConn
         wrapSqlBackend staticAttrs conn
 

exporters/handle/hs-opentelemetry-exporter-handle.cabal

@@ -1,11 +1,11 @@
 cabal-version: 1.12
 
--- This file has been generated from package.yaml by hpack version 0.34.4.
+-- This file has been generated from package.yaml by hpack version 0.35.0.
 --
 -- see: https://github.com/sol/hpack
 
 name:           hs-opentelemetry-exporter-handle
-version:        0.0.1.0
+version:        0.0.1.1
 description:    Please see the README on GitHub at <https://github.com/iand675/hs-opentelemetry/tree/main/exporters/handle#readme>
 homepage:       https://github.com/iand675/hs-opentelemetry#readme
 bug-reports:    https://github.com/iand675/hs-opentelemetry/issues
@@ -32,7 +32,7 @@ library
       src
   build-depends:
       base >=4.7 && <5
-    , hs-opentelemetry-api ==0.0.3.*
+    , hs-opentelemetry-api >=0.0.3 && <0.2
     , text
   default-language: Haskell2010
 
@@ -46,7 +46,7 @@ test-suite hs-opentelemetry-exporter-handle-test
   ghc-options: -threaded -rtsopts -with-rtsopts=-N
   build-depends:
       base >=4.7 && <5
-    , hs-opentelemetry-api ==0.0.3.*
+    , hs-opentelemetry-api >=0.0.3 && <0.2
     , hs-opentelemetry-exporter-handle
     , text
   default-language: Haskell2010

exporters/handle/package.yaml

@@ -1,5 +1,5 @@
 name:                hs-opentelemetry-exporter-handle
-version:             0.0.1.0
+version:             0.0.1.1
 github:              "iand675/hs-opentelemetry"
 license:             BSD3
 author:              "Ian Duncan"
@@ -21,7 +21,7 @@ description:         Please see the README on GitHub at <https://github.com/iand
 
 dependencies:
 - base >= 4.7 && < 5
-- hs-opentelemetry-api == 0.0.3.*
+- hs-opentelemetry-api >= 0.0.3 && < 0.2
 - text
 
 library:

exporters/in-memory/hs-opentelemetry-exporter-in-memory.cabal

@@ -1,11 +1,11 @@
 cabal-version: 1.12
 
--- This file has been generated from package.yaml by hpack version 0.34.4.
+-- This file has been generated from package.yaml by hpack version 0.35.0.
 --
 -- see: https://github.com/sol/hpack
 
 name:           hs-opentelemetry-exporter-in-memory
-version:        0.0.1.2
+version:        0.0.1.3
 description:    Please see the README on GitHub at <https://github.com/iand675/hs-opentelemetry/tree/main/exporters/in-memory#readme>
 homepage:       https://github.com/iand675/hs-opentelemetry#readme
 bug-reports:    https://github.com/iand675/hs-opentelemetry/issues
@@ -34,7 +34,7 @@ library
   build-depends:
       async
     , base >=4.7 && <5
-    , hs-opentelemetry-api ==0.0.3.*
+    , hs-opentelemetry-api >=0.0.3 && <0.2
     , unagi-chan
   default-language: Haskell2010
 
@@ -49,7 +49,7 @@ test-suite hs-opentelemetry-exporter-in-memory-test
   build-depends:
       async
     , base >=4.7 && <5
-    , hs-opentelemetry-api ==0.0.3.*
+    , hs-opentelemetry-api >=0.0.3 && <0.2
     , hs-opentelemetry-exporter-in-memory
     , unagi-chan
   default-language: Haskell2010