diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -2,7 +2,7 @@ [![Build Status](https://travis-ci.org/ChrisCoffey/haskell-opentracing-light.svg?branch=master)](https://travis-ci.org/ChrisCoffey/haskell-opentracing-light) -This repository is the minimum required for publishing trace data to Zipkin or Jaeger. It adheres to the [Open Tracing Standard] (https://github.com/opentracing/specification/blob/master/specification.md) but is not complete. See the documentation on Hackage for module-level details. +This repository is the minimum required for publishing trace data to Zipkin or Jaeger. It adheres to the [Open Tracing Standard] (https://github.com/opentracing/specification) but is not complete. See the documentation on Hackage for module-level details. ### Using the library @@ -24,7 +24,7 @@ ### Testing Locally with the Demo App -You can start up a compatible server for (Zipkin)[] or (Jaeger)[] via a standalone docker container. From there its a matter of seting the following environment variables: +You can start up a compatible server for [Zipkin](https://zipkin.io/pages/quickstart.html) or [Jaeger](https://jaegertracing.netlify.com/docs/deployment/) via a standalone docker container. From there its a matter of seting the following environment variables: - *TRACING_ENDPOINT*: a `String` with the fully url to a running tracing server - *TRACING_SERVICE*: a `String` name for your service diff --git a/servant-tracing.cabal b/servant-tracing.cabal --- a/servant-tracing.cabal +++ b/servant-tracing.cabal @@ -1,5 +1,5 @@ name: servant-tracing -version: 0.1.0.1 +version: 0.1.0.2 description: Please see the README on Github at homepage: https://github.com/ChrisCoffey/haskell-opentracing-light#readme bug-reports: https://github.com/ChrisCoffey/haskell-opentracing-light/issues @@ -48,6 +48,7 @@ exposed-modules: Tracing.Core , Tracing.Zipkin + , Tracing.DataDog , Servant.Tracing -- other-modules: default-language: Haskell2010 @@ -105,5 +106,6 @@ Servant.TracingSpec, Instances, Zipkin.ClientSpec, + DataDog.ClientSpec, Tracing.CoreSpec default-language: Haskell2010 diff --git a/src/Servant/Tracing.hs b/src/Servant/Tracing.hs --- a/src/Servant/Tracing.hs +++ b/src/Servant/Tracing.hs @@ -9,6 +9,7 @@ import Tracing.Core (Tracer, TraceId(..), SpanId(..), MonadTracer, TracingInstructions(..)) +import Control.Arrow (first) import Control.Monad.Trans (liftIO, MonadIO) import qualified Data.Text as T import qualified Data.ByteString.Char8 as BS @@ -30,10 +31,14 @@ -- | Jaeger format: http://jaeger.readthedocs.io/en/latest/client_libraries/#propagation-format -- This allows the trace backend to reassemble downstream traces. instructionsToHeader :: TracingInstructions -> T.Text -instructionsToHeader TracingInstructions {traceId=(TraceId tid), spanId=SpanId sid, parentSpanId=SpanId pid, sample, debug} = - toField tid<>":"<> toField sid <> ":"<> toField pid <> ":" <> (T.pack $ show setFlags) +instructionsToHeader TracingInstructions {traceId=(TraceId tid), spanId, parentSpanId, sample, debug} = + toField tid<>":"<> + (toField $ unSpanId spanId) <> ":"<> + (fromMaybe "" $ (toField . unSpanId) <$> parentSpanId) <> ":" <> + (T.pack $ show setFlags) where - toField = T.pack . BS.unpack . fromMaybe "0" . BS.packHexadecimal + unSpanId (SpanId sid) = sid + toField = T.pack . BS.unpack . fromMaybe "" . BS.packHexadecimal setFlags :: Int setFlags = (if debug then 2 else 0) .|. (if sample then 1 else 0) .|. 0 @@ -48,7 +53,10 @@ res = do traceId <- TraceId . fromIntegral . fst <$> hexadecimal rawTraceId spanId <- SpanId . fromIntegral . fst <$> hexadecimal rawSpanId - parentId <- SpanId . fromIntegral . fst <$> if T.null rawParentId then pure (0 :: Integer, "") else hexadecimal rawParentId + let resolvedPid = if T.null rawParentId + then pure (Nothing, "") + else first Just <$> hexadecimal rawParentId + parentId <- fmap (SpanId . fromIntegral) . fst <$> resolvedPid flagField <- fromIntegral . fst <$> hexadecimal flags let [sample, debug]= [sampleFlag, debugFlag] <*> [flagField] pure TracingInstructions { @@ -85,7 +93,7 @@ pure TracingInstructions { traceId = TraceId newTraceId, spanId = SpanId newSpanId, - parentSpanId = SpanId 0, + parentSpanId = Nothing, debug, sample = sample == (1::Int) } diff --git a/src/Tracing/Core.hs b/src/Tracing/Core.hs --- a/src/Tracing/Core.hs +++ b/src/Tracing/Core.hs @@ -130,7 +130,7 @@ TracingInstructions { traceId :: !TraceId, spanId :: !SpanId, - parentSpanId :: !SpanId, + parentSpanId :: !(Maybe SpanId), debug :: !Bool, sample :: !Bool } deriving (Eq, Show) diff --git a/src/Tracing/DataDog.hs b/src/Tracing/DataDog.hs new file mode 100644 --- /dev/null +++ b/src/Tracing/DataDog.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Tracing.DataDog ( + publishDataDog, + DataDogSpan(..) + ) where + +import Tracing.Core (Span(..), SpanId(..), OpName(..), TraceId(..), SpanContext(..), + SpanRelation(..), SpanTag(..)) + +import Control.Monad.Trans (liftIO, MonadIO) +import Control.Monad (void) +import Data.Monoid ((<>), mempty) +import Data.Aeson +import Data.Maybe (fromMaybe) +import Data.Int (Int64) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Lex.Integral as BS +import qualified Data.HashMap.Strict as HM +import Network.HTTP.Client + + +-- | Publish 'Span' in the . No call is made +-- on an empty span list +publishDataDog :: MonadIO m => + String -- ^ The address of the backend server + -> Manager + -> [Span] -- ^ The traced spans to send to a DataDog backend + -> m (Maybe (Response T.Text)) +publishDataDog _ _ [] = pure Nothing +publishDataDog destination manager spans = + liftIO . fmap (Just . fmap decode) $ httpLbs zipkinReq manager + where + decode = T.decodeUtf8 . LBS.toStrict + req = parseRequest_ destination + body = RequestBodyLBS . encode $ DataDogSpan <$> spans + zipkinReq = req { method = "POST", requestBody = body, requestHeaders = [("content-type", "application/json")]} + +newtype DataDogSpan = DataDogSpan Span +instance ToJSON DataDogSpan where + toJSON (DataDogSpan span) = object $ [ + "trace_id" .= (unTrace . traceId $ context span), + "span_id" .= (unSpan . spanId $ context span), + "name" .= unOp (operationName span), + "resource" .= unOp (operationName span), + "start" .= (floor . toNanos $ timestamp span :: Int64), + "type" .= ("web"::T.Text), + "duration" .= (toNanos $ duration span), + "service" .= (serviceName span), + "meta" .= (unTag <$> tags span) + ] <> + parentId (relations span) + where + toNanos = (*) 1000000000 + unOp (OpName n) = n + unSpan (SpanId sid) = sid + unTrace (TraceId tid) = tid + parentId :: [SpanRelation] -> [(T.Text, Value)] + parentId (ChildOf ctx:_) = ["parent_id" .= (unSpan $ spanId ctx)] + parentId (FollowsFrom ctx:_) = ["parent_id" .= (unSpan $ spanId ctx)] + parentId _ = [] + padLeft 0 txt = txt + padLeft n txt + | T.length txt < n = padLeft n ("0"<>txt) + | otherwise = txt + unTag (TagString a) = toJSON a + unTag (TagBool a) = toJSON a + unTag (TagInt a) = toJSON a + unTag (TagDouble a) = toJSON a diff --git a/test/DataDog/ClientSpec.hs b/test/DataDog/ClientSpec.hs new file mode 100644 --- /dev/null +++ b/test/DataDog/ClientSpec.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE NamedFieldPuns, OverloadedStrings #-} + +module DataDog.ClientSpec ( + ddSpec + ) where + +import Tracing.DataDog +import Tracing.Core +import Instances() + +import Data.Maybe (fromMaybe, maybe, isJust) +import Data.Aeson +import Data.Aeson.Types (parseMaybe) +import qualified Data.Text as T +import Test.HUnit +import Test.QuickCheck hiding (sample) +import Test.Tasty +import Test.Tasty.HUnit (testCase) +import Test.Tasty.QuickCheck (testProperty) +import Web.HttpApiData (parseUrlPiece) +import Data.Int + +ddSpec :: TestTree +ddSpec = testGroup "DataDog Spec" $ [ + testCase "start is in nanoseconds" $ do + s <- generate arbitrary + let fromNanos = maybe 0 (/ 1000000000) . parseMaybe ( withObject "" (.: "start") ) $ toJSON (DataDogSpan (s :: Span)) + fromNanos @=? timestamp s + , testCase "parentId set when a child Relation is present" $ do + s <- generate arbitrary :: IO Span + c <- generate arbitrary :: IO SpanContext + let s' = s {relations = [ChildOf c]} + let isPresent = maybe False (> (0:: Int64)) . parseMaybe ( withObject "" (.: "parent_id") ) $ toJSON (DataDogSpan s') + isPresent @=? True + , testCase "parentId set when a FollowsFrom Relation is present" $ do + s <- generate arbitrary :: IO Span + c <- generate arbitrary :: IO SpanContext + let s' = s {relations = [FollowsFrom c]} + let isPresent = maybe False (> (0::Int64)) . parseMaybe ( withObject "" (.: "parent_id") ) $ toJSON (DataDogSpan s') + isPresent @=? True + , testCase "parentId unset when no Relation is present" $ do + s <- generate arbitrary :: IO Span + let s' = s {relations = []} + let isPresent = maybe False (> (0::Int64)) . parseMaybe ( withObject "" (.: "parent_id") ) $ toJSON (DataDogSpan s') + isPresent @=? False + ] diff --git a/test/Servant/TracingSpec.hs b/test/Servant/TracingSpec.hs --- a/test/Servant/TracingSpec.hs +++ b/test/Servant/TracingSpec.hs @@ -45,11 +45,16 @@ testCase "4:3:4:3 == TracingInstructions 4 3 4 True True" $ let inst = parseUrlPiece "4:3:4:3" in case inst of - Right inst -> inst @=? (TracingInstructions (TraceId 4) (SpanId 3) (SpanId 4) True True) + Right inst -> inst @=? (TracingInstructions (TraceId 4) (SpanId 3) (Just $ SpanId 4) True True) + Left _ -> assertFailure $ "Failed: "++ show inst, + testCase "4:3::3 == TracingInstructions 4 3 Nothing True True" $ let + inst = parseUrlPiece "4:3::3" + in case inst of + Right inst -> inst @=? (TracingInstructions (TraceId 4) (SpanId 3) Nothing True True) Left _ -> assertFailure $ "Failed: "++ show inst ] where - dummyInst1 = TracingInstructions (TraceId 1) (SpanId 1) (SpanId 0) True True + dummyInst1 = TracingInstructions (TraceId 1) (SpanId 1) Nothing True True extractId = maybe (-1) fst . toMaybe . T.hexadecimal extractFields = maybe (-1) fst . toMaybe . T.hexadecimal . last . T.splitOn ":" toMaybe (Left _) = Nothing diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,6 +1,7 @@ import Servant.TracingSpec (tracingProps, tracingSpecs) import Zipkin.ClientSpec (zipkinProps, zipkinSpec) +import DataDog.ClientSpec (ddSpec) import Tracing.CoreSpec (coreSpec, coreProps) import Test.Tasty @@ -10,5 +11,6 @@ tracingSpecs, zipkinProps, zipkinSpec, + ddSpec, coreSpec ]