diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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`. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,1 @@ +# freckle-otel diff --git a/freckle-otel.cabal b/freckle-otel.cabal new file mode 100644 --- /dev/null +++ b/freckle-otel.cabal @@ -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 diff --git a/library/Freckle/App/OpenTelemetry.hs b/library/Freckle/App/OpenTelemetry.hs new file mode 100644 --- /dev/null +++ b/library/Freckle/App/OpenTelemetry.hs @@ -0,0 +1,176 @@ +-- | Application tracing via +-- +-- @ +-- 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 . +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. +-- +-- +attributeValueLimit :: Int +attributeValueLimit = 4095 + +truncateText :: Int -> Text -> Text +truncateText l t + | T.length t <= l = t + | otherwise = T.take (l - 3) t <> "..." diff --git a/library/Freckle/App/OpenTelemetry/Context.hs b/library/Freckle/App/OpenTelemetry/Context.hs new file mode 100644 --- /dev/null +++ b/library/Freckle/App/OpenTelemetry/Context.hs @@ -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' diff --git a/library/Freckle/App/OpenTelemetry/Http.hs b/library/Freckle/App/OpenTelemetry/Http.hs new file mode 100644 --- /dev/null +++ b/library/Freckle/App/OpenTelemetry/Http.hs @@ -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 diff --git a/library/Freckle/App/OpenTelemetry/ThreadContext.hs b/library/Freckle/App/OpenTelemetry/ThreadContext.hs new file mode 100644 --- /dev/null +++ b/library/Freckle/App/OpenTelemetry/ThreadContext.hs @@ -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 diff --git a/package.yaml b/package.yaml new file mode 100644 --- /dev/null +++ b/package.yaml @@ -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 diff --git a/tests/AppExample.hs b/tests/AppExample.hs new file mode 100644 --- /dev/null +++ b/tests/AppExample.hs @@ -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 diff --git a/tests/Freckle/App/OpenTelemetry/ContextSpec.hs b/tests/Freckle/App/OpenTelemetry/ContextSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Freckle/App/OpenTelemetry/ContextSpec.hs @@ -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" diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Main -Wno-missing-export-lists #-}