diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,7 @@ +# Change Log + +## 0.0.0.0 + +2023.10.03 + +- Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Ian Duncan (c) 2021 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/benchmark/header-codec/main.hs b/benchmark/header-codec/main.hs new file mode 100644 --- /dev/null +++ b/benchmark/header-codec/main.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +import Control.DeepSeq (NFData) +import qualified Criterion.Main as C +import qualified Data.ByteString.Short as SB +import OpenTelemetry.Propagator.Datadog.Internal +import OpenTelemetry.Trace.Id (TraceId) +import qualified String + + +main :: IO () +main = + C.defaultMain + [ C.bgroup + "newTraceIdFromHeader" + [ C.bench "new" $ C.nf newTraceIdFromHeader "1" + , C.bench "old" $ C.nf String.newTraceIdFromHeader "1" + ] + , C.bgroup "newHeaderFromTraceId" $ + let value = SB.pack [0, 1, 2, 3, 4, 5, 6, 7, 8, 8, 10, 11, 12, 13, 14, 15] + in [ C.bench "new" $ C.nf newHeaderFromTraceId value + , C.bench "old" $ C.nf String.newHeaderFromTraceId value + ] + ] + + +instance NFData TraceId diff --git a/hs-opentelemetry-propagator-datadog.cabal b/hs-opentelemetry-propagator-datadog.cabal new file mode 100644 --- /dev/null +++ b/hs-opentelemetry-propagator-datadog.cabal @@ -0,0 +1,103 @@ +cabal-version: 2.4 + +name: hs-opentelemetry-propagator-datadog +version: 0.0.0.0 +author: Kazuki Okamoto (岡本和樹) +maintainer: kazuki.okamoto@herp.co.jp +copyright: Kazuki Okamoto (岡本和樹), HERP, Inc. +license: BSD-3-Clause +license-file: LICENSE +category: Telemetry +homepage: https://github.com/iand675/hs-opentelemetry +bug-reports: https://github.com/iand675/hs-opentelemetry/issues +synopsis: Datadog Propagator for OpenTelemetry +description: This package provides a Datadog style propagator for hs-opentelemetry suite. + +extra-doc-files: + CHANGELOG.md + LICENSE + +common common + build-depends: base >= 4 && < 5 + ghc-options: -Wall + if impl(ghc >= 8.0) + ghc-options: -Wcompat + default-language: Haskell2010 + +library + import: common + hs-source-dirs: src + exposed-modules: OpenTelemetry.Propagator.Datadog + OpenTelemetry.Propagator.Datadog.Internal + build-depends: bytestring < 0.11, + hs-opentelemetry-api >= 0.1 && < 0.2, + hs-opentelemetry-sdk >= 0.0 && < 0.1, + http-types < 0.13, + primitive < 0.9, + text < 1.3, + ghc-options: -Wcompat + -Wno-name-shadowing + if impl(ghc >= 6.4) + ghc-options: -Wincomplete-record-updates + if impl(ghc >= 6.8) + ghc-options: -Wmonomorphism-restriction + if impl(ghc >= 7.0) + ghc-options: -Wmissing-import-lists + if impl(ghc >= 7.2) + ghc-options: -Wincomplete-uni-patterns + -Widentities + if impl(ghc >= 8.0) + ghc-options: -Wmissing-exported-signatures + -Wredundant-constraints + if impl(ghc >= 8.2) + ghc-options: -Wmissing-home-modules + if impl(ghc >= 8.4) + ghc-options: -Wmissing-export-lists + -Wpartial-fields + if impl(ghc >= 8.8) + ghc-options: -Wmissing-deriving-strategies + if impl(ghc >= 8.10) + ghc-options: -Wunused-packages + if impl(ghc >= 9.0) + ghc-options: -Winvalid-haddock + if impl(ghc >= 9.2) + ghc-options: -Wmissing-kind-signatures + -Woperator-whitespace + -Wredundant-bang-patterns + +test-suite spec + import: common + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: test/spec + old-src + other-modules: OpenTelemetry.Propagator.DatadogSpec + OpenTelemetry.Propagator.Datadog.InternalSpec + Raw + String + build-depends: hs-opentelemetry-propagator-datadog, + hs-opentelemetry-api, + bytestring, + hspec, + pretty-hex, + primitive, + QuickCheck + ghc-options: -threaded + -rtsopts + -with-rtsopts=-N + build-tool-depends: hspec-discover:hspec-discover + +benchmark header-codec + import: common + type: exitcode-stdio-1.0 + main-is: main.hs + other-modules: Raw + String + hs-source-dirs: benchmark/header-codec + old-src + build-depends: hs-opentelemetry-propagator-datadog, + hs-opentelemetry-api, + bytestring, + criterion, + deepseq, + primitive diff --git a/old-src/Raw.hs b/old-src/Raw.hs new file mode 100644 --- /dev/null +++ b/old-src/Raw.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Strict #-} + +module Raw ( + newTraceIdFromHeader, + newSpanIdFromHeader, + newHeaderFromTraceId, + newHeaderFromSpanId, + showWord64BS, + readWord64BS, + asciiWord8ToWord8, + word8ToAsciiWord8, +) where + +import Control.Monad.ST (ST, runST) +import Data.Bits (Bits (complement, shift, (.&.))) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Internal as BI +import Data.ByteString.Short (ShortByteString) +import qualified Data.ByteString.Short.Internal as SBI +import qualified Data.Char as C +import Data.Primitive.ByteArray ( + ByteArray (ByteArray), + MutableByteArray, + freezeByteArray, + indexByteArray, + newByteArray, + writeByteArray, + ) +import Data.Primitive.Ptr (writeOffPtr) +import Data.Word (Word64, Word8) +import Foreign.ForeignPtr (withForeignPtr) +import Foreign.Storable (peekElemOff) +import System.IO.Unsafe (unsafeDupablePerformIO) + + +newTraceIdFromHeader + :: ByteString + -- ^ ASCII numeric text + -> ShortByteString +newTraceIdFromHeader bs = + let len = 16 :: Int + !(ByteArray ba) = + runST $ do + mba <- newByteArray len + let w64 = readWord64BS bs + writeByteArray mba 0 (0 :: Word64) -- fill zeros to one upper Word64-size area + writeByteArrayNbo mba 1 w64 -- offset one Word64-size + freezeByteArray mba 0 len + in SBI.SBS ba + + +newSpanIdFromHeader + :: ByteString + -- ^ ASCII numeric text + -> ShortByteString +newSpanIdFromHeader bs = + let len = 8 :: Int + !(ByteArray ba) = + runST $ do + mba <- newByteArray len + let w64 = readWord64BS bs + writeByteArrayNbo mba 0 w64 + freezeByteArray mba 0 len + in SBI.SBS ba + + +{- | Write a primitive value to the byte array with network-byte-order (big-endian). +The offset is given in elements of type @a@ rather than in bytes. +-} +writeByteArrayNbo :: MutableByteArray s -> Int -> Word64 -> ST s () +writeByteArrayNbo mba offset value = do + writeByteArray mba offset (0 :: Word64) + loop 0 value + where + loop _ 0 = pure () + loop 8 _ = pure () + loop n v = do + let -- equivelent: + -- (p, q) = v `divMod` (2 ^ (8 :: Int)) + p = shift v (-8) + q = v .&. complement (shift p 8) + writeByteArray mba (8 * (offset + 1) - n - 1) (fromIntegral q :: Word8) + loop (n + 1) p + + +readWord64BS :: ByteString -> Word64 +readWord64BS (BI.PS fptr _ len) = + unsafeDupablePerformIO $ + withForeignPtr fptr readWord64Ptr + where + readWord64Ptr ptr = + readWord64PtrOffset 0 0 + where + readWord64PtrOffset offset acc + | offset < len = do + b <- peekElemOff ptr offset + let n = fromIntegral $ asciiWord8ToWord8 b :: Word64 + readWord64PtrOffset (offset + 1) $ n + acc * 10 + | otherwise = pure acc + + +asciiWord8ToWord8 :: Word8 -> Word8 +asciiWord8ToWord8 b = b - fromIntegral (C.ord '0') + + +newHeaderFromTraceId :: ShortByteString -> ByteString +newHeaderFromTraceId (SBI.SBS ba) = + let w64 = indexByteArrayNbo (ByteArray ba) 1 + in showWord64BS w64 + + +newHeaderFromSpanId :: ShortByteString -> ByteString +newHeaderFromSpanId (SBI.SBS ba) = + let w64 = indexByteArrayNbo (ByteArray ba) 0 + in showWord64BS w64 + + +indexByteArrayNbo :: ByteArray -> Int -> Word64 +indexByteArrayNbo ba offset = + loop 0 0 + where + loop 8 acc = acc + loop n acc = loop (n + 1) $ shift acc 8 + word8ToWord64 (indexByteArray ba $ 8 * offset + n) + + +showWord64BS :: Word64 -> ByteString +showWord64BS v = + unsafeDupablePerformIO $ + BI.createUptoN 20 writeWord64Ptr -- 20 = length (show (maxBound :: Word64)) + where + writeWord64Ptr ptr = + loop (19 :: Int) v 0 False + where + loop 0 v offset _ = do + writeOffPtr ptr offset (word8ToAsciiWord8 $ fromIntegral v) + pure $ offset + 1 + loop n v offset upper = do + let (p, q) = v `divMod` (10 ^ n) + if p == 0 && not upper + then loop (n - 1) q offset upper + else do + writeOffPtr ptr offset (word8ToAsciiWord8 $ fromIntegral p) + loop (n - 1) q (offset + 1) True + + +word8ToAsciiWord8 :: Word8 -> Word8 +word8ToAsciiWord8 b = b + fromIntegral (C.ord '0') + + +word8ToWord64 :: Word8 -> Word64 +word8ToWord64 = fromIntegral diff --git a/old-src/String.hs b/old-src/String.hs new file mode 100644 --- /dev/null +++ b/old-src/String.hs @@ -0,0 +1,41 @@ +module String where + +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BC +import qualified Data.ByteString.Short as SB +import Data.Word (Word64) + + +newTraceIdFromHeader :: ByteString -> SB.ShortByteString +newTraceIdFromHeader = SB.toShort . fillLeadingZeros 16 . convertWord64ToBinaryByteString . read . BC.unpack + + +newSpanIdFromHeader :: ByteString -> SB.ShortByteString +newSpanIdFromHeader = SB.toShort . fillLeadingZeros 8 . convertWord64ToBinaryByteString . read . BC.unpack + + +newHeaderFromTraceId :: SB.ShortByteString -> ByteString +newHeaderFromTraceId = BC.pack . show . convertBinaryByteStringToWord64 . SB.fromShort + + +newHeaderFromSpanId :: SB.ShortByteString -> ByteString +newHeaderFromSpanId = BC.pack . show . convertBinaryByteStringToWord64 . SB.fromShort + + +convertWord64ToBinaryByteString :: Word64 -> ByteString +convertWord64ToBinaryByteString = + B.pack . toWord8s [] + where + toWord8s acc 0 = acc + toWord8s acc n = + let (p, q) = n `divMod` (2 ^ (8 :: Int)) + in toWord8s (fromIntegral q : acc) p + + +fillLeadingZeros :: Word -> ByteString -> ByteString +fillLeadingZeros len bs = B.replicate (fromIntegral len - B.length bs) 0 <> bs + + +convertBinaryByteStringToWord64 :: ByteString -> Word64 +convertBinaryByteStringToWord64 = B.foldl (\acc b -> (2 ^ (8 :: Int)) * acc + fromIntegral b) 0 -- GHC.Prim.indexWord8ArrayAsWord64# とか駆使すると早くなりそう diff --git a/src/OpenTelemetry/Propagator/Datadog.hs b/src/OpenTelemetry/Propagator/Datadog.hs new file mode 100644 --- /dev/null +++ b/src/OpenTelemetry/Propagator/Datadog.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module OpenTelemetry.Propagator.Datadog ( + datadogTraceContextPropagator, + convertOpenTelemetrySpanIdToDatadogSpanId, + convertOpenTelemetryTraceIdToDatadogTraceId, +) where + +import qualified Data.ByteString.Char8 as BC +import qualified Data.ByteString.Short.Internal as SBI +import Data.Primitive (ByteArray (ByteArray)) +import Data.String (IsString) +import qualified Data.Text as T +import Data.Word (Word64) +import Network.HTTP.Types ( + RequestHeaders, + ResponseHeaders, + ) +import OpenTelemetry.Common (TraceFlags (TraceFlags)) +import OpenTelemetry.Context ( + Context, + insertSpan, + lookupSpan, + ) +import OpenTelemetry.Internal.Trace.Id ( + SpanId (SpanId), + TraceId (TraceId), + ) +import OpenTelemetry.Propagator (Propagator (Propagator, extractor, injector, propagatorNames)) +import OpenTelemetry.Propagator.Datadog.Internal ( + indexByteArrayNbo, + newHeaderFromSpanId, + newHeaderFromTraceId, + newSpanIdFromHeader, + newTraceIdFromHeader, + ) +import OpenTelemetry.Trace (SpanContext (SpanContext, isRemote, spanId, traceFlags, traceId, traceState)) +import OpenTelemetry.Trace.Core ( + getSpanContext, + wrapSpanContext, + ) +import OpenTelemetry.Trace.TraceState (TraceState (TraceState)) +import qualified OpenTelemetry.Trace.TraceState as TS + + +-- Reference: bi-directional conversion of IDs of Open Telemetry and ones of Datadog +-- - English: https://docs.datadoghq.com/tracing/other_telemetry/connect_logs_and_traces/opentelemetry/ +-- - Japanese: https://docs.datadoghq.com/ja/tracing/connect_logs_and_traces/opentelemetry/ +datadogTraceContextPropagator :: Propagator Context RequestHeaders ResponseHeaders +datadogTraceContextPropagator = + Propagator + { propagatorNames = ["datadog trace context"] + , extractor = \hs c -> do + let spanContext' = do + traceId <- TraceId . newTraceIdFromHeader <$> lookup traceIdKey hs + parentId <- SpanId . newSpanIdFromHeader <$> lookup parentIdKey hs + samplingPriority <- T.pack . BC.unpack <$> lookup samplingPriorityKey hs + pure $ + SpanContext + { traceId + , spanId = parentId + , isRemote = True + , -- when 0, not sampled + -- refer: OpenTelemetry.Internal.Trace.Types.isSampled + traceFlags = TraceFlags 1 + , traceState = TraceState [(TS.Key samplingPriorityKey, TS.Value samplingPriority)] + } + case spanContext' of + Nothing -> pure c + Just spanContext -> pure $ insertSpan (wrapSpanContext spanContext) c + , injector = \c hs -> + case lookupSpan c of + Nothing -> pure hs + Just span' -> do + SpanContext {traceId, spanId, traceState = TraceState traceState} <- getSpanContext span' + let traceIdValue = (\(TraceId b) -> newHeaderFromTraceId b) traceId + parentIdValue = (\(SpanId b) -> newHeaderFromSpanId b) spanId + samplingPriority <- + case lookup (TS.Key samplingPriorityKey) traceState of + Nothing -> pure "1" -- when an origin of the trace + Just (TS.Value p) -> pure $ BC.pack $ T.unpack p + pure $ + (traceIdKey, traceIdValue) + : (parentIdKey, parentIdValue) + : (samplingPriorityKey, samplingPriority) + : hs + } + where + traceIdKey, parentIdKey, samplingPriorityKey :: (IsString s) => s + traceIdKey = "x-datadog-trace-id" + parentIdKey = "x-datadog-parent-id" + samplingPriorityKey = "x-datadog-sampling-priority" + + +convertOpenTelemetrySpanIdToDatadogSpanId :: SpanId -> Word64 +convertOpenTelemetrySpanIdToDatadogSpanId (SpanId (SBI.SBS a)) = indexByteArrayNbo (ByteArray a) 0 + + +convertOpenTelemetryTraceIdToDatadogTraceId :: TraceId -> Word64 +convertOpenTelemetryTraceIdToDatadogTraceId (TraceId (SBI.SBS a)) = indexByteArrayNbo (ByteArray a) 1 diff --git a/src/OpenTelemetry/Propagator/Datadog/Internal.hs b/src/OpenTelemetry/Propagator/Datadog/Internal.hs new file mode 100644 --- /dev/null +++ b/src/OpenTelemetry/Propagator/Datadog/Internal.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Strict #-} + +{- | Conversion of the hs-opentelemetry internal representation of the trace ID and the span ID and the Datadog header representation of them each other. + ++----------+-----------------+----------------+ +| | Trace ID | Span ID | ++----------+-----------------+----------------+ +| Internal | 128-bit integer | 64-bit integer | ++----------+-----------------+----------------+ +| Datadog | ASCII text of | ASCII text of | +| Header | 64-bit integer | 64-bit integer | ++----------+-----------------+----------------+ +-} +module OpenTelemetry.Propagator.Datadog.Internal ( + newTraceIdFromHeader, + newSpanIdFromHeader, + newHeaderFromTraceId, + newHeaderFromSpanId, + indexByteArrayNbo, +) where + +import Data.Bits (Bits (shift)) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Builder as BB +import qualified Data.ByteString.Internal as BI +import qualified Data.ByteString.Lazy as BL +import Data.ByteString.Short (ShortByteString) +import qualified Data.ByteString.Short as SB +import qualified Data.ByteString.Short.Internal as SBI +import qualified Data.Char as C +import Data.Primitive.ByteArray (ByteArray (ByteArray), indexByteArray) +import Data.Primitive.Ptr (writeOffPtr) +import Data.Word (Word64, Word8) +import Foreign.ForeignPtr (withForeignPtr) +import Foreign.Storable (peekElemOff) +import System.IO.Unsafe (unsafeDupablePerformIO) + + +newTraceIdFromHeader + :: ByteString + -- ^ ASCII text of 64-bit integer + -> ShortByteString + -- ^ 128-bit integer +newTraceIdFromHeader bs = + let w64 = readWord64BS bs + builder = BB.word64BE 0 <> BB.word64BE w64 + in SB.toShort $ BL.toStrict $ BB.toLazyByteString builder + + +newSpanIdFromHeader + :: ByteString + -- ^ ASCII text of 64-bit integer + -> ShortByteString + -- ^ 64-bit integer +newSpanIdFromHeader bs = + let w64 = readWord64BS bs + builder = BB.word64BE w64 + in SB.toShort $ BL.toStrict $ BB.toLazyByteString builder + + +readWord64BS :: ByteString -> Word64 +readWord64BS (BI.PS fptr _ len) = + -- Safe. + unsafeDupablePerformIO $ + withForeignPtr fptr readWord64Ptr + where + readWord64Ptr ptr = + readWord64PtrOffset 0 0 + where + readWord64PtrOffset offset acc + | offset < len = do + b <- peekElemOff ptr offset + let n = fromIntegral $ asciiWord8ToWord8 b :: Word64 + readWord64PtrOffset (offset + 1) $ n + acc * 10 + | otherwise = pure acc + + +asciiWord8ToWord8 :: Word8 -> Word8 +asciiWord8ToWord8 b = b - fromIntegral (C.ord '0') + + +newHeaderFromTraceId + :: ShortByteString + -- ^ 128-bit integer + -> ByteString + -- ^ ASCII text of 64-bit integer +newHeaderFromTraceId (SBI.SBS ba) = + let w64 = indexByteArrayNbo (ByteArray ba) 1 + in showWord64BS w64 + + +newHeaderFromSpanId + :: ShortByteString + -- ^ 64-bit integer + -> ByteString + -- ^ ASCII text of 64-bit integer +newHeaderFromSpanId (SBI.SBS ba) = + let w64 = indexByteArrayNbo (ByteArray ba) 0 + in showWord64BS w64 + + +-- | Read 'ByteArray' to 'Word64' with network-byte-order. +indexByteArrayNbo + :: ByteArray + -> Int + -- ^ Offset in 'Word64'-size unit + -> Word64 +indexByteArrayNbo ba offset = + loop 0 0 + where + loop 8 acc = acc + loop n acc = loop (n + 1) $ shift acc 8 + word8ToWord64 (indexByteArray ba $ 8 * offset + n) + + +showWord64BS :: Word64 -> ByteString +showWord64BS v = + -- Safe. + unsafeDupablePerformIO $ + BI.createUptoN 20 writeWord64Ptr -- 20 = length (show (maxBound :: Word64)) + where + writeWord64Ptr ptr = + loop (19 :: Int) v 0 False + where + loop 0 v offset _ = do + writeOffPtr ptr offset (word8ToAsciiWord8 $ fromIntegral v) + pure $ offset + 1 + loop n v offset upper = do + let (p, q) = v `divMod` (10 ^ n) + if p == 0 && not upper + then loop (n - 1) q offset upper + else do + writeOffPtr ptr offset (word8ToAsciiWord8 $ fromIntegral p) + loop (n - 1) q (offset + 1) True + + +word8ToAsciiWord8 :: Word8 -> Word8 +word8ToAsciiWord8 b = b + fromIntegral (C.ord '0') + + +word8ToWord64 :: Word8 -> Word64 +word8ToWord64 = fromIntegral diff --git a/test/spec/OpenTelemetry/Propagator/Datadog/InternalSpec.hs b/test/spec/OpenTelemetry/Propagator/Datadog/InternalSpec.hs new file mode 100644 --- /dev/null +++ b/test/spec/OpenTelemetry/Propagator/Datadog/InternalSpec.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} + +module OpenTelemetry.Propagator.Datadog.InternalSpec where + +import qualified Data.ByteString.Char8 as BC +import Data.ByteString.Short (ShortByteString) +import qualified Data.ByteString.Short as SB +import Data.Word (Word64) +import Hexdump (simpleHex) +import OpenTelemetry.Propagator.Datadog.Internal +import qualified String +import Test.Hspec +import Test.QuickCheck + + +spec :: Spec +spec = do + context "newTraceIdFromHeader" $ do + it "is equal to the old implementation" $ + property $ \x -> do + let x' = BC.pack $ show (x :: Word64) + HexString (newTraceIdFromHeader x') + `shouldBe` HexString (String.newTraceIdFromHeader x') + + context "newSpanIdFromHeader" $ do + it "is equal to the old implementation" $ + property $ \x -> do + let x' = BC.pack $ show (x :: Word64) + HexString (newSpanIdFromHeader x') + `shouldBe` HexString (String.newSpanIdFromHeader x') + + context "newHeaderFromTraceId" $ do + it "is equal to the old implementation" $ + property $ \(x1, x2, x3, x4, x5, x6, x7, x8, x9, (x10, x11, x12, x13, x14, x15, x16)) -> do + let x' = SB.pack [x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16] + newHeaderFromTraceId x' + `shouldBe` String.newHeaderFromTraceId x' + + context "newHeaderFromSpanId" $ do + it "is equal to the old implementation" $ + property $ \(x1, x2, x3, x4, x5, x6, x7, x8) -> do + let x' = SB.pack [x1, x2, x3, x4, x5, x6, x7, x8] + newHeaderFromSpanId x' + `shouldBe` String.newHeaderFromSpanId x' + + context "composition of newTraceIdFromHeader and newHeaderFromTraceId" $ do + it "is identical" $ + property $ \(x1, x2, x3, x4, x5, x6, x7, x8) -> do + let x' = SB.pack $ replicate 8 0 ++ [x1, x2, x3, x4, x5, x6, x7, x8] + HexString (newTraceIdFromHeader $ newHeaderFromTraceId x') `shouldBe` HexString x' + + context "composition of newHeaderFromTraceId and newTraceIdFromHeader" $ do + it "is identical" $ + property $ \x -> do + let x' = BC.pack $ show (x :: Word64) + newHeaderFromTraceId (newTraceIdFromHeader x') `shouldBe` x' + + context "composition of newSpanIdFromHeader and newHeaderFromSpanId" $ do + it "is identical" $ + property $ \(x1, x2, x3, x4, x5, x6, x7, x8) -> do + let x' = SB.pack [x1, x2, x3, x4, x5, x6, x7, x8] + newSpanIdFromHeader (newHeaderFromSpanId x') `shouldBe` x' + + context "composition of newHeaderFromSpanId and newSpanIdFromHeader" $ do + it "is identical" $ + property $ \x -> do + let x' = BC.pack $ show (x :: Word64) + newHeaderFromSpanId (newSpanIdFromHeader x') `shouldBe` x' + + +newtype HexString = HexString ShortByteString deriving (Eq) + + +instance Show HexString where + show (HexString s) = simpleHex $ SB.fromShort s diff --git a/test/spec/OpenTelemetry/Propagator/DatadogSpec.hs b/test/spec/OpenTelemetry/Propagator/DatadogSpec.hs new file mode 100644 --- /dev/null +++ b/test/spec/OpenTelemetry/Propagator/DatadogSpec.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-type-defaults #-} + +module OpenTelemetry.Propagator.DatadogSpec where + +import qualified Data.ByteString as B +import qualified Data.ByteString.Short as SB +import OpenTelemetry.Internal.Trace.Id +import OpenTelemetry.Propagator.Datadog +import Test.Hspec +import Test.QuickCheck + + +spec :: Spec +spec = do + context "convertOpenTelemetrySpanIdToDatadogSpanId" $ do + it "can conert values" $ + property $ \(x1, x2, x3, x4, x5, x6, x7, x8) -> do + let v = + fromIntegral x1 * (2 ^ 8) ^ 7 + + fromIntegral x2 * (2 ^ 8) ^ 6 + + fromIntegral x3 * (2 ^ 8) ^ 5 + + fromIntegral x4 * (2 ^ 8) ^ 4 + + fromIntegral x5 * (2 ^ 8) ^ 3 + + fromIntegral x6 * (2 ^ 8) ^ 2 + + fromIntegral x7 * (2 ^ 8) ^ 1 + + fromIntegral x8 + spanId = SpanId $ SB.toShort $ B.pack [x1, x2, x3, x4, x5, x6, x7, x8] + convertOpenTelemetrySpanIdToDatadogSpanId spanId `shouldBe` v + + context "convertOpenTelemetryTraceIdToDatadogTraceId" $ do + it "can conert values" $ + property $ \(x1, x2, x3, x4, x5, x6, x7, x8) -> do + let v = + fromIntegral x1 * (2 ^ 8) ^ 7 + + fromIntegral x2 * (2 ^ 8) ^ 6 + + fromIntegral x3 * (2 ^ 8) ^ 5 + + fromIntegral x4 * (2 ^ 8) ^ 4 + + fromIntegral x5 * (2 ^ 8) ^ 3 + + fromIntegral x6 * (2 ^ 8) ^ 2 + + fromIntegral x7 * (2 ^ 8) ^ 1 + + fromIntegral x8 + traceId = TraceId $ SB.toShort $ B.pack $ replicate 8 0 ++ [x1, x2, x3, x4, x5, x6, x7, x8] + convertOpenTelemetryTraceIdToDatadogTraceId traceId `shouldBe` v diff --git a/test/spec/Spec.hs b/test/spec/Spec.hs new file mode 100644 --- /dev/null +++ b/test/spec/Spec.hs @@ -0,0 +1,2 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} +