diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +## [_Unreleased_](https://github.com/freckle/hs-opentelemetry-awsxray/compare/v0.1.0.0...main) + +## [v0.1.0.0](https://github.com/freckle/hs-opentelemetry-awsxray/tree/v0.1.0.0) + +First tagged release. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +The MIT License (MIT) + +Copyright (c) 2021 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,57 @@ +# AWS X-Ray Support for hs-opentelemetry + + + +[![CI](https://github.com/freckle/hs-opentelemetry-awsxray/actions/workflows/ci.yml/badge.svg)](https://github.com/freckle/hs-opentelemetry-awsxray/actions/workflows/ci.yml) + +An `IdGenerator` and `Propagator` for [`hs-opentelemetry-sdk`][sdk] that +generates and propagates `TraceId` and `SpanId` values that are [compatible with +AWS X-Ray][xray]. + +[sdk]: https://hackage.haskell.org/package/hs-opentelemetry-sdk +[xray]: https://docs.aws.amazon.com/xray/latest/devguide/xray-api-sendingdata.html#xray-api-traceids + +## Usage + +The API currently exposed by the `hs-opentelemetry-sdk` package lacks a +convenient way to modify the `TracerProviderOptions` (to tell it to use our +generator/propagator) as part of initialization. You basically have to +re-implement the internals of `initializeTracerProvider` to do so. + +While we plan to open a PR upstream to address the lack of API here, the +workaround approach has at least been been encapsulated in a module of this +library for convenience: + +```hs +import OpenTelemetry.AWSXRay +import OpenTelemetry.Trace +import OpenTelemetry.Trace.Setup +import OpenTelemetry.Trace.Setup.Lens + +main :: IO () +main = do + withTracerProvider modifyTracerProviderOptions $ \tracerProvider -> do + let tracer = makeTracer tracerProvider "my-app" tracerOptions + + -- do something with tracer + +modifyTracerProviderOptions :: TracerProviderOptions -> TracerProviderOptions +modifyTracerProviderOptions = + idGeneratorL .~ awsXRayIdGenerator + . propagatorL <>~ awsXRayContextPropagator +``` + +This example uses lens, but you certainly don't have to. + +## Additional References + +- https://docs.aws.amazon.com/xray/latest/devguide/xray-services-adot.html +- https://aws.amazon.com/blogs/opensource/migrating-x-ray-tracing-to-aws-distro-for-opentelemetry/ + +--- + +[CHANGELOG](./CHANGELOG.md) | [LICENSE](./LICENSE) diff --git a/hs-opentelemetry-awsxray.cabal b/hs-opentelemetry-awsxray.cabal new file mode 100644 --- /dev/null +++ b/hs-opentelemetry-awsxray.cabal @@ -0,0 +1,108 @@ +cabal-version: 1.18 +name: hs-opentelemetry-awsxray +version: 0.1.0.0 +license: MIT +license-file: LICENSE +maintainer: Freckle Education +homepage: https://github.com/freckle/hs-opentelemetry-awsxray#readme +bug-reports: https://github.com/freckle/hs-opentelemetry-awsxray/issues +synopsis: [synopsis] +description: Please see README.md +category: Utils +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/hs-opentelemetry-awsxray + +library + exposed-modules: + OpenTelemetry.AWSXRay.Baggage + OpenTelemetry.AWSXRay.IdGenerator + OpenTelemetry.AWSXRay.Propagator + OpenTelemetry.AWSXRay.TraceInfo + OpenTelemetry.Trace.Setup + OpenTelemetry.Trace.Setup.Lens + + hs-source-dirs: library + other-modules: Paths_hs_opentelemetry_awsxray + default-language: Haskell2010 + default-extensions: + BangPatterns DataKinds DeriveAnyClass DeriveFoldable DeriveFunctor + DeriveGeneric DeriveLift DeriveTraversable DerivingStrategies + FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving + LambdaCase MultiParamTypeClasses NoImplicitPrelude + NoMonomorphismRestriction OverloadedStrings RankNTypes + RecordWildCards ScopedTypeVariables StandaloneDeriving + TypeApplications TypeFamilies + + ghc-options: + -Weverything -Wno-missing-exported-signatures + -Wno-missing-import-lists -Wno-missing-local-signatures + -Wno-monomorphism-restriction -Wno-unsafe -Wno-safe + + build-depends: + base >=4.11.1.0 && <5, + bytestring, + errors, + hs-opentelemetry-api, + hs-opentelemetry-sdk, + http-types, + memory, + microlens, + random >=1.2.1, + text, + time, + unliftio, + unliftio-core, + unordered-containers + + if impl(ghc >=9.2) + ghc-options: -Wno-missing-kind-signatures + + if impl(ghc >=8.10) + ghc-options: + -Wno-missing-safe-haskell-mode -Wno-prepositive-qualified-module + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: tests + other-modules: + OpenTelemetry.AWSXRay.TraceInfoSpec + Paths_hs_opentelemetry_awsxray + + default-language: Haskell2010 + default-extensions: + BangPatterns DataKinds DeriveAnyClass DeriveFoldable DeriveFunctor + DeriveGeneric DeriveLift DeriveTraversable DerivingStrategies + FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving + LambdaCase MultiParamTypeClasses NoImplicitPrelude + NoMonomorphismRestriction OverloadedStrings RankNTypes + RecordWildCards ScopedTypeVariables StandaloneDeriving + TypeApplications TypeFamilies + + ghc-options: + -Weverything -Wno-missing-exported-signatures + -Wno-missing-import-lists -Wno-missing-local-signatures + -Wno-monomorphism-restriction -Wno-unsafe -Wno-safe -threaded + -rtsopts -with-rtsopts=-N + + build-depends: + base >=4.11.1.0 && <5, + hs-opentelemetry-api, + hs-opentelemetry-awsxray, + hspec, + text, + unordered-containers + + if impl(ghc >=9.2) + ghc-options: -Wno-missing-kind-signatures + + if impl(ghc >=8.10) + ghc-options: + -Wno-missing-safe-haskell-mode -Wno-prepositive-qualified-module diff --git a/library/OpenTelemetry/AWSXRay/Baggage.hs b/library/OpenTelemetry/AWSXRay/Baggage.hs new file mode 100644 --- /dev/null +++ b/library/OpenTelemetry/AWSXRay/Baggage.hs @@ -0,0 +1,52 @@ +-- | Functions for dealing with 'Baggage' +-- +-- We ported specs about 'Baggage' from the Java Propagator: +-- +-- +-- +-- And using the obvious 'encodeBaggageHeader'/'decodeBaggageHeader' functions +-- fails them. So, we roll our own stuff here. +-- +module OpenTelemetry.AWSXRay.Baggage + ( decode + , encode + , module OpenTelemetry.Baggage + ) where + +import Prelude + +import Control.Applicative (Alternative) +import Control.Arrow ((***)) +import Control.Error.Util (hush) +import Control.Monad (guard) +import Data.ByteString (ByteString) +import qualified Data.HashMap.Strict as HashMap +import Data.Maybe (mapMaybe) +import Data.Text.Encoding (decodeUtf8', encodeUtf8) +import OpenTelemetry.Baggage (Baggage, Element, Token) +import OpenTelemetry.Baggage as Baggage + +-- | Only returns 'Just' if the 'Baggage' is not empty +decode :: [(ByteString, ByteString)] -> Maybe Baggage +decode = + guarded (/= Baggage.empty) + . Baggage.fromHashMap + . HashMap.fromList + . mapMaybe decodePart + . filter ((`notElem` nonBaggageKeys) . fst) + where nonBaggageKeys = ["Root", "Parent", "Sampled"] + +decodePart :: (ByteString, ByteString) -> Maybe (Token, Element) +decodePart (bsToken, bsElement) = + (,) + <$> (Baggage.mkToken =<< hush (decodeUtf8' bsToken)) + <*> (Baggage.element <$> hush (decodeUtf8' bsElement)) + +encode :: Baggage -> [(ByteString, ByteString)] +encode = map encodePart . HashMap.toList . Baggage.values + +encodePart :: (Token, Element) -> (ByteString, ByteString) +encodePart = Baggage.tokenValue *** encodeUtf8 . Baggage.value + +guarded :: Alternative f => (a -> Bool) -> a -> f a +guarded p x = x <$ guard (p x) diff --git a/library/OpenTelemetry/AWSXRay/IdGenerator.hs b/library/OpenTelemetry/AWSXRay/IdGenerator.hs new file mode 100644 --- /dev/null +++ b/library/OpenTelemetry/AWSXRay/IdGenerator.hs @@ -0,0 +1,56 @@ +-- | +-- +-- +-- +module OpenTelemetry.AWSXRay.IdGenerator + ( XRayIdGenerationError + , awsXRayIdGenerator + ) where + +import Prelude + +import Control.Monad (replicateM) +import Data.ByteArray.Encoding (convertFromBase) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BS8 +import Data.Char (intToDigit) +import Data.Time.Clock.POSIX (getPOSIXTime) +import Numeric (showHex) +import OpenTelemetry.Trace.Id (Base(..)) +import OpenTelemetry.Trace.Id.Generator +import OpenTelemetry.Trace.Id.Generator.Default +import System.Random.Stateful (applyAtomicGen, globalStdGen, uniformR) +import UnliftIO.Exception (Exception(..), throwIO) + +data XRayIdGenerationError = FailedToConvert ByteString Base String + deriving stock Show + +instance Exception XRayIdGenerationError where + displayException = \case + FailedToConvert bs base message -> + "Failed to convert generated bytestring (" + <> show bs + <> ") in " + <> show base + <> ": " + <> message + +awsXRayIdGenerator :: IdGenerator +awsXRayIdGenerator = IdGenerator + { generateSpanIdBytes = generateSpanIdBytes defaultIdGenerator + , generateTraceIdBytes = generateXRayTraceIdBytes + } + +generateXRayTraceIdBytes :: IO ByteString +generateXRayTraceIdBytes = do + epoch <- round @_ @Int <$> getPOSIXTime + unique <- replicateM 24 randomHex + + let + tid = BS8.pack $ showHex epoch "" <> unique + base = Base16 + + either (throwIO . FailedToConvert tid base) pure $ convertFromBase base tid + +randomHex :: IO Char +randomHex = intToDigit <$> applyAtomicGen (uniformR (1, 15)) globalStdGen diff --git a/library/OpenTelemetry/AWSXRay/Propagator.hs b/library/OpenTelemetry/AWSXRay/Propagator.hs new file mode 100644 --- /dev/null +++ b/library/OpenTelemetry/AWSXRay/Propagator.hs @@ -0,0 +1,39 @@ +module OpenTelemetry.AWSXRay.Propagator + ( awsXRayContextPropagator + , awsXRayContextPropagatorOnError + ) where + +import Prelude + +import Control.Error.Util (note) +import Network.HTTP.Types.Header (HeaderName, RequestHeaders, ResponseHeaders) +import OpenTelemetry.AWSXRay.TraceInfo +import OpenTelemetry.Context + (Context, insertBaggage, insertSpan, lookupBaggage, lookupSpan) +import OpenTelemetry.Propagator +import OpenTelemetry.Trace.Core (getSpanContext, wrapSpanContext) + +awsXRayContextPropagator :: Propagator Context RequestHeaders ResponseHeaders +awsXRayContextPropagator = awsXRayContextPropagatorOnError $ \_ _ -> pure () + +awsXRayContextPropagatorOnError + :: (RequestHeaders -> String -> IO ()) + -- ^ Called on failure to find or parse an @X-Amzn-Trace-Id@ header + -> Propagator Context RequestHeaders ResponseHeaders +awsXRayContextPropagatorOnError onErr = Propagator + { propagatorNames = ["awsxray trace context"] + , extractor = \hs c -> do + case fromXRayHeader =<< note "not found" (lookup hAmznTraceId hs) of + Left err -> c <$ onErr hs err + Right TraceInfo {..} -> do + let wrapped = wrapSpanContext spanContext + pure $ maybe id insertBaggage baggage $ insertSpan wrapped c + , injector = \c hs -> case lookupSpan c of + Nothing -> pure hs + Just sp -> do + info <- TraceInfo <$> getSpanContext sp <*> pure (lookupBaggage c) + pure $ (hAmznTraceId, toXRayHeader info) : hs + } + +hAmznTraceId :: HeaderName +hAmznTraceId = "X-Amzn-Trace-Id" diff --git a/library/OpenTelemetry/AWSXRay/TraceInfo.hs b/library/OpenTelemetry/AWSXRay/TraceInfo.hs new file mode 100644 --- /dev/null +++ b/library/OpenTelemetry/AWSXRay/TraceInfo.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE NamedFieldPuns #-} + +-- | +-- +-- +-- +-- Example: +-- +-- @Root=1-5759e988-bd862e3fe1be46a994272793;Parent=53995c3f42cd8ad8;Sampled=1@ +-- +-- @Root=1-{epoch}-{unique}[;Parent={spanId}][;Sampled={1|0}][;meta=attr...]@ +-- +module OpenTelemetry.AWSXRay.TraceInfo + ( TraceInfo(..) + , fromXRayHeader + , toXRayHeader + ) where + +import Prelude + +import Control.Error.Util (note) +import Data.Bifunctor (first) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import qualified OpenTelemetry.AWSXRay.Baggage as Baggage +import OpenTelemetry.Baggage (Baggage) +import OpenTelemetry.Trace (SpanContext(..)) +import OpenTelemetry.Trace.Core + (defaultTraceFlags, isSampled, setSampled, unsetSampled) +import OpenTelemetry.Trace.Id + ( Base(..) + , baseEncodedToSpanId + , baseEncodedToTraceId + , spanIdBaseEncodedByteString + , traceIdBaseEncodedByteString + ) +import qualified OpenTelemetry.Trace.TraceState as TS + +-- | The data to read/write from the @X-Amzn-TraceId@ header +data TraceInfo = TraceInfo + { spanContext :: SpanContext + , baggage :: Maybe Baggage + } + deriving stock Show + +fromXRayHeader :: ByteString -> Either String TraceInfo +fromXRayHeader bs = do + kv <- bsToKeyValues bs + + root <- note "Root not present" $ lookup "Root" kv + traceId <- case bsSplitOn '-' root of + ["1", epoch, unique] -> do + let + -- AWS may trim leading zeros from epoch; we must put them back for it + -- to be valid for OTel + epochUnique = bsLeftPad 8 '0' epoch <> unique + errorPrefix = + "Root epoch+unique (" + <> show epochUnique + <> ") is not a valid TraceId" + prefix errorPrefix $ baseEncodedToTraceId Base16 epochUnique + _ -> Left "Splitting on - did not produce exactly 3 parts" + + parent <- note "Parent not present" $ lookup "Parent" kv + spanId <- prefix "Parent is not a valid SpanId" + $ baseEncodedToSpanId Base16 parent + + let + sampled = (== Just "1") $ lookup "Sampled" kv + + traceFlags = + (if sampled then setSampled else unsetSampled) defaultTraceFlags + + baggage = Baggage.decode kv + + pure $ TraceInfo + { spanContext = SpanContext + { traceFlags + , traceId + , spanId + , isRemote = True + , traceState = TS.empty + } + , baggage + } + +toXRayHeader :: TraceInfo -> ByteString +toXRayHeader TraceInfo { spanContext, baggage } = + bsFromKeyValues + $ [ ("Root", "1-" <> epoch <> "-" <> unique) + , ("Parent", spanIdBaseEncodedByteString Base16 spanId) + , ("Sampled", if isSampled traceFlags then "1" else "0") + ] + <> maybe [] Baggage.encode baggage + where + SpanContext { traceId, spanId, traceFlags } = spanContext + (epoch, unique) = BS.splitAt 8 $ traceIdBaseEncodedByteString Base16 traceId + +prefix :: String -> Either String a -> Either String a +prefix p = first (\e -> p <> ": " <> e) + +bsToKeyValues :: ByteString -> Either String [(ByteString, ByteString)] +bsToKeyValues = traverse go . bsSplitOn ';' + where + go bs = case bsSplitOn '=' bs of + k : vs -> Right (k, mconcat vs) + _ -> Left "No = found in key-value piece" + +bsFromKeyValues :: [(ByteString, ByteString)] -> ByteString +bsFromKeyValues = BS.intercalate ";" . map (\(k, v) -> k <> "=" <> v) + +bsLeftPad :: Int -> Char -> ByteString -> ByteString +bsLeftPad n c bs + | diff > 0 = BS8.replicate diff c <> bs + | otherwise = bs + where diff = BS.length bs - n + +bsSplitOn :: Char -> ByteString -> [ByteString] +bsSplitOn c = BS8.splitWith (== c) diff --git a/library/OpenTelemetry/Trace/Setup.hs b/library/OpenTelemetry/Trace/Setup.hs new file mode 100644 --- /dev/null +++ b/library/OpenTelemetry/Trace/Setup.hs @@ -0,0 +1,45 @@ +-- | Initialization of a 'TracerProvider' with modified 'TracerProviderOptions' +module OpenTelemetry.Trace.Setup + ( withTracerProvider + ) where + +import Prelude + +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.IO.Unlift (MonadUnliftIO(..)) +import OpenTelemetry.Trace + ( TracerProvider + , TracerProviderOptions + , createTracerProvider + , getTracerProviderInitializationOptions + , setGlobalTracerProvider + ) +import qualified OpenTelemetry.Trace as Trace +import UnliftIO.Exception (bracket) + +withTracerProvider + :: MonadUnliftIO m + => (TracerProviderOptions -> TracerProviderOptions) + -> (TracerProvider -> m a) + -> m a +withTracerProvider setup = + bracket (initializeGlobalTracerProvider setup) shutdownTracerProvider + +initializeGlobalTracerProvider + :: MonadIO m + => (TracerProviderOptions -> TracerProviderOptions) + -> m TracerProvider +initializeGlobalTracerProvider setup = liftIO $ do + t <- initializeTracerProvider setup + t <$ setGlobalTracerProvider t + +initializeTracerProvider + :: MonadIO m + => (TracerProviderOptions -> TracerProviderOptions) + -> m TracerProvider +initializeTracerProvider setup = liftIO $ do + (processors, opts) <- getTracerProviderInitializationOptions + createTracerProvider processors $ setup opts + +shutdownTracerProvider :: MonadIO m => TracerProvider -> m () +shutdownTracerProvider = liftIO . Trace.shutdownTracerProvider diff --git a/library/OpenTelemetry/Trace/Setup/Lens.hs b/library/OpenTelemetry/Trace/Setup/Lens.hs new file mode 100644 --- /dev/null +++ b/library/OpenTelemetry/Trace/Setup/Lens.hs @@ -0,0 +1,56 @@ +-- | Lenses for modifying a 'TracerProviderOptions' +module OpenTelemetry.Trace.Setup.Lens + ( idGeneratorL + , samplerL + , resourcesL + , attributeLimitsL + , spanLimitsL + , propagatorL + , loggerL + ) where + +import Prelude + +import Data.Text (Text) +import Lens.Micro (Lens', lens) +import Network.HTTP.Types.Header (RequestHeaders, ResponseHeaders) +import OpenTelemetry.Attributes (AttributeLimits) +import OpenTelemetry.Context (Context) +import OpenTelemetry.Logging.Core (Log) +import OpenTelemetry.Propagator (Propagator) +import OpenTelemetry.Resource (MaterializedResources) +import OpenTelemetry.Trace (TracerProviderOptions(..)) +import OpenTelemetry.Trace.Core (SpanLimits) +import OpenTelemetry.Trace.Id.Generator (IdGenerator) +import OpenTelemetry.Trace.Sampler (Sampler) + +idGeneratorL :: Lens' TracerProviderOptions IdGenerator +idGeneratorL = lens tracerProviderOptionsIdGenerator + $ \x y -> x { tracerProviderOptionsIdGenerator = y } + +samplerL :: Lens' TracerProviderOptions Sampler +samplerL = lens tracerProviderOptionsSampler + $ \x y -> x { tracerProviderOptionsSampler = y } + +resourcesL :: Lens' TracerProviderOptions MaterializedResources +resourcesL = lens tracerProviderOptionsResources + $ \x y -> x { tracerProviderOptionsResources = y } + +attributeLimitsL :: Lens' TracerProviderOptions AttributeLimits +attributeLimitsL = lens tracerProviderOptionsAttributeLimits + $ \x y -> x { tracerProviderOptionsAttributeLimits = y } + +spanLimitsL :: Lens' TracerProviderOptions SpanLimits +spanLimitsL = lens tracerProviderOptionsSpanLimits + $ \x y -> x { tracerProviderOptionsSpanLimits = y } + +propagatorL + :: Lens' + TracerProviderOptions + (Propagator Context RequestHeaders ResponseHeaders) +propagatorL = lens tracerProviderOptionsPropagators + $ \x y -> x { tracerProviderOptionsPropagators = y } + +loggerL :: Lens' TracerProviderOptions (Log Text -> IO ()) +loggerL = lens tracerProviderOptionsLogger + $ \x y -> x { tracerProviderOptionsLogger = y } diff --git a/package.yaml b/package.yaml new file mode 100644 --- /dev/null +++ b/package.yaml @@ -0,0 +1,90 @@ +name: hs-opentelemetry-awsxray +version: 0.1.0.0 +maintainer: Freckle Education +category: Utils +github: freckle/hs-opentelemetry-awsxray +synopsis: "[synopsis]" +description: Please see README.md + +extra-doc-files: + - README.md + - CHANGELOG.md + +extra-source-files: + - package.yaml + +ghc-options: + - -Weverything + - -Wno-missing-exported-signatures # re-enables missing-signatures + - -Wno-missing-import-lists + - -Wno-missing-local-signatures + - -Wno-monomorphism-restriction + - -Wno-unsafe + - -Wno-safe + +when: + - condition: "impl(ghc >= 9.2)" + ghc-options: + - -Wno-missing-kind-signatures + - condition: "impl(ghc >= 8.10)" + ghc-options: + - -Wno-missing-safe-haskell-mode + - -Wno-prepositive-qualified-module + +dependencies: + - base < 5 + +default-extensions: + - BangPatterns + - DataKinds + - DeriveAnyClass + - DeriveFoldable + - DeriveFunctor + - DeriveGeneric + - DeriveLift + - DeriveTraversable + - DerivingStrategies + - FlexibleContexts + - FlexibleInstances + - GADTs + - GeneralizedNewtypeDeriving + - LambdaCase + - MultiParamTypeClasses + - NoImplicitPrelude + - NoMonomorphismRestriction + - OverloadedStrings + - RankNTypes + - RecordWildCards + - ScopedTypeVariables + - StandaloneDeriving + - TypeApplications + - TypeFamilies + +library: + source-dirs: library + dependencies: + - bytestring + - errors + - hs-opentelemetry-api + - hs-opentelemetry-sdk + - http-types + - memory + - microlens + - random >= 1.2.1 # globalStdGen + - text + - time + - unliftio + - unliftio-core + - unordered-containers + +tests: + spec: + main: Spec.hs + source-dirs: tests + ghc-options: -threaded -rtsopts "-with-rtsopts=-N" + dependencies: + - hs-opentelemetry-api + - hs-opentelemetry-awsxray + - hspec + - text + - unordered-containers diff --git a/tests/OpenTelemetry/AWSXRay/TraceInfoSpec.hs b/tests/OpenTelemetry/AWSXRay/TraceInfoSpec.hs new file mode 100644 --- /dev/null +++ b/tests/OpenTelemetry/AWSXRay/TraceInfoSpec.hs @@ -0,0 +1,90 @@ +module OpenTelemetry.AWSXRay.TraceInfoSpec + ( spec + ) where + +import Prelude + +import Data.Either (isLeft) +import qualified Data.HashMap.Strict as HashMap +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import OpenTelemetry.AWSXRay.TraceInfo +import OpenTelemetry.Baggage (Token) +import qualified OpenTelemetry.Baggage as Baggage +import OpenTelemetry.Trace.Core (isSampled, traceFlags) +import Test.Hspec + +spec :: Spec +spec = do + it "round trips an example" $ do + let + h = + "Root=1-5759e988-bd862e3fe1be46a994272793" + <> ";Parent=53995c3f42cd8ad8" + <> ";Sampled=1" + + fmap toXRayHeader (fromXRayHeader h) `shouldBe` Right h + + it "round trips an example with baggage" $ do + let + h = + "Root=1-5759e988-bd862e3fe1be46a994272793" + <> ";Parent=53995c3f42cd8ad8" + <> ";Sampled=1" + <> ";baz=bat" -- order matters due to HashMap + <> ";foo=bar" + + fmap toXRayHeader (fromXRayHeader h) `shouldBe` Right h + + describe "fromXRayHeader" $ do + it "requires Parent" $ do + fromXRayHeader "Root=1-5759e988-bd862e3fe1be46a994272793" + `shouldSatisfy` isLeft + + context "Sampled" $ do + it "defaults False" $ do + let + eInfo = + fromXRayHeader + $ "Root=1-5759e988-bd862e3fe1be46a994272793" + <> ";Parent=53995c3f42cd8ad8" + + fmap (isSampled . traceFlags . spanContext) eInfo `shouldBe` Right False + + it "interprets =1 as True" $ do + let + eInfo = + fromXRayHeader + $ "Root=1-5759e988-bd862e3fe1be46a994272793" + <> ";Parent=53995c3f42cd8ad8" + <> ";Sampled=1" + + fmap (isSampled . traceFlags . spanContext) eInfo `shouldBe` Right True + + it "interprets other values as as False" $ do + let + eInfo = + fromXRayHeader + $ "Root=1-5759e988-bd862e3fe1be46a994272793" + <> ";Parent=53995c3f42cd8ad8" + <> ";Sampled=flipFlop" + + fmap (isSampled . traceFlags . spanContext) eInfo `shouldBe` Right False + + it "grabs all other values as Baggage" $ do + let + eInfo = + fromXRayHeader + $ "Root=1-5759e988-bd862e3fe1be46a994272793" + <> ";Parent=53995c3f42cd8ad8" + <> ";foo=bar;baz=bat" + + fmap baggage eInfo `shouldBe` Right + (Just $ Baggage.fromHashMap $ HashMap.fromList + [ (mkTokenUnsafe "foo", Baggage.element "bar") + , (mkTokenUnsafe "baz", Baggage.element "bat") + ] + ) + +mkTokenUnsafe :: Text -> Token +mkTokenUnsafe = fromMaybe (error "not a valid Token") . Baggage.mkToken diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover -Wno-missing-export-lists #-}