freckle-app 1.15.4.0 → 1.15.5.0

raw patch · 6 files changed

+306/−6 lines, 6 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +8/−3
• freckle-app.cabal +4/−1
• library/Freckle/App/OpenTelemetry.hs +20/−1
• library/Freckle/App/OpenTelemetry/Context.hs +116/−0
• package.yaml +2/−1
• tests/Freckle/App/OpenTelemetry/ContextSpec.hs +156/−0

@@ -1,5 +1,10 @@-## [_Unreleased_](https://github.com/freckle/freckle-app/compare/v1.15.4.0...main)+## [_Unreleased_](https://github.com/freckle/freckle-app/compare/v1.15.5.0...main) +## [v1.15.5.0](https://github.com/freckle/freckle-app/compare/v1.15.4.0...v1.15.5.0)++- Add `Freckle.App.OpenTelemetry.Context` with helpers for propagating trace+  context across services.+ ## [v1.15.4.0](https://github.com/freckle/freckle-app/compare/v1.15.3.0...v1.15.4.0)  - Add `addThreadContextFromTracing` and deprecate existing middleware@@ -8,14 +13,14 @@    ```diff   - import Network.Wai.Middleware.OpenTelemetry (newOpenTelemetryWaiMiddleware)-  + import Freckle.App.Wai (addThreadContextFromRequest)+  + import Freckle.App.Wai (addThreadContextFromTracing)   + import OpenTelemetry.Instrumentation.Wai (newOpenTelemetryWaiMiddleware)      traceMiddleware <- newOpenTelemetryWaiMiddleware      run 3000       . traceMiddleware-  +   . addThreadContextFromRequest+  +   . addThreadContextFromTracing       . ...       $ app   ```

@@ -1,6 +1,6 @@ cabal-version:      1.18 name:               freckle-app-version:            1.15.4.0+version:            1.15.5.0 license:            MIT license-file:       LICENSE maintainer:         Freckle Education@@ -59,6 +59,7 @@         Freckle.App.Memcached.MD5         Freckle.App.Memcached.Servers         Freckle.App.OpenTelemetry+        Freckle.App.OpenTelemetry.Context         Freckle.App.OpenTelemetry.ThreadContext         Freckle.App.Prelude         Freckle.App.Random@@ -237,6 +238,7 @@         Freckle.App.HttpSpec         Freckle.App.Memcached.ServersSpec         Freckle.App.MemcachedSpec+        Freckle.App.OpenTelemetry.ContextSpec         Freckle.App.Test.Http.MatchRequestSpec         Freckle.App.Test.Properties.JSONSpec         Freckle.App.Test.Properties.PathPieceSpec@@ -273,6 +275,7 @@         conduit >=1.3.5,         errors >=2.3.0,         freckle-app,+        hs-opentelemetry-api >=0.1.0.0,         hspec >=2.9.7,         hspec-expectations-json >=1.0.0.7,         hspec-expectations-lifted >=0.10.0,

@@ -31,6 +31,7 @@     -- * Effects   , MonadTracer (..)   , inSpan+  , SpanArguments (..)   , defaultSpanArguments   , serverSpanArguments   , clientSpanArguments@@ -43,6 +44,12 @@   , getCurrentTraceIdAsDatadog   , getCurrentSpanContext +    -- * Ids+  , TraceId+  , traceIdToHex+  , SpanId+  , spanIdToHex+     -- * Attributes   , ToAttribute (..)   , addCurrentSpanAttributes@@ -76,7 +83,13 @@ import OpenTelemetry.Trace hiding (inSpan) import OpenTelemetry.Trace.Core (getSpanContext) import qualified OpenTelemetry.Trace.Core as Trace (SpanContext (..))-import OpenTelemetry.Trace.Id (TraceId)+import OpenTelemetry.Trace.Id+  ( Base (..)+  , SpanId+  , TraceId+  , spanIdBaseEncodedText+  , traceIdBaseEncodedText+  ) import OpenTelemetry.Trace.Monad import UnliftIO.Exception (bracket) @@ -143,6 +156,12 @@   mTraceId <- getCurrentTraceIdAsDatadog   maybe f (\traceId -> withThreadContext ["trace_id" .= traceId] f) mTraceId {-# DEPRECATED withTraceIdContext "Use Freckle.App.OpenTelemetry.ThreadContext" #-}++traceIdToHex :: TraceId -> Text+traceIdToHex = traceIdBaseEncodedText Base16++spanIdToHex :: SpanId -> Text+spanIdToHex = spanIdBaseEncodedText Base16  -- | Convert a 'ByteString' to an 'Attribute' safely --

@@ -0,0 +1,116 @@+module Freckle.App.OpenTelemetry.Context+  ( HasHeaders (..)+  , CustomTraceContext (..)+  , extractContext+  , injectContext+  , processWithContext+  ) where++import Freckle.App.Prelude++import Control.Error.Util (hush)+import Control.Lens (Lens', lens, (&), (.~), (^.))+import Control.Monad.Catch (MonadMask)+import Data.Aeson (FromJSON, ToJSON)+import Data.ByteString (ByteString)+import Data.CaseInsensitive (CI)+import qualified Data.CaseInsensitive as CI+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 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+  )++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 . encodeUtf8) encodeUtf8++decode :: (CI ByteString, ByteString) -> (Text, Text)+decode = bimap (decodeUtf8 . CI.original) 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'

@@ -1,5 +1,5 @@ name: freckle-app-version: 1.15.4.0+version: 1.15.5.0 maintainer: Freckle Education category: Utils github: freckle/freckle-app@@ -168,6 +168,7 @@       - conduit       - errors       - freckle-app+      - hs-opentelemetry-api       - hspec       - hspec-expectations-json       - hspec-expectations-lifted

@@ -0,0 +1,156 @@+module Freckle.App.OpenTelemetry.ContextSpec+  ( spec+  ) where++import Freckle.App.Test++import Blammo.Logging+import Blammo.Logging.Logger (newTestLogger)+import Control.Lens (lens)+import qualified Data.Text as T+import Freckle.App.OpenTelemetry+import Freckle.App.OpenTelemetry.Context+import Network.HTTP.Types.Header (Header)+import qualified OpenTelemetry.Trace.Core as Trace++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 $ do+      inSpan "example" defaultSpanArguments $ do+        spanContext <- assertCurrentSpanContext++        let expectedTraceParent =+              toTraceParent+                (traceIdToHex $ Trace.traceId spanContext)+                (spanIdToHex $ Trace.spanId spanContext)++        injectContext ([] :: [Header])+          `shouldReturn` [ ("traceparent", encodeUtf8 expectedTraceParent)+                         , ("tracestate", "")+                         ]++  describe "extractContext" $ do+    it "sets the context from the headers" $ appExample $ do+      let+        traceId = "fba7cd19bff3ef866a599d6f6a85baef"+        spanId = "5747fd6b144f4009"++        headers :: [Header]+        headers =+          [ ("traceparent", 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 $ do+      getCurrentSpanContext `shouldReturn` Nothing++      extractContext ([] :: [Header])++      getCurrentSpanContext `shouldReturn` Nothing++  describe "processWithContext" $ do+    it "creates a child-span context" $ appExample $ do+      inSpan "example" defaultSpanArguments $ do+        outerSpanContext <- assertCurrentSpanContext++        let+          traceId = traceIdToHex $ Trace.traceId outerSpanContext+          spanId = spanIdToHex $ Trace.spanId outerSpanContext++          headers :: [Header]+          headers =+            [ ("traceparent", 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 $ do+      inSpan "example" defaultSpanArguments $ do+        let+          traceId = "fba7cd19bff3ef866a599d6f6a85baef"+          spanId = "5747fd6b144f4009"++          headers :: [Header]+          headers =+            [ ("traceparent", encodeUtf8 $ toTraceParent traceId spanId)+            , ("tracestate", "")+            ]++        processWithContext "loop" defaultSpanArguments headers $ \headers' -> do+          spanContext <- assertCurrentSpanContext++          let headerTraceParent = do+                bs <- lookup "traceparent" headers'+                fromTraceParent $ 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 $ do+      inSpan "example" defaultSpanArguments $ do+        let+          headers :: [Header]+          headers = []++        processWithContext "loop" defaultSpanArguments headers $ \headers' -> do+          spanContext <- assertCurrentSpanContext++          let headerTraceParent = do+                bs <- lookup "traceparent" headers'+                fromTraceParent $ 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)