diff --git a/datadog-tracing.cabal b/datadog-tracing.cabal --- a/datadog-tracing.cabal +++ b/datadog-tracing.cabal @@ -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 diff --git a/library/Data/MessagePack/Aeson.hs b/library/Data/MessagePack/Aeson.hs new file mode 100644 --- /dev/null +++ b/library/Data/MessagePack/Aeson.hs @@ -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 diff --git a/library/Datadog/Agent.hs b/library/Datadog/Agent.hs --- a/library/Datadog/Agent.hs +++ b/library/Datadog/Agent.hs @@ -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 diff --git a/library/Datadog/Client.hs b/library/Datadog/Client.hs --- a/library/Datadog/Client.hs +++ b/library/Datadog/Client.hs @@ -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 diff --git a/library/Servant/MsgPack.hs b/library/Servant/MsgPack.hs new file mode 100644 --- /dev/null +++ b/library/Servant/MsgPack.hs @@ -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 diff --git a/manual-test/Main.hs b/manual-test/Main.hs new file mode 100644 --- /dev/null +++ b/manual-test/Main.hs @@ -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)