packages feed

freckle-otel (empty) → 0.0.0.1

raw patch · 12 files changed

+893/−0 lines, 12 filesdep +Blammodep +aesondep +base

Dependencies added: Blammo, aeson, base, bytestring, case-insensitive, errors, exceptions, faktory, freckle-env, freckle-otel, hs-opentelemetry-api, hs-opentelemetry-sdk, hspec, hspec-core, hspec-expectations-lifted, http-client, http-conduit, http-types, lens, mtl, text, unliftio, unordered-containers

Files

+ CHANGELOG.md view
@@ -0,0 +1,9 @@+## [_Unreleased_](https://github.com/freckle/freckle-app/compare/freckle-otel-v0.0.0.0...main)++## [v0.0.0.1](https://github.com/freckle/freckle-app/compare/freckle-otel-v0.0.0.0...freckle-otel-v0.0.0.1)++Drop `relude` dependency++## [v0.0.0.0](https://github.com/freckle/freckle-app/tree/freckle-otel-v0.0.0.0/freckle-otel)++First release, sprouted from `freckle-app-1.19.0.0`.
+ LICENSE view
@@ -0,0 +1,21 @@+The MIT License (MIT)++Copyright (c) 2023-2024 Renaissance Learning Inc++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.md view
@@ -0,0 +1,1 @@+# freckle-otel
+ freckle-otel.cabal view
@@ -0,0 +1,112 @@+cabal-version:      1.18+name:               freckle-otel+version:            0.0.0.1+license:            MIT+license-file:       LICENSE+maintainer:         Freckle Education+homepage:           https://github.com/freckle/freckle-app#readme+bug-reports:        https://github.com/freckle/freckle-app/issues+synopsis:           ...+description:        Please see README.md+category:+    OpenTelemetry, Telemetry, Monitoring, Observability, Metrics++build-type:         Simple+extra-source-files: package.yaml+extra-doc-files:+    README.md+    CHANGELOG.md++source-repository head+    type:     git+    location: https://github.com/freckle/freckle-app++library+    exposed-modules:+        Freckle.App.OpenTelemetry+        Freckle.App.OpenTelemetry.Context+        Freckle.App.OpenTelemetry.Http+        Freckle.App.OpenTelemetry.ThreadContext++    hs-source-dirs:     library+    other-modules:      Paths_freckle_otel+    default-language:   GHC2021+    default-extensions:+        DataKinds DeriveAnyClass DerivingVia DerivingStrategies GADTs+        LambdaCase NoImplicitPrelude NoMonomorphismRestriction+        OverloadedStrings RecordWildCards TypeFamilies++    ghc-options:+        -fignore-optim-changes -fwrite-ide-info -Weverything+        -Wno-all-missed-specialisations -Wno-missing-exported-signatures+        -Wno-missing-import-lists -Wno-missing-kind-signatures+        -Wno-missing-local-signatures -Wno-missing-safe-haskell-mode+        -Wno-monomorphism-restriction -Wno-prepositive-qualified-module+        -Wno-safe -Wno-unsafe++    build-depends:+        Blammo >=2.0.0.0,+        aeson >=2.0.3.0,+        base >=4.16.4.0 && <5,+        bytestring >=0.11.4.0,+        case-insensitive >=1.2.1.0,+        errors >=2.3.0,+        exceptions >=0.10.4,+        faktory >=1.1.2.4,+        hs-opentelemetry-api >=0.1.0.0,+        hs-opentelemetry-sdk >=0.0.3.6,+        http-client >=0.7.13.1,+        http-conduit >=2.3.5,+        http-types >=0.12.3,+        lens >=5.1.1,+        text >=1.2.5.0,+        unliftio >=0.2.25.0,+        unordered-containers >=0.2.19.1++    if impl(ghc >=9.8)+        ghc-options:+            -Wno-missing-role-annotations -Wno-missing-poly-kind-signatures++test-suite spec+    type:               exitcode-stdio-1.0+    main-is:            Main.hs+    hs-source-dirs:     tests+    other-modules:+        AppExample+        Freckle.App.OpenTelemetry.ContextSpec+        Paths_freckle_otel++    default-language:   GHC2021+    default-extensions:+        DataKinds DeriveAnyClass DerivingVia DerivingStrategies GADTs+        LambdaCase NoImplicitPrelude NoMonomorphismRestriction+        OverloadedStrings RecordWildCards TypeFamilies++    ghc-options:+        -fignore-optim-changes -fwrite-ide-info -Weverything+        -Wno-all-missed-specialisations -Wno-missing-exported-signatures+        -Wno-missing-import-lists -Wno-missing-kind-signatures+        -Wno-missing-local-signatures -Wno-missing-safe-haskell-mode+        -Wno-monomorphism-restriction -Wno-prepositive-qualified-module+        -Wno-safe -Wno-unsafe -threaded -rtsopts -with-rtsopts=-N++    build-depends:+        Blammo >=2.0.0.0,+        base >=4.16.4.0 && <5,+        exceptions >=0.10.4,+        freckle-env >=0.0.1.1,+        freckle-otel,+        hs-opentelemetry-api >=0.1.0.0,+        hs-opentelemetry-sdk >=0.0.3.6,+        hspec >=2.10.10,+        hspec-core >=2.10.10,+        hspec-expectations-lifted >=0.10.0,+        http-types >=0.12.3,+        lens >=5.1.1,+        mtl >=2.2.2,+        text >=1.2.5.0,+        unliftio >=0.2.25.0++    if impl(ghc >=9.8)+        ghc-options:+            -Wno-missing-role-annotations -Wno-missing-poly-kind-signatures
+ library/Freckle/App/OpenTelemetry.hs view
@@ -0,0 +1,176 @@+-- | Application tracing via <https://opentelemetry.io/>+--+-- @+-- data App = App+--   { -- ...+--   , appTracer :: Tracer+--   }+--+-- instance 'HasTracer' App where+--   tracerL = lens appTracer $ \x y -> x { appTracer = y }+--+-- loadApp f = do+--   -- ...+--   'withTracerProvider' $ \tracerProvider -> do+--     let appTracer = 'makeTracer' tracerProvider "my-app" 'tracerOptions'+--     f App {..}+-- @+--+-- You may need to do this even if you don't plan to manually trace things, in+-- order to satisfy the 'MonadTracer' constraint required by functions like+-- 'runDB'. If you don't need this feature, and don't plan on running an+-- otel-collector, set @OTEL_TRACES_EXPORTER=none@ in the environment, which+-- makes all tracing a no-op.+--+-- In the future, it should be possible to use @OTEL_SDK_DISABLED@ for the same+-- purpose. See <https://github.com/iand675/hs-opentelemetry/issues/60>.+module Freckle.App.OpenTelemetry+  ( HasTracer (..)+  , Tracer++    -- * Effects+  , MonadTracer (..)+  , inSpan+  , SpanArguments (..)+  , defaultSpanArguments+  , serverSpanArguments+  , clientSpanArguments+  , producerSpanArguments+  , consumerSpanArguments++    -- * Querying+  , getCurrentTraceId+  , getCurrentSpanContext++    -- * Ids+  , TraceId+  , traceIdToHex+  , SpanId+  , spanIdToHex++    -- * Attributes+  , ToAttribute (..)+  , addCurrentSpanAttributes++    -- * Setup+  , withTracerProvider++    -- ** 'Tracer'+  , makeTracer+  , tracerOptions++    -- ** Utilities+  , byteStringToAttribute+  , attributeValueLimit+  ) where++import Prelude++import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.ByteString (ByteString)+import Data.Functor (void)+import Data.HashMap.Strict (HashMap)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Encoding qualified as T+import Data.Text.Encoding.Error qualified as T+import OpenTelemetry.Context (lookupSpan)+import OpenTelemetry.Context.ThreadLocal (getContext)+import OpenTelemetry.Trace hiding (inSpan)+import OpenTelemetry.Trace.Core (getSpanContext)+import OpenTelemetry.Trace.Core qualified as Trace (SpanContext (..))+import OpenTelemetry.Trace.Id+  ( Base (..)+  , SpanId+  , TraceId+  , spanIdBaseEncodedText+  , traceIdBaseEncodedText+  )+import OpenTelemetry.Trace.Monad+import UnliftIO (MonadUnliftIO)+import UnliftIO.Exception (bracket)++-- | 'defaultSpanArguments' with 'kind' set to 'Server'+--+-- Indicates that the span covers server-side handling of a synchronous RPC or+-- other remote request. This span is the child of a remote @Client@ span that+-- was expected to wait for a response.+serverSpanArguments :: SpanArguments+serverSpanArguments = defaultSpanArguments {kind = Server}++-- | 'defaultSpanArguments' with 'kind' set to 'Kind'+--+-- Indicates that the span describes a synchronous request to some remote+-- service. This span is the parent of a remote @Server@ span and waits for its+-- response.+clientSpanArguments :: SpanArguments+clientSpanArguments = defaultSpanArguments {kind = Client}++-- | 'defaultSpanArguments' with 'kind' set to 'Producer'+--+-- Indicates that the span describes the parent of an asynchronous request. This+-- parent span is expected to end before the corresponding child @Producer@+-- span, possibly even before the child span starts. In messaging scenarios with+-- batching, tracing individual messages requires a new @Producer@ span per+-- message to be created.+producerSpanArguments :: SpanArguments+producerSpanArguments = defaultSpanArguments {kind = Producer}++-- | 'defaultSpanArguments' with 'kind' set to 'Consumer'+--+-- Indicates that the span describes the child of an asynchronous @Producer@+-- request.+consumerSpanArguments :: SpanArguments+consumerSpanArguments = defaultSpanArguments {kind = Consumer}++withTracerProvider :: MonadUnliftIO m => (TracerProvider -> m a) -> m a+withTracerProvider =+  bracket+    (liftIO initializeGlobalTracerProvider)+    (liftIO . shutdownTracerProvider)++getCurrentTraceId :: MonadIO m => m (Maybe TraceId)+getCurrentTraceId = fmap Trace.traceId <$> getCurrentSpanContext++getCurrentSpanContext :: MonadIO m => m (Maybe SpanContext)+getCurrentSpanContext = withCurrentSpan getSpanContext++addCurrentSpanAttributes :: MonadIO m => HashMap Text Attribute -> m ()+addCurrentSpanAttributes attrs = void $ withCurrentSpan (`addAttributes` attrs)++withCurrentSpan :: MonadIO m => (Span -> m b) -> m (Maybe b)+withCurrentSpan f = do+  mSpan <- lookupSpan <$> getContext+  traverse f mSpan++traceIdToHex :: TraceId -> Text+traceIdToHex = traceIdBaseEncodedText Base16++spanIdToHex :: SpanId -> Text+spanIdToHex = spanIdBaseEncodedText Base16++-- | Convert a 'ByteString' to an 'Attribute' safely+--+-- - Decodes it as UTF-8 leniently,+-- - Truncates to fit within 'attributeValueLimit'+byteStringToAttribute :: ByteString -> Attribute+byteStringToAttribute =+  toAttribute+    . truncateText attributeValueLimit+    . T.decodeUtf8With T.lenientDecode++-- | Character limit for 'Attribute' values+--+-- OTel the spec doesn't specify a limit, but says that SDKs should decide+-- some limit. It's not clear what the Haskell SDK does, if anything. New+-- Relic applies a limit of 4095 characters on all metrics it handles,+-- including those coming from OTel. Seems reasonable enough.+--+-- <https://docs.newrelic.com/docs/more-integrations/open-source-telemetry-integrations/opentelemetry/best-practices/opentelemetry-best-practices-attributes/>+attributeValueLimit :: Int+attributeValueLimit = 4095++truncateText :: Int -> Text -> Text+truncateText l t+  | T.length t <= l = t+  | otherwise = T.take (l - 3) t <> "..."
+ library/Freckle/App/OpenTelemetry/Context.hs view
@@ -0,0 +1,126 @@+module Freckle.App.OpenTelemetry.Context+  ( HasHeaders (..)+  , CustomTraceContext (..)+  , extractContext+  , injectContext+  , processWithContext+  ) where++import Prelude++import Control.Error.Util (hush)+import Control.Lens (Lens', lens, (.~), (^.))+import Control.Monad.Catch (MonadMask)+import Control.Monad.IO.Class (MonadIO)+import Data.Aeson (FromJSON, ToJSON)+import Data.Bifunctor (bimap)+import Data.ByteString (ByteString)+import Data.CaseInsensitive (CI)+import Data.CaseInsensitive qualified as CI+import Data.Function ((&))+import Data.Functor (void)+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import Data.Text.Encoding qualified as T+import Faktory.Job (Job, custom, jobOptions)+import Faktory.Job.Custom (fromCustom, toCustom)+import Faktory.JobOptions (JobOptions (..))+import Freckle.App.OpenTelemetry+  ( MonadTracer (..)+  , SpanArguments+  , inSpan+  )+import Freckle.App.OpenTelemetry.ThreadContext (withTraceContext)+import GHC.Generics (Generic)+import GHC.Stack (HasCallStack)+import Network.HTTP.Client (Request, requestHeaders)+import Network.HTTP.Simple (setRequestHeaders)+import Network.HTTP.Types.Header (Header)+import OpenTelemetry.Context (Context)+import OpenTelemetry.Context.ThreadLocal (attachContext, getContext)+import OpenTelemetry.Propagator (Propagator, extract, inject)+import OpenTelemetry.Trace.Core+  ( getTracerProviderPropagators+  , getTracerTracerProvider+  )+import UnliftIO (MonadUnliftIO)++class HasHeaders a where+  headersL :: Lens' a [Header]++instance HasHeaders [Header] where+  headersL = id++instance HasHeaders Request where+  headersL = lens requestHeaders $ \req hs -> setRequestHeaders hs req++instance HasHeaders (Job a) where+  headersL = optionsL . customTraceContextL . headersL++optionsL :: Lens' (Job a) JobOptions+optionsL = lens jobOptions $ \x y -> x {jobOptions = y}++customTraceContextL :: Lens' JobOptions CustomTraceContext+customTraceContextL = lens get set+ where+  get jo = fromMaybe mempty $ hush . fromCustom =<< joCustom jo+  set jo = (jo <>) . custom . toCustom++-- | A type that can be stored as the @custom@ field of a Faktory 'Job'+newtype CustomTraceContext = CustomTraceContext+  { traceHeaders :: [(Text, Text)]+  }+  deriving stock (Generic)+  deriving newtype (Semigroup, Monoid)+  deriving anyclass (FromJSON, ToJSON)++instance HasHeaders CustomTraceContext where+  headersL = lens (map encode . traceHeaders) $ \x y -> x {traceHeaders = map decode y}++encode :: (Text, Text) -> (CI ByteString, ByteString)+encode = bimap (CI.mk . T.encodeUtf8) T.encodeUtf8++decode :: (CI ByteString, ByteString) -> (Text, Text)+decode = bimap (T.decodeUtf8 . CI.original) T.decodeUtf8++-- | Update our trace context from that extracted from the given item's headers+extractContext+  :: (MonadIO m, MonadTracer m, HasHeaders a) => a -> m ()+extractContext a = do+  context <- getContext+  propagator <- getPropagator+  updatedContext <- extract propagator (a ^. headersL) context+  void $ attachContext updatedContext++-- | Inject our trace context into the given item's headers+injectContext+  :: (MonadIO m, MonadTracer m, HasHeaders a) => a -> m a+injectContext a = do+  context <- getContext+  propagator <- getPropagator+  headers <- inject propagator context $ a ^. headersL+  pure $ a & headersL .~ headers++getPropagator :: MonadTracer m => m (Propagator Context [Header] [Header])+getPropagator =+  getTracerProviderPropagators . getTracerTracerProvider <$> getTracer++-- | Process an item (a request, a Job, etc) in a top-level span and context+processWithContext+  :: ( MonadUnliftIO m+     , MonadMask m+     , MonadTracer m+     , HasHeaders a+     , HasCallStack+     )+  => Text+  -- ^ Span name+  -> SpanArguments+  -> a+  -> (a -> m b)+  -> m b+processWithContext name args a f = do+  extractContext a+  inSpan name args $ do+    a' <- injectContext a+    withTraceContext $ f a'
+ library/Freckle/App/OpenTelemetry/Http.hs view
@@ -0,0 +1,60 @@+module Freckle.App.OpenTelemetry.Http+  ( httpSpanName+  , httpSpanArguments+  , httpAttributes+  , httpResponseAttributes+  ) where++import Prelude++import Data.CaseInsensitive qualified as CI+import Data.HashMap.Strict (HashMap)+import Data.HashMap.Strict qualified as HashMap+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Encoding qualified as T+import Data.Text.Encoding.Error qualified as T+import Freckle.App.OpenTelemetry+  ( SpanArguments (..)+  , byteStringToAttribute+  , clientSpanArguments+  )+import Network.HTTP.Client (Request, Response)+import Network.HTTP.Client qualified as HTTP+import Network.HTTP.Types.Status (statusCode)+import OpenTelemetry.Attributes (Attribute, ToAttribute (..))++httpSpanName :: Request -> Text+httpSpanName req =+  T.decodeUtf8With T.lenientDecode $ HTTP.method req <> " " <> HTTP.path req++httpSpanArguments :: Request -> SpanArguments+httpSpanArguments req = clientSpanArguments {attributes = httpAttributes req}++httpAttributes :: Request -> HashMap Text Attribute+httpAttributes req =+  HashMap.fromList+    [ ("service.name", byteStringToAttribute $ HTTP.host req)+    , ("resource.name", toAttribute $ httpSpanName req)+    , ("http.host", byteStringToAttribute $ HTTP.host req)+    , ("http.method", byteStringToAttribute $ HTTP.method req)+    , ("http.path", byteStringToAttribute $ HTTP.path req)+    , ("http.query", byteStringToAttribute $ HTTP.queryString req)+    ]++httpResponseAttributes :: Response body -> HashMap Text Attribute+httpResponseAttributes resp = statusAttr <> foldMap (uncurry headerAttr) (HTTP.responseHeaders resp)+ where+  statusAttr =+    HashMap.singleton "http.status_code"+      . toAttribute+      . statusCode+      $ HTTP.responseStatus resp++  headerAttr k = HashMap.singleton (headerAttrKey k) . byteStringToAttribute++  headerAttrKey =+    ("http.response.headers." <>)+      . T.toLower+      . T.decodeUtf8With T.lenientDecode+      . CI.original
+ library/Freckle/App/OpenTelemetry/ThreadContext.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE NamedFieldPuns #-}++module Freckle.App.OpenTelemetry.ThreadContext+  ( withTraceContext+  ) where++import Prelude++import Blammo.Logging (MonadMask, withThreadContext)+import Control.Monad.IO.Class (MonadIO)+import Data.Aeson ((.=))+import Data.Aeson.Key qualified as Key+import Data.Aeson.Types (Pair)+import Data.Bifunctor (bimap)+import Data.Text (Text)+import Freckle.App.OpenTelemetry (getCurrentSpanContext)+import OpenTelemetry.Trace.Core (SpanContext (..))+import OpenTelemetry.Trace.Id+  ( Base (..)+  , spanIdBaseEncodedText+  , traceIdBaseEncodedText+  )+import OpenTelemetry.Trace.TraceState (Key (..), TraceState (..), Value (..))++-- | Add tracing context values to the logging context+--+-- Values are encoded to 'Base16' (i.e. hex).+withTraceContext :: (MonadIO m, MonadMask m) => m a -> m a+withTraceContext f = do+  mSpanContext <- getCurrentSpanContext++  case mSpanContext of+    Nothing -> f+    Just sc -> withThreadContext (toThreadContext sc) f++toThreadContext :: SpanContext -> [Pair]+toThreadContext SpanContext {traceId, spanId, traceState} =+  [ "trace_id" .= traceIdBaseEncodedText Base16 traceId+  , "span_id" .= spanIdBaseEncodedText Base16 spanId+  , "trace_state" .= traceStatePairs+  ]+ where+  traceStatePairs :: [Pair]+  traceStatePairs = map traceStatePair $ unTraceState traceState++  traceStatePair :: (Key, Value) -> Pair+  traceStatePair = uncurry (.=) . bimap (Key.fromText . unKey) unValue++unTraceState :: TraceState -> [(Key, Value)]+unTraceState (TraceState x) = x++unKey :: Key -> Text+unKey (Key x) = x++unValue :: Value -> Text+unValue (Value x) = x
+ package.yaml view
@@ -0,0 +1,94 @@+name: freckle-otel+version: 0.0.0.1+maintainer: Freckle Education+category: OpenTelemetry, Telemetry, Monitoring, Observability, Metrics+github: freckle/freckle-app+synopsis: ...+description: Please see README.md++extra-doc-files:+  - README.md+  - CHANGELOG.md++extra-source-files:+  - package.yaml++language: GHC2021++ghc-options:+  - -fignore-optim-changes+  - -fwrite-ide-info+  - -Weverything+  - -Wno-all-missed-specialisations+  - -Wno-missing-exported-signatures # re-enables missing-signatures+  - -Wno-missing-import-lists+  - -Wno-missing-kind-signatures+  - -Wno-missing-local-signatures+  - -Wno-missing-safe-haskell-mode+  - -Wno-monomorphism-restriction+  - -Wno-prepositive-qualified-module+  - -Wno-safe+  - -Wno-unsafe++when:+  - condition: "impl(ghc >= 9.8)"+    ghc-options:+      - -Wno-missing-role-annotations+      - -Wno-missing-poly-kind-signatures++dependencies:+  - base < 5++default-extensions:+  - DataKinds+  - DeriveAnyClass+  - DerivingVia+  - DerivingStrategies+  - GADTs+  - LambdaCase+  - NoImplicitPrelude+  - NoMonomorphismRestriction+  - OverloadedStrings+  - RecordWildCards+  - TypeFamilies++library:+  source-dirs: library+  dependencies:+    - Blammo >= 2.0.0.0+    - aeson+    - bytestring+    - case-insensitive+    - errors+    - exceptions+    - faktory+    - hs-opentelemetry-api+    - hs-opentelemetry-sdk+    - http-client+    - http-conduit >= 2.3.5 # addToRequestQueryString+    - http-types+    - lens+    - text+    - unliftio+    - unordered-containers++tests:+  spec:+    main: Main.hs+    source-dirs: tests+    ghc-options: -threaded -rtsopts "-with-rtsopts=-N"+    dependencies:+      - Blammo+      - exceptions+      - freckle-env+      - freckle-otel+      - hs-opentelemetry-api+      - hs-opentelemetry-sdk+      - hspec+      - hspec-core+      - hspec-expectations-lifted+      - http-types+      - lens+      - mtl+      - text+      - unliftio
+ tests/AppExample.hs view
@@ -0,0 +1,65 @@+module AppExample+  ( AppExample (..)+  , appExample+  , withApp+  ) where++import Prelude++import Control.Lens (view)+import Control.Monad.Catch+import Control.Monad.Reader (MonadReader, ReaderT (..))+import Data.Functor (void)+import Freckle.App.Dotenv qualified as Dotenv+import OpenTelemetry.Trace (HasTracer (..))+import OpenTelemetry.Trace.Monad (MonadTracer (..))+import Test.Hspec (Spec, SpecWith, aroundAll, beforeAll)+import Test.Hspec.Core.Spec (Example (..))+import UnliftIO++withApp :: ((app -> IO ()) -> IO ()) -> SpecWith app -> Spec+withApp run = beforeAll Dotenv.loadTest . aroundAll run++-- | An Hspec example over some @app@ value+newtype AppExample app a = AppExample+  { unAppExample :: ReaderT app IO a+  }+  deriving newtype+    ( Applicative+    , Functor+    , Monad+    , MonadCatch+    , MonadIO+    , MonadUnliftIO+    , MonadReader app+    , MonadThrow+    , MonadFail+    )++instance MonadMask (AppExample app) where+  mask = UnliftIO.mask+  uninterruptibleMask = UnliftIO.uninterruptibleMask+  generalBracket acquire release use = UnliftIO.mask $ \unmasked -> do+    resource <- acquire+    b <-+      unmasked (use resource) `UnliftIO.catch` \e -> do+        _ <- release resource (ExitCaseException e)+        throwM e++    c <- release resource (ExitCaseSuccess b)+    pure (b, c)++instance HasTracer app => MonadTracer (AppExample app) where+  getTracer = view tracerL++instance Example (AppExample app a) where+  type Arg (AppExample app a) = app++  evaluateExample (AppExample ex) params action =+    evaluateExample+      (action $ \app -> void $ runReaderT ex app)+      params+      ($ ())++appExample :: AppExample app a -> AppExample app a+appExample = id
+ tests/Freckle/App/OpenTelemetry/ContextSpec.hs view
@@ -0,0 +1,172 @@+module Freckle.App.OpenTelemetry.ContextSpec+  ( spec+  ) where++import Prelude++import AppExample+import Blammo.Logging+import Blammo.Logging.Logger (newTestLogger)+import Control.Lens (lens)+import Control.Monad.IO.Class (MonadIO)+import Data.List qualified as List+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Encoding qualified as T+import Freckle.App.OpenTelemetry+import Freckle.App.OpenTelemetry.Context+import GHC.Stack (HasCallStack)+import Network.HTTP.Types.Header (Header)+import OpenTelemetry.Trace.Core qualified as Trace+import Test.Hspec (Spec, describe, it)+import Test.Hspec.Expectations.Lifted+  ( shouldBe+  , shouldNotBe+  , shouldReturn+  )+import Test.Hspec.Expectations.Lifted qualified as Hspec (expectationFailure)++data App = App+  { appLogger :: Logger+  , appTracer :: Tracer+  }++instance HasLogger App where+  loggerL = lens appLogger $ \x y -> x {appLogger = y}++instance HasTracer App where+  tracerL = lens appTracer $ \x y -> x {appTracer = y}++loadApp :: (App -> IO ()) -> IO ()+loadApp f = do+  appLogger <- newTestLogger defaultLogSettings++  withTracerProvider $ \tracerProvider -> do+    let appTracer = makeTracer tracerProvider "app" tracerOptions+    f App {..}++spec :: Spec+spec = withApp loadApp $ do+  describe "injectContext" $ do+    it "sets request headers from existing context" $ appExample @App $ do+      inSpan "example" defaultSpanArguments $ do+        spanContext <- assertCurrentSpanContext++        let expectedTraceParent =+              toTraceParent+                (traceIdToHex $ Trace.traceId spanContext)+                (spanIdToHex $ Trace.spanId spanContext)++        injectContext ([] :: [Header])+          `shouldReturn` [ ("traceparent", T.encodeUtf8 expectedTraceParent)+                         , ("tracestate", "")+                         ]++  describe "extractContext" $ do+    it "sets the context from the headers" $ appExample @App $ do+      let+        traceId = "fba7cd19bff3ef866a599d6f6a85baef"+        spanId = "5747fd6b144f4009"++        headers :: [Header]+        headers =+          [ ("traceparent", T.encodeUtf8 $ toTraceParent traceId spanId)+          , ("tracestate", "")+          ]++      extractContext headers++      spanContext <- assertCurrentSpanContext+      traceIdToHex (Trace.traceId spanContext) `shouldBe` traceId+      spanIdToHex (Trace.spanId spanContext) `shouldBe` spanId++    it "does nothing with no headers" $ appExample @App $ do+      getCurrentSpanContext `shouldReturn` Nothing++      extractContext ([] :: [Header])++      getCurrentSpanContext `shouldReturn` Nothing++  describe "processWithContext" $ do+    it "creates a child-span context" $ appExample @App $ do+      inSpan "example" defaultSpanArguments $ do+        outerSpanContext <- assertCurrentSpanContext++        let+          traceId = traceIdToHex $ Trace.traceId outerSpanContext+          spanId = spanIdToHex $ Trace.spanId outerSpanContext++          headers :: [Header]+          headers =+            [ ("traceparent", T.encodeUtf8 $ toTraceParent traceId spanId)+            , ("tracestate", "")+            ]++        processWithContext "loop" defaultSpanArguments headers $ \_ -> do+          innerSpanContext <- assertCurrentSpanContext++          -- Ideally we'd assert the inner span's parent is the outer span, but+          -- the library doesn't expose the necessary functionality. All we can+          -- do is assert it's a fresh span of the same trace.+          Trace.traceId innerSpanContext `shouldBe` Trace.traceId outerSpanContext+          Trace.spanId innerSpanContext `shouldNotBe` Trace.spanId outerSpanContext++    it "sets the current context back into the headers" $ appExample @App $ do+      inSpan "example" defaultSpanArguments $ do+        let+          traceId = "fba7cd19bff3ef866a599d6f6a85baef"+          spanId = "5747fd6b144f4009"++          headers :: [Header]+          headers =+            [ ("traceparent", T.encodeUtf8 $ toTraceParent traceId spanId)+            , ("tracestate", "")+            ]++        processWithContext "loop" defaultSpanArguments headers $ \headers' -> do+          spanContext <- assertCurrentSpanContext++          let headerTraceParent = do+                bs <- List.lookup "traceparent" headers'+                fromTraceParent $ T.decodeUtf8 bs++          fmap fst headerTraceParent `shouldBe` Just traceId+          fmap snd headerTraceParent+            `shouldBe` Just (spanIdToHex $ Trace.spanId spanContext)++    it "sets a fresh context back into the headers" $ appExample @App $ do+      inSpan "example" defaultSpanArguments $ do+        let+          headers :: [Header]+          headers = []++        processWithContext "loop" defaultSpanArguments headers $ \headers' -> do+          spanContext <- assertCurrentSpanContext++          let headerTraceParent = do+                bs <- List.lookup "traceparent" headers'+                fromTraceParent $ T.decodeUtf8 bs++          fmap fst headerTraceParent+            `shouldBe` Just (traceIdToHex $ Trace.traceId spanContext)+          fmap snd headerTraceParent+            `shouldBe` Just (spanIdToHex $ Trace.spanId spanContext)++assertCurrentSpanContext :: (MonadIO m, HasCallStack) => m Trace.SpanContext+assertCurrentSpanContext =+  getCurrentSpanContext >>= \case+    Nothing -> expectationFailure "Expect there to be a SpanContext"+    Just spanContext -> pure spanContext++toTraceParent :: Text -> Text -> Text+toTraceParent traceId spanId = "00-" <> traceId <> "-" <> spanId <> "-00"++fromTraceParent :: Text -> Maybe (Text, Text)+fromTraceParent a = do+  b <- T.stripPrefix "00-" a+  c <- T.stripSuffix "-00" b+  [traceId, spanId] <- Just $ T.splitOn "-" c+  pure (traceId, spanId)++expectationFailure :: (MonadIO m, HasCallStack) => String -> m a+expectationFailure msg = Hspec.expectationFailure msg >> error "unreachable"
+ tests/Main.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Main -Wno-missing-export-lists #-}