datadog-tracing 1.2.0 → 1.3.0
raw patch · 6 files changed
+202/−11 lines, 6 filesdep +binarydep +cryptonitedep +data-msgpackdep ~refineddep ~servant-clientdep ~timenew-component:exe:manual-test
Dependencies added: binary, cryptonite, data-msgpack, http-client, http-media, scientific, unordered-containers, vector
Dependency ranges changed: refined, servant-client, time
Files
- datadog-tracing.cabal +26/−3
- library/Data/MessagePack/Aeson.hs +49/−0
- library/Datadog/Agent.hs +23/−4
- library/Datadog/Client.hs +8/−4
- library/Servant/MsgPack.hs +32/−0
- manual-test/Main.hs +64/−0
datadog-tracing.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.2 name: datadog-tracing-version: 1.2.0+version: 1.3.0 synopsis: Datadog tracing client and mock agent. license: BSD-3-Clause license-file: LICENSE@@ -25,6 +25,11 @@ -- https://www.haskell.org/cabal/users-guide/cabal-projectindex.html +flag manual+ description: Enable building the manual test binary+ manual: True+ default: False+ common deps build-depends: , base ^>= 4.11.1.0 || ^>= 4.12.0.0 , bytestring ^>= 0.10.8.2@@ -43,12 +48,19 @@ exposed-modules: Datadog.Agent , Datadog.Client , Datadog.Jaeger- build-depends: , ffunctor ^>= 1.1.0+ other-modules: Data.MessagePack.Aeson+ , Servant.MsgPack+ build-depends: , data-msgpack ^>= 0.0.12+ , ffunctor ^>= 1.1.0 , generic-random ^>= 1.2.0.0- , refined ^>= 0.2.3.0+ , http-media ^>= 0.7.1.3+ , refined ^>= 0.2.3.0 || ^>= 0.4 , prettyprinter ^>= 1.2.1 , servant-client ^>= 0.14+ , scientific ^>= 0.3.6.2 , time ^>= 1.8.0.2+ , unordered-containers ^>= 0.2.9.0+ , vector ^>= 0.12.0.2 , QuickCheck ^>= 2.11.3 , quickcheck-text ^>= 0.1.2.1 @@ -60,6 +72,17 @@ , servant-server ^>= 0.14.1 , warp ^>= 3.2.25 ghc-options: -threaded++executable manual-test+ import: deps+ hs-source-dirs: manual-test+ main-is: Main.hs+ if flag(manual)+ build-depends: , datadog-tracing, binary, http-client, servant-client, time+ , cryptonite ^>= 0.25+ ghc-options: -threaded+ else+ buildable: False test-suite tests import: deps
+ library/Data/MessagePack/Aeson.hs view
@@ -0,0 +1,49 @@+-- | This file is copied and pasted from+-- http://hackage.haskell.org/package/msgpack-aeson-0.1.0.0/docs/src/Data-MessagePack-Aeson.html#toAeson+-- with only minor changes to use the data-msgpack fork (mostly changing Vector to list).++{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ViewPatterns #-}++-- | Aeson bridge for MessagePack+--+-- Copyright: (c) 2015 Hideyuki Tanaka+module Data.MessagePack.Aeson where++import Control.Arrow+import Data.Aeson as A+import qualified Data.HashMap.Strict as HM+import Data.MessagePack as MP+import Data.Scientific+import qualified Data.Text.Encoding as T+import qualified Data.Vector as V++toAeson :: (Monad m) => MP.Object -> m Value+toAeson = \case+ ObjectNil -> pure Null+ ObjectBool b -> pure . Bool $ b+ ObjectInt n -> pure . Number $ fromIntegral n+ ObjectFloat f -> pure . Number $ realToFrac f+ ObjectDouble d -> pure . Number $ realToFrac d+ ObjectStr t -> pure . String $ t+ ObjectBin b -> String <$> either (fail . show) pure (T.decodeUtf8' b)+ ObjectArray (V.fromList -> v) -> Array <$> V.mapM toAeson v+ ObjectMap (m) ->+ A.Object . HM.fromList <$> mapM (\(k, v) -> (,) <$> fromObject k <*> toAeson v) m+ ObjectExt _ _ -> fail "ObjectExt not supported"+ ObjectWord _ -> fail "ObjectWord not supported"++fromAeson :: Value -> MP.Object+fromAeson = \case+ Null -> ObjectNil+ Bool b -> ObjectBool b+ Number s ->+ case floatingOrInteger s of+ Left f -> ObjectDouble f+ Right n -> ObjectInt n+ String t -> ObjectStr t+ Array (V.toList -> v) -> ObjectArray $ map fromAeson v+ A.Object (HM.toList -> o) -> ObjectMap $ map (toObject *** fromAeson) o
library/Datadog/Agent.hs view
@@ -19,6 +19,7 @@ import Generic.Random (genericArbitraryU) import GHC.Generics (Generic) import Servant.API+import Servant.MsgPack import Test.QuickCheck (Arbitrary, arbitrary) -- defined in pkg/trace/api/api.go@@ -46,11 +47,15 @@ -- and will silently rewrite invalid data, e.g. the normalisation routines, when -- ParentID == TraceID == SpanID the parent is reset to 0. type Traces4 = "v0.4" :> "traces"- :> ReqBody '[JSON] [Trace]- :> Put '[JSON] TraceResponse+ :> ReqBody '[MsgPack, JSON] [Trace]+ :> Put '[MsgPack, JSON] TraceResponse+ -- WARNING: agent incorrectly sets the response type to be plain text+ -- https://github.com/DataDog/datadog-agent/issues/3207#issuecomment-476716966 -- backcompat-type Traces3 = "v0.3" :> "traces" :> ReqBody '[JSON] [Trace] :> Put '[JSON] ()+type Traces3 = "v0.3" :> "traces"+ :> ReqBody '[MsgPack, JSON] [Trace]+ :> Put '[PlainText] NoContent newtype Trace = Trace [Span] deriving (ToJSON, FromJSON) @@ -66,7 +71,7 @@ , spanDuration :: Int64 , spanError :: Maybe Int32 , spanMeta :: Maybe (Map Text Text)- , spanMetrics :: Maybe (Map Text Text)+ , spanMetrics :: Maybe Metrics , spanType :: Maybe Text } deriving (Generic) @@ -107,6 +112,20 @@ <*> v .:? "meta" .!= Nothing <*> v .:? "metrics" .!= Nothing <*> v .:? "type" .!= Nothing++-- See TraceResponse+data Metrics = Metrics Int deriving (Generic)++instance Arbitrary Metrics where+ arbitrary = genericArbitraryU++instance ToJSON Metrics where+ toJSON (Metrics priority) = object+ [ "_sampling_priority_v1" .= priority ]++instance FromJSON Metrics where+ parseJSON = withObject "Metrics" $ \v ->+ Metrics <$> v .: "_sampling_priority_v1" -- "rate" is a number between `[0.0, 1.0]` indicating the desired percentage of -- traces that the agent wishes to downsample for a given service (`0.0` meaning
library/Datadog/Client.hs view
@@ -92,6 +92,7 @@ , sStart :: UTCTime , sDuration :: NominalDiffTime , sMeta :: Maybe (Map MetaKey MetaValue)+ , sError :: Bool } deriving (Eq, Show) traces :: NEL.NonEmpty Trace -> ClientM ()@@ -112,8 +113,11 @@ parent start duration- meta)) =- API.Span serviceName+ meta+ err)) =+ let metrics = (\_ -> API.Metrics 2) <$> parent -- never sample+ in API.Span+ serviceName spanName "time" -- not using resource, but it is required traceId@@ -121,9 +125,9 @@ ((\(SpanId (unrefine -> p)) -> p) <$> parent) (timeToNanos start) (nominalToNanos duration)- Nothing -- not using error+ (if err then Just 1 else Nothing) ((\m -> (M.map unValue) . (M.mapKeys unKey) $ m) <$> meta)- Nothing -- not using metrics+ metrics Nothing -- not using type unKey (MetaKey (unrefine -> k)) = k
+ library/Servant/MsgPack.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}++-- | msgpack support for Servant, piggy backing off Aeson.+--+-- Note: if we wish to improve performance and/or control over the msgpack+-- formats, we should avoid the Aeson intermediate format and create direct+-- MessagePack a => Mime(R,Unr)ender instances.+module Servant.MsgPack where++import Data.Aeson+import Data.List.NonEmpty+import Data.MessagePack (pack, unpack)+import Data.MessagePack.Aeson+import Network.HTTP.Media ((//))+import Servant.API.ContentTypes++data MsgPack++instance Accept MsgPack where+ contentTypes _ = fromList [ "application" // "msgpack"+ , "application" // "x-msgpack"+ , "application" // "vnd.msgpack"]++instance ToJSON a => MimeRender MsgPack a where+ mimeRender _ = pack . fromAeson . toJSON++instance FromJSON a => MimeUnrender MsgPack a where+ mimeUnrender _ b = case fromJSON =<< toAeson =<< unpack b of+ Error str -> Left str+ Success a -> Right a
+ manual-test/Main.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++{-+This tests the client against a real Datadog Agent but is manual because there+is no way to get an HTTP error code from their API:++1. get a DD_API_KEY from datadog (sigh)+2. start the agent using the docker command (below)+3. cabal v2-run -O0 --constraint "datadog-tracing +manual" manual-test+4. check that the trace shows up in datadog, grep for "INFO (api.go"+5. docker stop datadog && docker rm datadog++docker run -d --name datadog \+ -p 8126:8126 \+ --network host \+ -e DD_API_KEY=${DD_API_KEY} \+ -v /sys/fs/cgroup/:/host/sys/fs/cgroup:ro \+ -v /proc/:/host/proc/:ro \+ -e DD_APM_ENABLED=true \+ -e DD_LOG_LEVEL=trace \+ datadog/agent:6.10.3-logs-api-key-rc.1+-}+module Main where++import Crypto.Random+import Data.Aeson.Text+import Data.Binary (decode)+import qualified Data.ByteString.Lazy as LBS+import Data.Int (Int64)+import qualified Data.Text.Lazy as LT+import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime)+import Data.Typeable+import Data.Word (Word64)+import Datadog.Agent+import Network.HTTP.Client hiding (Proxy)+import Servant.Client++main :: IO ()+main = do+ mgr <- newManager defaultManagerSettings+ base <- parseBaseUrl "http://localhost:8126"+ start <- toNanos <$> getPOSIXTime+ traceid <- randomWord64+ spanid <- randomWord64+ let http = client (Proxy @ Traces3)+ env = mkClientEnv mgr base+ metrics = Just $ Metrics 2+ traces = [ (Trace+ [ Span "tester" "span" "time" traceid spanid Nothing start 800971+ Nothing Nothing metrics Nothing+ ])+ ]+ putStrLn (LT.unpack . encodeToLazyText $ traces)+ res <- runClientM (http traces) env+ putStrLn (show res)++toNanos :: POSIXTime -> Int64+toNanos nominal =+ let (nanos, _) = properFraction (1000000000 * nominal)+ in nanos++randomWord64 :: MonadRandom m => m Word64+randomWord64 = decode . LBS.fromStrict <$> (getRandomBytes 8)