servant-tracing 0.1.0.1 → 0.1.0.2

raw patch · 8 files changed

+146/−11 lines, 8 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• README.md +2/−2
• servant-tracing.cabal +3/−1
• src/Servant/Tracing.hs +13/−5
• src/Tracing/Core.hs +1/−1
• src/Tracing/DataDog.hs +72/−0
• test/DataDog/ClientSpec.hs +46/−0
• test/Servant/TracingSpec.hs +7/−2
• test/Spec.hs +2/−0

@@ -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 

@@ -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 <https://github.com/ChrisCoffey/haskell-opentracing-light#readme> 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

@@ -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)         }

@@ -130,7 +130,7 @@     TracingInstructions {         traceId :: !TraceId,         spanId :: !SpanId,-        parentSpanId :: !SpanId,+        parentSpanId :: !(Maybe SpanId),         debug :: !Bool,         sample :: !Bool         } deriving (Eq, Show)

@@ -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 <https://docs.datadoghq.com/api/?lang=bash#send-traces DataDog format> . 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

@@ -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+    ]

@@ -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

@@ -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     ]