datadog-tracing (empty) → 1.0.0
raw patch · 8 files changed
+475/−0 lines, 8 filesdep +QuickCheckdep +aesondep +base
Dependencies added: QuickCheck, aeson, base, bytestring, containers, datadog, generic-random, hspec-golden-aeson, prettyprinter, quickcheck-text, refined, servant, servant-client, servant-server, tasty, tasty-hspec, text, time, warp
Files
- LICENSE +26/−0
- datadog-tracing.cabal +73/−0
- exe/Main.hs +38/−0
- library/Datadog/Agent.hs +124/−0
- library/Datadog/Client.hs +111/−0
- library/Datadog/Jaeger.hs +91/−0
- test/Datadog/AgentTest.hs +11/−0
- test/Driver.hs +1/−0
+ LICENSE view
@@ -0,0 +1,26 @@+Copyright 2019 Symbiont.io++Redistribution and use in source and binary forms, with or without modification,+are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++2. 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.++3. Neither the name of the copyright holder nor the names of its 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 HOLDER 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.
+ datadog-tracing.cabal view
@@ -0,0 +1,73 @@+cabal-version: 2.2+name: datadog-tracing+version: 1.0.0+synopsis: Datadog tracing client and mock agent.+license: BSD-3-Clause+license-file: LICENSE+author: Sam Halliday+maintainer: Sam Halliday+copyright: (c) 2019 Symbiont.io+bug-reports: https://github.com/symbiont-io/haskell-datadog/pulls+tested-with: GHC ^>= 8.4.4 || ^>= 8.6.3+category: Logging+description:+ An HTTP client to publish tracing to+ a [datadog agent](https://docs.datadoghq.com/agent/?tab=agentv6).+ .+ In addition, an HTTP server is provided that can be used in place of+ the official agent, that does not communicate with upstream datadog+ servers, allowing replay of all data from a `GET /dump` endpoint,+ compatible with `jaeger-flamegraph`.++source-repository head+ type: git+ location: https://github.com/symbiont-io/haskell-datadog++-- https://www.haskell.org/cabal/users-guide/cabal-projectindex.html++common deps+ build-depends: , base ^>= 4.11.1.0 || ^>= 4.12.0.0+ , bytestring ^>= 0.10.8.2+ , containers ^>= 0.5.11.0 || ^>= 0.6.0.1+ , text ^>= 1.2.3.1+ , aeson ^>= 1.4.1.0+ , servant ^>= 0.14.1+ ghc-options: -Wall+ -Werror=missing-home-modules+ default-language: Haskell2010++library+ import: deps+ hs-source-dirs: library+ exposed-modules: Datadog.Agent+ , Datadog.Client+ , Datadog.Jaeger+ build-depends: , generic-random ^>= 1.2.0.0+ , refined ^>= 0.2.3.0+ , prettyprinter ^>= 1.2.1+ , servant-client ^>= 0.14+ , time ^>= 1.8.0.2+ , QuickCheck ^>= 2.11.3+ , quickcheck-text ^>= 0.1.2.1++executable datadog-agent+ import: deps+ hs-source-dirs: exe+ main-is: Main.hs+ build-depends: , datadog+ , servant-server ^>= 0.14.1+ , warp ^>= 3.2.25+ ghc-options: -threaded++test-suite tests+ import: deps+ hs-source-dirs: test+ type: exitcode-stdio-1.0+ main-is: Driver.hs+ other-modules: Datadog.AgentTest+ build-depends: , datadog+ , hspec-golden-aeson ^>= 0.7.0.0+ , tasty ^>= 1.1.0.4+ , tasty-hspec ^>= 1.1.5.1+ build-tool-depends: tasty-discover:tasty-discover ^>= 4.2.1+ ghc-options: -threaded
+ exe/Main.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}++-- | A mock server implementing the Agent API.+--+-- Unlike the real agent, input is not validated, and an additional endpoint is+-- exposed that allows downloading all the recorded data in a format compatible+-- with Jaeger tracing.++import Control.Monad (void)+import Control.Monad.IO.Class (liftIO)+import Data.IORef+import qualified Data.Map.Strict as M+import Network.Wai.Handler.Warp (run)+import Servant++import Datadog.Agent+import Datadog.Jaeger++type Services = (Traces3 :<|> Traces4 :<|> Dump)++main :: IO ()+main = do+ ref <- newIORef []+ let services = (postTraces3 ref) :<|> (postTraces4 ref) :<|> (getTraces ref)+ run 8126 (serve (Proxy @ Services) services)++postTraces3 :: IORef [Trace] -> [Trace] -> Handler ()+postTraces3 r t = void $ postTraces4 r t++postTraces4 :: IORef [Trace] -> [Trace] -> Handler TraceResponse+postTraces4 ref traces = liftIO $ (atomicModifyIORef' ref update)+ where update store = ((reverse traces) <> store, TraceResponse M.empty)++getTraces :: IORef [Trace] -> Handler Jaeger+getTraces ref = liftIO $ toJaeger <$> readIORef ref
+ library/Datadog/Agent.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE TypeOperators #-}++-- | A model of the API provided by https://github.com/DataDog/datadog-agent+module Datadog.Agent where++import Data.Aeson+import Data.Int (Int32, Int64)+import Data.Map.Strict (Map)+import Data.Maybe (catMaybes)+import Data.Text (Text)+import Data.Text.Arbitrary ()+import Data.Word (Word64)+import Generic.Random (genericArbitraryU)+import GHC.Generics (Generic)+import Servant.API+import Test.QuickCheck (Arbitrary, arbitrary)++-- defined in pkg/trace/api/api.go+--+-- Clients post a list of traces. The datadog-agent (based on version+-- e34402aeae95a619303c0cb624ba5b3908f5c358) silently rejects invalid traces+-- under any of the following conditions:+--+-- * if there is a trace ID discrepancy between 2 spans+-- * if two spans have the same span_id+-- * if it is empty+-- * if trace_id or span_id is 0+-- * if service is empty or longer than 100 chars after applying+-- `normalizeTag` rules (tl;dr letters and colons are safe)+-- * if name is empty, doesn't have any alphabetic chars, or is longer than+-- 100 chars after applying `normMetricNameParse` rules (tl;dr underscores+-- only allowed in certain places)+-- * if type is empty or longer than 100 chars after attempting to correct+-- any UTF-8 errors.+-- * if the span duration is less than 0 or longer than 10 minutes+-- * if the resource is not valid UTF-8 and cannot be fixed. The upstream+-- server has a 5000 character limit.+-- * if the start is before 2000-01-01+--+-- 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++-- backcompat+type Traces3 = "v0.3" :> "traces" :> ReqBody '[JSON] [Trace] :> Put '[JSON] ()++newtype Trace = Trace [Span] deriving (ToJSON, FromJSON)++-- | https://docs.datadoghq.com/api/?lang=python#tracing+data Span = Span+ { spanService :: Text+ , spanName :: Text+ , spanResource :: Text+ , spanTraceId :: Word64+ , spanId :: Word64+ , spanParentId :: Maybe Word64+ , spanStart :: Int64+ , spanDuration :: Int64+ , spanError :: Maybe Int32+ , spanMeta :: Maybe (Map Text Text)+ , spanMetrics :: Maybe (Map Text Text)+ , spanType :: Maybe Text+ } deriving (Generic)++instance Arbitrary Span where+ arbitrary = genericArbitraryU++instance ToJSON Span where+ toJSON Span{..} = object'+ [ "service" .= spanService+ , "name" .= spanName+ , "resource" .= spanResource+ , "trace_id" .= spanTraceId+ , "span_id" .= spanId+ , "start" .= spanStart+ , "duration" .= spanDuration+ ]+ [ "parent_id" .=? spanParentId+ , "error" .=? spanError+ , "meta" .=? spanMeta+ , "metrics" .=? spanMetrics+ , "type" .=? spanType+ ]+ where+ key .=? value = (key .=) <$> value+ object' required optional = object $ required <> catMaybes optional++instance FromJSON Span where+ parseJSON = withObject "Span" $ \v ->+ Span <$> v .: "service"+ <*> v .: "name"+ <*> v .: "resource"+ <*> v .: "trace_id"+ <*> v .: "span_id"+ <*> v .:? "parent_id" .!= Nothing+ <*> v .: "start"+ <*> v .: "duration"+ <*> v .:? "error" .!= Nothing+ <*> v .:? "meta" .!= Nothing+ <*> v .:? "metrics" .!= Nothing+ <*> v .:? "type" .!= Nothing++-- The meaning of this is ambiguous: https://github.com/DataDog/datadog-agent/issues/3031+-- The Double is always in the range [0.0, 1.0]+data TraceResponse = TraceResponse+ { trRateByService :: Map Text Double+ }++instance ToJSON TraceResponse where+ toJSON (TraceResponse rates) = object+ [ "rate_by_service" .= rates+ ]++instance FromJSON TraceResponse where+ parseJSON = withObject "TraceResponse" $ \v ->+ TraceResponse <$> v .: "rate_by_service"
+ library/Datadog/Client.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ViewPatterns #-}++-- | An HTTP Client to post data to a datadog agent.+--+-- Many of our refinements are stricter than the actual requirements, to err on+-- the side of caution, and because the actual requirements are very complex.+module Datadog.Client where++import Control.Monad (unless, void)+import Data.Char (isAlpha, isAlphaNum)+import Data.Int (Int64)+import qualified Data.List.NonEmpty as NEL+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as M+import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Arbitrary ()+import Data.Text.Prettyprint.Doc (viaShow)+import Data.Time (NominalDiffTime, UTCTime)+import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)+import Data.Typeable (Proxy (..), Typeable, typeOf)+import Data.Word (Word64)+import Refined+import Servant.Client (ClientM, client)++import qualified Datadog.Agent as API++type DDText = NonEmpty && (SizeLessThan 101)++newtype SpanId = SpanId (Refined NonZero Word64)+newtype TraceId = TraceId (Refined NonZero Word64)+newtype ServiceName = ServiceName (Refined (DDText && AlphaNum) Text)++data Trace = Trace+ { tService :: ServiceName+ , tId :: TraceId+ , tSpans :: (Refined NonEmpty (Map SpanId Span))+ }++newtype SpanName = SpanName (Refined (DDText && HasAlpha) Text)+newtype MetaKey = MetaKey (Refined (DDText && AlphaNum) Text)+newtype MetaValue = MetaValue (Refined DDText Text)++data Span = Span+ { sName :: SpanName+ , sParentId :: Maybe SpanId+ , sStart :: UTCTime+ , sDuration :: NominalDiffTime+ , sMeta :: Maybe (Map MetaKey MetaValue)+ }++traces :: NEL.NonEmpty Trace -> ClientM ()+traces (NEL.toList -> ts) = void . raw $ toAPI <$> ts+ where+ raw = client (Proxy @ API.Traces3)++ toAPI :: Trace -> API.Trace+ toAPI (trace@(Trace _ _ (M.toList . unrefine -> spans))) =+ API.Trace $ (mkSpan trace) <$> spans++ mkSpan :: Trace -> (SpanId, Span) -> API.Span+ mkSpan (Trace (ServiceName (unrefine -> serviceName))+ (TraceId (unrefine -> traceId))+ _)+ ((SpanId (unrefine -> spanId)),+ (Span (SpanName (unrefine -> spanName))+ parent+ start+ duration+ meta)) =+ API.Span serviceName+ spanName+ "time" -- not using resource, but it is required+ traceId+ spanId+ ((\(SpanId (unrefine -> p)) -> p) <$> parent)+ (timeToNanos start)+ (nominalToNanos duration)+ Nothing -- not using error+ ((\m -> (M.map unValue) . (M.mapKeys unKey) $ m) <$> meta)+ Nothing -- not using metrics+ Nothing -- not using type++ unKey (MetaKey (unrefine -> k)) = k+ unValue (MetaValue (unrefine -> v)) = v++ timeToNanos :: UTCTime -> Int64+ timeToNanos time = nominalToNanos $ utcTimeToPOSIXSeconds time++ nominalToNanos :: NominalDiffTime -> Int64+ nominalToNanos time =+ let (nanos, _) = properFraction (1000000000 * time)+ in nanos++data AlphaNum+instance Predicate AlphaNum Text where+ validate p txt = validate' p (T.all isAlphaNum) txt++data HasAlpha+instance Predicate HasAlpha Text where+ validate p txt = validate' p (T.any isAlpha) txt++validate' :: (Typeable t, Monad m, Show a) => t -> (a -> Bool) -> a -> RefineT m ()+validate' t p a =+ unless (p a) $+ throwRefineOtherException (typeOf t) ("failed predicate: " <> (viaShow a))
+ library/Datadog/Jaeger.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeOperators #-}++-- | Mimicks the Jaeger `api/traces` API, as used by `jaeger-flamegraph`, but+-- without requiring service names to be provided.+module Datadog.Jaeger where++import Data.Aeson+import Data.List (nub)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as M+import Data.Maybe (mapMaybe, maybeToList)+import Data.Text (Text)+import qualified Data.Text as T+import GHC.Generics (Generic)+import Servant.API++import qualified Datadog.Agent as Agent++type Dump = "dump" :> Get '[JSON] Jaeger++toJaeger :: [Agent.Trace] -> Jaeger+toJaeger traces = Jaeger $ mapMaybe traceToData traces+ where+ traceToData (Agent.Trace []) = Nothing+ traceToData (Agent.Trace spans) =+ let Agent.Span{..} = head spans+ in Just $ Data+ (TraceID . showt $ spanTraceId)+ (spanToSpan <$> spans)+ (M.fromList $ (\a -> (ProcessID a, Process a)) <$> services spans)+ spanToSpan Agent.Span{..} =+ let traceId = (TraceID . showt $ spanTraceId)+ in Span (SpanID . showt $ spanId)+ traceId+ (Name spanName)+ ((Reference traceId) . (SpanID . showt) <$> maybeToList spanParentId)+ (toInteger spanStart)+ (toInteger spanDuration)+ (mkTag <$> (concat $ M.toList <$> spanMeta))+ (ProcessID spanService)+ services spans = nub $ Agent.spanService <$> spans+ showt = T.pack . show+ mkTag (k, v) = Tag $ T.concat [k, ":", v]++newtype Jaeger = Jaeger [Data]+instance ToJSON Jaeger where+ toJSON (Jaeger dat) = object ["data" .= dat]++newtype TraceID = TraceID Text deriving newtype (Eq, Ord, ToJSON)+newtype SpanID = SpanID Text deriving newtype (Eq, Ord, ToJSON)+newtype ProcessID = ProcessID Text deriving newtype (Eq, Ord, ToJSON, ToJSONKey)+newtype Name = Name Text deriving newtype (Eq, ToJSON)++data Data = Data+ { traceID :: TraceID+ , spans :: [Span]+ , processes :: Map ProcessID Process+ } deriving (Generic, ToJSON)++data Process = Process+ { serviceName :: Text+ } deriving (Generic, ToJSON)++data Span = Span+ { spanID :: SpanID+ , traceID :: TraceID+ , operationName :: Name+ , references :: [Reference]+ , startTime :: Integer+ , duration :: Integer+ , tags :: [Tag]+ , processID :: ProcessID+ } deriving (Generic, ToJSON)++data Reference = Reference+ { traceID :: TraceID+ , spanID :: SpanID+ } deriving (Eq, Ord, Generic, ToJSON)++newtype Tag = Tag+ { key :: Text+ } deriving (Eq, Generic)+ deriving anyclass (ToJSON)
+ test/Datadog/AgentTest.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE TypeApplications #-}++module Datadog.AgentTest where++import Test.Aeson.GenericSpecs+import Test.Tasty.Hspec++import Datadog.Agent++spec_json :: Spec+spec_json = roundtripAndGoldenSpecs (Proxy @Span)
+ test/Driver.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF tasty-discover #-}