diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,8 @@ +# 0.1.1.0 + +- Add honeycomb.io reporter. +- Add kafka consumer log details. + # 0.1.0.3 - Relax version bounds to encompass `time-0.12`. diff --git a/nri-observability.cabal b/nri-observability.cabal --- a/nri-observability.cabal +++ b/nri-observability.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: nri-observability -version: 0.1.0.3 +version: 0.1.1.0 synopsis: Report log spans collected by nri-prelude. description: Please see the README at . category: Web @@ -32,15 +32,18 @@ Log.HttpRequest Log.RedisCommands Log.SqlQuery + Log.Kafka Reporter.Bugsnag Reporter.Dev Reporter.File + Reporter.Honeycomb other-modules: Platform.ReporterHelpers Platform.Timer Reporter.Bugsnag.Internal Reporter.Dev.Internal Reporter.File.Internal + Reporter.Honeycomb.Internal Paths_nri_observability hs-source-dirs: src @@ -78,6 +81,7 @@ , text >=1.2.3.1 && <1.3 , time >=1.8.0.2 && <1.13 , unordered-containers >=0.2.0.0 && <0.3 + , uuid >=1.3.0 && <1.4 default-language: Haskell2010 test-suite tests @@ -88,7 +92,9 @@ Spec.Reporter.Bugsnag Spec.Reporter.Dev Spec.Reporter.File + Spec.Reporter.Honeycomb Log.HttpRequest + Log.Kafka Log.RedisCommands Log.SqlQuery Platform.ReporterHelpers @@ -99,6 +105,8 @@ Reporter.Dev.Internal Reporter.File Reporter.File.Internal + Reporter.Honeycomb + Reporter.Honeycomb.Internal Paths_nri_observability hs-source-dirs: tests @@ -138,4 +146,5 @@ , text >=1.2.3.1 && <1.3 , time >=1.8.0.2 && <1.13 , unordered-containers >=0.2.0.0 && <0.3 + , uuid >=1.3.0 && <1.4 default-language: Haskell2010 diff --git a/src/Log/HttpRequest.hs b/src/Log/HttpRequest.hs --- a/src/Log/HttpRequest.hs +++ b/src/Log/HttpRequest.hs @@ -66,11 +66,15 @@ Aeson.omitNothingFields = True } +-- | A wrapper around the 'Details' type to indicate that we're reporting an +-- incoming http, like a request sent from a frontend to an http server. newtype Incoming = Incoming Details deriving (Aeson.ToJSON) instance Platform.TracingSpanDetails Incoming +-- | A wrapper around the 'Details' type to indicate that this is an outgoing +-- http request, for example a request we're making to an external weather API. newtype Outgoing = Outgoing Details deriving (Aeson.ToJSON) diff --git a/src/Log/Kafka.hs b/src/Log/Kafka.hs new file mode 100644 --- /dev/null +++ b/src/Log/Kafka.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE GADTs #-} + +-- | A module for creating great logs in code using Kafka. +module Log.Kafka + ( emptyDetails, + Details, + topic, + partitionId, + key, + contents, + createTime, + logAppendTime, + processAttempt, + assignedPartitions, + pausedPartitions, + timeSinceLastRebalance, + requestId, + mkContents, + Contents, + ) +where + +import qualified Data.Aeson as Aeson +import qualified Data.Time.Clock as Clock +import qualified Platform + +-- | A type describing a kafka message being processed by a consumer. +-- +-- > emptyDetails +-- > { topic = Just "kafka-topic" +-- > , partitionId = Just 1 +-- > , contents = Just (mkContents "This message is a JSON string!") +-- > } +data Details = Details + { -- | The topic name of the message. + topic :: Maybe Text, + -- | The partition id of the message. + partitionId :: Maybe Int, + -- | The key of the message (if it has one). If a key is provided by a + -- message producer it is used to determine the partition id, in such a way + -- that messages with the same key are guaranteed to end up in the same + -- partition. + key :: Maybe Text, + -- | The contents of the message. + contents :: Maybe Contents, + -- | The time at which this message was created by a producer. + -- Whether this property is available for a message depends on the + -- `log.message.timestamp.type` configuration option. + -- More context: https://github.com/edenhill/librdkafka/blob/8bacbc0b4c357193288c81277bfcc815633126ea/INTRODUCTION.md#latency-measurement + createTime :: Maybe Clock.UTCTime, + -- | The time at which this message was added to a log by a broker. + -- Whether this property is available for a message depends on the + -- `log.message.timestamp.type` configuration option. + -- More context: https://github.com/edenhill/librdkafka/blob/8bacbc0b4c357193288c81277bfcc815633126ea/INTRODUCTION.md#latency-measurement + logAppendTime :: Maybe Clock.UTCTime, + -- | Zero-based counter indicating the how-manyth time it is we're attemping + -- to process this message. + processAttempt :: Maybe Int, + -- | The amount of partitions for this topic the consumer is responsible + -- for. + assignedPartitions :: Maybe Int, + -- | The amount of partitions this consumer currently has paused, because + -- it's behing processing this partition. + pausedPartitions :: Maybe Int, + -- | Time since last rebalance in s + timeSinceLastRebalance :: Maybe Float, + -- | The request id of the http request that resulted in the enqueueing of + -- the message that is now being processed by a worker. + requestId :: Maybe Text + } + deriving (Generic) + +-- | An empty details value to be modified by you. +emptyDetails :: Details +emptyDetails = + Details + { topic = Nothing, + partitionId = Nothing, + key = Nothing, + contents = Nothing, + createTime = Nothing, + logAppendTime = Nothing, + processAttempt = Nothing, + assignedPartitions = Nothing, + pausedPartitions = Nothing, + timeSinceLastRebalance = Nothing, + requestId = Nothing + } + +instance Aeson.ToJSON Details where + toJSON = Aeson.genericToJSON options + toEncoding = Aeson.genericToEncoding options + +options :: Aeson.Options +options = + Aeson.defaultOptions + { Aeson.fieldLabelModifier = Aeson.camelTo2 '_', + Aeson.omitNothingFields = True + } + +instance Platform.TracingSpanDetails Details + +-- | The contents of a Kafka message. Use 'mkContents' to create one of these. +data Contents where + Contents :: (Aeson.ToJSON a) => a -> Contents + +instance Aeson.ToJSON Contents where + toJSON (Contents x) = Aeson.toJSON x + toEncoding (Contents x) = Aeson.toEncoding x + +-- | Create a 'Contents' value. +-- +-- The type wrapped needs to have an Aeson.ToJSON instance, so we can present it +-- nicely in observability tools. +-- +-- > data MyMessagePayload { counter :: Int } deriving (Generic) +-- > instance Aeson.ToJSON MyMessagePayload +-- > +-- > contents = mkContents MyMessagePayload { counter = 5 } +mkContents :: Aeson.ToJSON a => a -> Contents +mkContents = Contents diff --git a/src/Log/SqlQuery.hs b/src/Log/SqlQuery.hs --- a/src/Log/SqlQuery.hs +++ b/src/Log/SqlQuery.hs @@ -63,8 +63,10 @@ instance Platform.TracingSpanDetails Details +-- | MySQL mysql :: Text mysql = "MySQL" +-- | Postgresql postgresql :: Text postgresql = "PostgreSQL" diff --git a/src/Reporter/Bugsnag/Internal.hs b/src/Reporter/Bugsnag/Internal.hs --- a/src/Reporter/Bugsnag/Internal.hs +++ b/src/Reporter/Bugsnag/Internal.hs @@ -28,7 +28,7 @@ import qualified Platform.Timer as Timer import qualified Prelude --- This function takes the root span of a completed request and reports it to +-- | This function takes the root span of a completed request and reports it to -- Bugsnag, if there has been a failure. A request that completed succesfully -- is not reported. -- @@ -474,8 +474,8 @@ { -- | The Bugsnag API key to use. This determines which Bugsnag project your -- errors will end up in. -- - -- [@environment variable@] LOG_FILE - -- [@default value@] app.log + -- [@environment variable@] BUGSNAG_API_KEY + -- [@default value@] ***** apiKey :: Log.Secret Bugsnag.ApiKey, -- | The name of this application. This will be attached to all bugsnag -- reports. diff --git a/src/Reporter/Dev.hs b/src/Reporter/Dev.hs --- a/src/Reporter/Dev.hs +++ b/src/Reporter/Dev.hs @@ -1,5 +1,4 @@ -- | Reporting for development --- -- This reporter logs basic information about requests in a human-readable -- format, for use in a development console. -- diff --git a/src/Reporter/Dev/Internal.hs b/src/Reporter/Dev/Internal.hs --- a/src/Reporter/Dev/Internal.hs +++ b/src/Reporter/Dev/Internal.hs @@ -14,7 +14,7 @@ import qualified Platform.Timer as Timer import qualified Prelude --- Print basic information about requests to stdout and make more detailed +-- | Print basic information about requests to stdout and make more detailed -- information available to the log-explorer tool. -- -- Example usage: @@ -64,6 +64,8 @@ "❌\n" ++ Builder.fromString (Exception.displayException err) +-- | Contextual information this reporter needs to do its work. You can create +-- one using 'handler'. data Handler = Handler { timer :: Timer.Timer, -- If we let each request log to stdout directly the result will be lots diff --git a/src/Reporter/File/Internal.hs b/src/Reporter/File/Internal.hs --- a/src/Reporter/File/Internal.hs +++ b/src/Reporter/File/Internal.hs @@ -15,9 +15,9 @@ import qualified System.Random as Random import qualified Prelude --- Log tracing information for a request to a file. Tracing information contains --- nested spans but will appear flattend in the log. Each tracing span will --- appear on its own line in the log, ordered by its start date. +-- | Log tracing information for a request to a file. Tracing information +-- contains nested spans but will appear flattend in the log. Each tracing span +-- will appear on its own line in the log, ordered by its start date. -- -- Example usage: -- @@ -78,6 +78,8 @@ |> Aeson.pairs |> Data.Aeson.Encoding.encodingToLazyByteString +-- | Contextual information this reporter needs to do its work. You can create +-- one using 'handler'. data Handler = Handler { fileHandle :: System.IO.Handle, logContext :: LogContext, @@ -138,6 +140,8 @@ ByteString.hPut fileHandle "\n" logLoop writeQueue fileHandle +-- | Clean up your handler after you're done with it. Call this before your +-- application shuts down. cleanup :: Handler -> Prelude.IO () cleanup Handler {loggingThread, fileHandle} = do Async.cancel loggingThread diff --git a/src/Reporter/Honeycomb.hs b/src/Reporter/Honeycomb.hs new file mode 100644 --- /dev/null +++ b/src/Reporter/Honeycomb.hs @@ -0,0 +1,11 @@ +-- | This reporter logs execution to https://honeycomb.io. +module Reporter.Honeycomb + ( Internal.report, + Internal.handler, + Internal.Handler, + Internal.Settings(..), + Internal.decoder, + ) +where + +import qualified Reporter.Honeycomb.Internal as Internal diff --git a/src/Reporter/Honeycomb/Internal.hs b/src/Reporter/Honeycomb/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Reporter/Honeycomb/Internal.hs @@ -0,0 +1,636 @@ +{-# LANGUAGE GADTs #-} + +module Reporter.Honeycomb.Internal where + +import qualified Control.Exception.Safe as Exception +import qualified Data.Aeson as Aeson +import qualified Data.ByteString as ByteString +import qualified Data.HashMap.Strict as HashMap +import qualified Data.List +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Text.Encoding as Encoding +import qualified Data.Text.IO +import qualified Data.UUID +import qualified Data.UUID.V4 +import qualified Data.Word +import qualified Dict +import qualified Environment +import qualified GHC.Stack as Stack +import qualified List +import qualified Log +import qualified Log.HttpRequest as HttpRequest +import qualified Log.Kafka as Kafka +import qualified Log.RedisCommands as RedisCommands +import qualified Log.SqlQuery as SqlQuery +import qualified Maybe +import qualified Network.HTTP.Client as HTTP +import qualified Network.HTTP.Client.TLS as HTTP.TLS +import qualified Network.HostName +import qualified Platform +import qualified Platform.Timer as Timer +import qualified System.Random as Random +import qualified Text +import qualified Text as NriText +import qualified Prelude + +batchApiEndpoint :: Text -> Text +batchApiEndpoint datasetName = "https://api.honeycomb.io/1/batch/" ++ datasetName + +-- | Report a tracing span to Honeycomb. +report :: Handler -> Text -> Platform.TracingSpan -> Prelude.IO () +report handler' _requestId span = do + sendOrSample <- makeSharedTraceData handler' span + case sendOrSample of + SampledOut -> Prelude.pure () + SendToHoneycomb sharedTraceData -> sendToHoneycomb handler' sharedTraceData span + +sendToHoneycomb :: Handler -> SharedTraceData -> Platform.TracingSpan -> Prelude.IO () +sendToHoneycomb handler' sharedTraceData span = do + let events = toBatchEvents sharedTraceData span + baseRequest <- + settings handler' + |> datasetName + |> batchApiEndpoint + |> Text.toList + |> HTTP.parseRequest + let req = + baseRequest + { HTTP.method = "POST", + HTTP.requestHeaders = + [ ( "X-Honeycomb-Team", + settings handler' + |> apiKey + |> Log.unSecret + ) + ], + HTTP.requestBody = HTTP.RequestBodyLBS (Aeson.encode events) + } + _ <- HTTP.httpNoBody req (http handler') + Prelude.pure () + +getRootSpanRequestPath :: Platform.TracingSpan -> Maybe Text +getRootSpanRequestPath rootSpan = + Platform.details rootSpan + |> Maybe.andThen + ( Platform.renderTracingSpanDetails + [ Platform.Renderer (\(HttpRequest.Incoming details) -> HttpRequest.endpoint details) + ] + ) + |> Maybe.andThen identity + +getSpanEndpoint :: Platform.TracingSpan -> Maybe Text +getSpanEndpoint span = + span + |> Platform.details + |> Maybe.andThen + ( Platform.renderTracingSpanDetails + [ Platform.Renderer (\(HttpRequest.Incoming details) -> HttpRequest.endpoint details), + Platform.Renderer Kafka.topic + ] + ) + |> Maybe.andThen identity + +deriveSampleRate :: Platform.TracingSpan -> Settings -> Float +deriveSampleRate rootSpan settings = + let isNonAppRequestPath = + case getRootSpanRequestPath rootSpan of + Nothing -> False + -- You might be tempted to use `endpoint` instead of `path`, but + -- healthcheck endpoints don't populate `HttpRequest.endpoint`. + -- Fix that first before trying this. + Just requestPath -> List.any (requestPath ==) ["/health/readiness", "/metrics", "/health/liveness"] + baseRate = fractionOfSuccessRequestsLogged settings + requestDurationMs = + Timer.difference (Platform.started rootSpan) (Platform.finished rootSpan) + |> Platform.inMicroseconds + |> Prelude.fromIntegral + |> (*) 1e-3 + apdexTMs = Prelude.fromIntegral (apdexTimeMs settings) + in if isNonAppRequestPath + then -- + -- We have 2678400 seconds in a month + -- We health-check once per second per Pod in Haskell + -- We have 2-3 pods at idle per service + -- We have some 5 services + -- We have up to 4 environments (staging, prod, demo, backyard) + -- + -- Healthchecks would be 107,136,000 / sampleRate traces per month + -- + -- But we also don't wanna never log them, who knows, they might cause + -- problems + -- + -- High sample rates might make honeycomb make ridiculous assumptions + -- about the actual request rate tho. Adjust if that's the case. + baseRate / 500 + else sampleRateForDuration baseRate requestDurationMs apdexTMs + +-- For every increase of apdexTU in the request duration we double the chance of +-- a request getting logged, up to a maximum of 1. +-- +-- An example plot of this function, for: +-- * apdex 30ms +-- * baseRate 1/1000 +-- * from 1ms to 300ms + +-- https://www.wolframalpha.com/input/?i=plot+1%2Fmax%281%2F1000%2C+min%281%2C+%281%2F1000%29+*+%281.5+%5E+%28x+%2F+30%29%29%29%29+from+x%3D1+to+x%3D300 +sampleRateForDuration :: Float -> Float -> Float -> Float +sampleRateForDuration baseRate requestDurationMs apdexTMs = + baseRate * (1.5 ^ (requestDurationMs / apdexTMs)) + |> clamp baseRate 1 + +calculateApdex :: Settings -> Platform.TracingSpan -> Float +calculateApdex settings span = + case Platform.succeeded span of + Platform.Failed -> 0 + Platform.FailedWith _ -> 0 + Platform.Succeeded -> + let duration = + spanDuration span + |> Platform.inMicroseconds + |> Prelude.fromIntegral + apdexTUs = 1000 * apdexTimeMs settings + in if duration < apdexTUs + then 1 + else + if duration < (4 * apdexTUs) + then 0.5 + else 0 + +toBatchEvents :: SharedTraceData -> Platform.TracingSpan -> List BatchEvent +toBatchEvents sharedTraceData span = + let (_, events) = + batchEventsHelper + sharedTraceData + Nothing + (emptyStatsByName, 0) + span + in events + +batchEventsHelper :: + SharedTraceData -> + Maybe SpanId -> + (StatsByName, Int) -> + Platform.TracingSpan -> + ((StatsByName, Int), [BatchEvent]) +batchEventsHelper sharedTraceData parentSpanId (statsByName, spanIndex) span = do + let isRootSpan = parentSpanId == Nothing + let thisSpansId = SpanId (requestId sharedTraceData ++ "-" ++ NriText.fromInt spanIndex) + let ((lastStatsByName, lastSpanIndex), nestedChildren) = + Data.List.mapAccumL + (batchEventsHelper sharedTraceData (Just thisSpansId)) + ( -- Don't record the root span. We have only one of those per trace, + -- so there's no statistics we can do with it. + if isRootSpan + then statsByName + else recordStats span statsByName, + spanIndex + 1 + ) + (Platform.children span) + let children = List.concat nestedChildren + let duration = + Timer.difference (Platform.started span) (Platform.finished span) + |> Platform.inMicroseconds + let timestamp = Timer.toISO8601 (timer sharedTraceData) (Platform.started span) + let sourceLocation = + Platform.frame span + |> Maybe.map + ( \(_, frame) -> + Text.fromList (Stack.srcLocFile frame) + ++ ":" + ++ Text.fromInt (Prelude.fromIntegral (Stack.srcLocStartLine frame)) + ) + let isError = case Platform.succeeded span of + Platform.Succeeded -> False + Platform.Failed -> True + Platform.FailedWith _ -> True + let addStats span' = + if isRootSpan + then perSpanNameStats lastStatsByName span' + else span' + let addEndpoint span' = + case endpoint sharedTraceData of + Nothing -> span' + Just endpoint -> addField "endpoint" endpoint span' + let hcSpan = + initSpan sharedTraceData + |> addField "name" (Platform.name span) + |> addField "trace.span_id" thisSpansId + |> addField "trace.parent_id" parentSpanId + |> addField "duration_ms" (Prelude.fromIntegral duration / 1000) + |> addField "allocated_bytes" (Platform.allocated span) + |> addField "failed" isError + |> addField "source_location" sourceLocation + |> addDetails span + |> addEndpoint + |> addStats + ( (lastStatsByName, lastSpanIndex), + BatchEvent + { batchevent_time = timestamp, + batchevent_data = hcSpan, + batchevent_samplerate = sampleRate sharedTraceData + } : + children + ) + +data Stats = Stats + { count :: Int, + totalTimeMicroseconds :: Data.Word.Word64 + } + +newtype StatsByName = StatsByName (Dict.Dict Text Stats) + +emptyStatsByName :: StatsByName +emptyStatsByName = StatsByName Dict.empty + +recordStats :: Platform.TracingSpan -> StatsByName -> StatsByName +recordStats span (StatsByName statsByName) = + let name = Platform.name span + duration = Platform.inMicroseconds (spanDuration span) + newStats = + case Dict.get name statsByName of + Nothing -> + Stats + { count = 1, + totalTimeMicroseconds = duration + } + Just stats -> + Stats + { count = 1 + count stats, + totalTimeMicroseconds = duration + totalTimeMicroseconds stats + } + in StatsByName (Dict.insert name newStats statsByName) + +spanDuration :: Platform.TracingSpan -> Platform.MonotonicTime +spanDuration span = + Timer.difference (Platform.started span) (Platform.finished span) + +perSpanNameStats :: StatsByName -> Span -> Span +perSpanNameStats (StatsByName statsByName) span = + let -- chose foldr to preserve order, not super important tho + statsForCategory (name, stats) acc = + let calls = count stats + total = Prelude.fromIntegral (totalTimeMicroseconds stats) / 1000 + average = total / Prelude.fromIntegral calls + saneName = useAsKey name + in acc + |> addField ("stats.total_time_ms." ++ saneName) total + |> addField ("stats.average_time_ms." ++ saneName) average + |> addField ("stats.count." ++ saneName) calls + in List.foldl statsForCategory span (Dict.toList statsByName) + +useAsKey :: Text -> Text +useAsKey str = + str + |> NriText.toLower + |> NriText.replace " " "_" + +-- Customize how we render span details for different kinds of spans to +-- Honeycomb. +-- +-- In the past we used the toHashMap helper to generate the JSON representations +-- we send to honeycomb (see its documentation in the Helpers module to learn +-- more about it). This turned out to be a poor fit because it creates a ton of +-- top-level JSON keys, each of which Honeycomb will create a unique column for. +-- +-- If we ever hit 10k unique column names (and we were past the thousands when +-- this code was introduced) Honeycomb will stop accepting traces from us. +-- +-- "Unique column names" means different column names that Honeycomb has seen us +-- report on a span. +addDetails :: Platform.TracingSpan -> Span -> Span +addDetails tracingSpan honeycombSpan = + case Platform.details tracingSpan of + Just details -> + details + |> Platform.renderTracingSpanDetails + [ Platform.Renderer (renderDetailsLog honeycombSpan), + Platform.Renderer (renderDetailsRedis honeycombSpan), + Platform.Renderer + ( \(_ :: HttpRequest.Incoming) -> + renderDetailsGeneric "http" details honeycombSpan + ), + Platform.Renderer + ( \(_ :: SqlQuery.Details) -> + renderDetailsGeneric "sql" details honeycombSpan + ), + Platform.Renderer + ( \(_ :: Kafka.Details) -> + renderDetailsGeneric "kafka" details honeycombSpan + ) + ] + -- `renderTracingSpanDetails` returns Nothing when type of details + -- doesn't match any in our list of functions above. + -- + -- We'll default to using the default JSON encoding of the honeycombSpan. + -- Assuming it encodes into a JSON object with multiple keys (every + -- known details object we have does this) we'll use that object + -- directly. + |> Maybe.withDefault + (renderDetailsGeneric (Platform.name tracingSpan) details honeycombSpan) + Nothing -> honeycombSpan + +renderDetailsGeneric :: Text -> Platform.SomeTracingSpanDetails -> Span -> Span +renderDetailsGeneric keyPrefix details honeycombSpan = + case Aeson.toJSON details of + Aeson.Object hashMap -> + HashMap.foldrWithKey + (\key value -> addField (useAsKey (keyPrefix ++ "." ++ key)) value) + honeycombSpan + hashMap + jsonVal -> addField keyPrefix jsonVal honeycombSpan + +-- LogContext is an unbounded list of key value pairs with possibly nested +-- stuff in them. Aeson flatens the nesting, so: +-- +-- {error: [{quiz: [{"some-quiz-id": "some context"}]}]} +-- +-- becomes +-- +-- {"error.0.quiz.0.some-quiz-id": "some context"} +-- +-- - With "some-quiz-id" in the example above, we have an unbounded number of +-- unique columns. +-- - With long lists, the `.0` parts helps boost our unique column name growth. +-- +-- We don't need Honeycomb to collect rich error information. +-- That's what we pay Bugsnag for. +renderDetailsLog :: Span -> Log.LogContexts -> Span +renderDetailsLog span context@(Log.LogContexts contexts) = + if List.length contexts > 5 + then addField "log.context" context span + else + List.foldl + (\(Log.Context key val) -> addField ("log." ++ key) val) + span + contexts + +-- Redis creates one column per command for batches +-- Let's trace what matters: +-- - How many of each command +-- - The full blob in a single column +-- - The rest of our Info record +renderDetailsRedis :: Span -> RedisCommands.Details -> Span +renderDetailsRedis span redisInfo = + let addCommandCounts span' = + redisInfo + |> RedisCommands.commands + |> List.filterMap (NriText.words >> List.head) + |> NonEmpty.groupWith identity + |> List.foldr + ( \xs -> + addField + ("redis." ++ NonEmpty.head xs ++ ".count") + (NonEmpty.length xs) + ) + span' + fullBlob = + redisInfo + |> RedisCommands.commands + |> Aeson.toJSON + in span + |> addField "redis.commands" fullBlob + |> addField "redis.host" (RedisCommands.host redisInfo) + |> addField "redis.port" (RedisCommands.port redisInfo) + |> addCommandCounts + +data BatchEvent = BatchEvent + { batchevent_time :: Text, + batchevent_data :: Span, + batchevent_samplerate :: Int + } + deriving (Generic, Show) + +options :: Aeson.Options +options = + Aeson.defaultOptions + { -- Drop the batchevent_ prefix + Aeson.fieldLabelModifier = List.drop 1 << Prelude.dropWhile ('_' /=) + } + +instance Aeson.ToJSON BatchEvent where + toJSON = Aeson.genericToJSON options + +data SharedTraceData = SharedTraceData + { -- | We use this to turn GHC.Clock-produced timestamps into regular times. + timer :: Timer.Timer, + -- | Each request has a unique id, for correlating spans for the same request. + requestId :: Text, + -- | A honeycomb span with the common fields for this request pre-applied. + initSpan :: Span, + -- | The 'endpoint' of the request this trace describes. Honeycomb uses + -- this for a breakdown-by-endpoint on the dataset home. + endpoint :: Maybe Text, + -- | The amount of similar traces this one trace represents. For example, + -- if we send this trace but sampled out 9 similar ones, sample rate will be + -- 10. This will let honeycomb know it should count this trace as 10. + sampleRate :: Int + } + +-- | Honeycomb defines a span to be a list of key-value pairs, which we model +-- using a dictionary. Honeycomb expects as values anything that's valid JSON. +-- +-- We could use the `Aeson.Value` type to model values, but that mean we'd be +-- encoding spans for honeycomb in two steps: first from our original types to +-- `Aeson.Value`, then to the `ByteString` we send in the network request. +-- `Aeson` has a more efficient encoding strategy that is able to encode types +-- into JSON in one go. To use that we accept as keys any value we know we'll be +-- able to encode into JSON later, once we got the whole payload we want to send +-- to honeycomb together. +newtype Span = Span (Dict.Dict Text JsonEncodable) + deriving (Aeson.ToJSON, Show) + +data JsonEncodable where + JsonEncodable :: Aeson.ToJSON a => a -> JsonEncodable + +instance Aeson.ToJSON JsonEncodable where + toEncoding (JsonEncodable x) = Aeson.toEncoding x + toJSON (JsonEncodable x) = Aeson.toJSON x + +instance Show JsonEncodable where + show (JsonEncodable x) = Prelude.show (Aeson.toJSON x) + +emptySpan :: Span +emptySpan = Span Dict.empty + +addField :: Aeson.ToJSON a => Text -> a -> Span -> Span +addField key val (Span span) = Span (Dict.insert key (JsonEncodable val) span) + +newtype SpanId = SpanId Text + deriving (Aeson.ToJSON, Eq, Show) + +-- | Contextual information this reporter needs to do its work. You can create +-- one using 'handler'. +data Handler = Handler + { http :: HTTP.Manager, + settings :: Settings, + makeSharedTraceData :: Platform.TracingSpan -> Prelude.IO SendOrSample + } + +data SendOrSample + = SendToHoneycomb SharedTraceData + | SampledOut + +-- | Create a 'Handler' for a specified set of 'Settings'. Do this once when +-- your application starts and reuse the 'Handler' you get. +handler :: Settings -> Prelude.IO Handler +handler settings = do + timer <- Timer.mkTimer + http <- HTTP.TLS.getGlobalManager + revision <- getRevision + hostname' <- Network.HostName.getHostName + let baseSpan = + emptySpan + |> addField "service_name" (serviceName settings) + |> addField "hostname" (Text.fromList hostname') + |> addField "revision" revision + Prelude.pure + Handler + { http = http, + settings = settings, + makeSharedTraceData = \span -> do + -- This is an initial implementation of sampling, based on + -- https://docs.honeycomb.io/working-with-your-data/best-practices/sampling/ + -- using Dynamic Sampling based on whether the request was successful or not. + -- + -- We can go further and: + -- + -- * Not sample requests above a certain configurable threshold, to replicate + -- NewRelic's slow request tracing. + -- * Apply some sampling rate to errors + -- * Apply different sample rates depending on traffic (easiest approximation + -- is basing it off of time of day) so we sample less at low traffic + + (skipLogging, sampleRate) <- + case Platform.succeeded span of + Platform.Succeeded -> do + let probability = deriveSampleRate span settings + roll <- Random.randomRIO (0.0, 1.0) + Prelude.pure (roll > probability, round (1 / probability)) + Platform.Failed -> Prelude.pure (False, 1) + Platform.FailedWith _ -> Prelude.pure (False, 1) + uuid <- Data.UUID.V4.nextRandom + if skipLogging + then Prelude.pure SampledOut + else + Prelude.pure + <| SendToHoneycomb + SharedTraceData + { timer, + sampleRate, + requestId = Data.UUID.toText uuid, + endpoint = getSpanEndpoint span, + initSpan = + baseSpan + |> addField "apdex" (calculateApdex settings span) + -- Don't use requestId if we don't do Distributed Tracing + -- Else, it will create traces with no parent sharing the same TraceId + -- Which makes Honeycomb's UI confused + |> addField "trace.trace_id" (Data.UUID.toText uuid) + } + } + +newtype Revision = Revision Text + deriving (Show, Aeson.ToJSON) + +-- | Get the GIT revision of the current code. We do this by reading a file that +-- our K8S setup is supposed to provide. +getRevision :: Prelude.IO Revision +getRevision = do + eitherRevision <- Exception.tryAny <| Data.Text.IO.readFile "revision" + case eitherRevision of + Prelude.Left _err -> Prelude.pure (Revision "no revision file found") + Prelude.Right version -> Prelude.pure (Revision version) + +-- | Configuration settings for ths reporter. A value of this type can be read +-- from the environment using the 'decoder' function. +data Settings = Settings + { -- | The Honeycomb API key to use. + apiKey :: Log.Secret ByteString.ByteString, + -- | The name of the honeycomb dataset to report to. If the dataset does not + -- exist yet, Honeycomb will create it when you first send a request for it. + -- + -- [@environment variable@] HONEYCOMB_API_KEY + -- [@default value@] ***** + datasetName :: Text, + -- | The name of the service we're reporting for. + -- + -- [@environment variable@] HONEYCOMB_SERVICE_NAME + -- [@default value@] service + serviceName :: Text, + -- | The fraction of successfull requests that will be reported. If your + -- service receives a lot of requests you might want reduce this to safe + -- cost. + -- + -- [@environment variable@] HONEYCOMB_FRACTION_OF_SUCCESS_REQUESTS_LOGGED + -- [@default value@] 1 + fractionOfSuccessRequestsLogged :: Float, + -- | The apdex time for this service in ms. Requests handled faster than + -- this time will be sampled according to the + -- @HONEYCOMB_FRACTION_OF_SUCCESS_REQUESTS_LOGGED@ variable. Slower request + -- will have a larger chance to be reported. + -- + -- [@environment variable@] HONEYCOMB_APDEX_TIME_IN_MILLISECONDS + -- [@default value@] 100 + apdexTimeMs :: Int + } + +-- | Read 'Settings' from environment variables. Default variables will be used +-- in case no environment variable is set for an option. +decoder :: Environment.Decoder Settings +decoder = + Prelude.pure Settings + |> andMap honeycombApiKeyDecoder + |> andMap datasetNameDecoder + |> andMap honeycombAppNameDecoder + |> andMap fractionOfSuccessRequestsLoggedDecoder + |> andMap apdexTimeMsDecoder + +honeycombApiKeyDecoder :: Environment.Decoder (Log.Secret ByteString.ByteString) +honeycombApiKeyDecoder = + Environment.variable + Environment.Variable + { Environment.name = "HONEYCOMB_API_KEY", + Environment.description = "The API key for Honeycomb", + Environment.defaultValue = "*****" + } + (Environment.text |> map Encoding.encodeUtf8 |> Environment.secret) + +datasetNameDecoder :: Environment.Decoder Text +datasetNameDecoder = + Environment.variable + Environment.Variable + { Environment.name = "HONEYCOMB_DATASET", + Environment.description = "Name of the dataset honeycomb should log to.", + Environment.defaultValue = "dataset" + } + Environment.text + +honeycombAppNameDecoder :: Environment.Decoder Text +honeycombAppNameDecoder = + Environment.variable + Environment.Variable + { Environment.name = "HONEYCOMB_SERVICE_NAME", + Environment.description = "Variable that sets the honeycomb service name.", + Environment.defaultValue = "service" + } + Environment.text + +fractionOfSuccessRequestsLoggedDecoder :: Environment.Decoder Float +fractionOfSuccessRequestsLoggedDecoder = + Environment.variable + Environment.Variable + { Environment.name = "HONEYCOMB_FRACTION_OF_SUCCESS_REQUESTS_LOGGED", + Environment.description = "The fraction of successful requests logged. Defaults to logging all successful requests.", + Environment.defaultValue = "1" + } + Environment.float + +apdexTimeMsDecoder :: Environment.Decoder Int +apdexTimeMsDecoder = + Environment.variable + Environment.Variable + { Environment.name = "HONEYCOMB_APDEX_TIME_IN_MILLISECONDS", + Environment.description = "The T value in the apdex, the time in milliseconds in which a healthy request should complete.", + Environment.defaultValue = "100" + } + Environment.int diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -4,6 +4,7 @@ import qualified Spec.Reporter.Bugsnag import qualified Spec.Reporter.Dev import qualified Spec.Reporter.File +import qualified Spec.Reporter.Honeycomb import qualified Test import qualified Prelude @@ -17,5 +18,6 @@ [ Spec.Platform.Timer.tests, Spec.Reporter.Bugsnag.tests, Spec.Reporter.Dev.tests, - Spec.Reporter.File.tests + Spec.Reporter.File.tests, + Spec.Reporter.Honeycomb.tests ] diff --git a/tests/Spec/Reporter/Honeycomb.hs b/tests/Spec/Reporter/Honeycomb.hs new file mode 100644 --- /dev/null +++ b/tests/Spec/Reporter/Honeycomb.hs @@ -0,0 +1,373 @@ +module Spec.Reporter.Honeycomb (tests) where + +import qualified Control.Exception.Safe as Exception +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Encode.Pretty +import qualified Data.ByteString.Lazy +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Text.Encoding +import qualified Data.Time.Clock.POSIX as Clock.POSIX +import qualified Data.Time.LocalTime as LocalTime +import qualified Dict +import qualified Expect +import qualified GHC.Stack as Stack +import qualified Log +import qualified Log.HttpRequest as HttpRequest +import qualified Log.Kafka as Kafka +import qualified Log.RedisCommands as RedisCommands +import qualified Log.SqlQuery as SqlQuery +import qualified Platform +import qualified Platform.Timer as Timer +import qualified Reporter.Honeycomb.Internal as Honeycomb +import Test (Test, describe, test) + +tests :: Test +tests = + describe + "Observability.Honeycomb" + [ test "encodes span marked as failed as an exception" <| \_ -> + emptyTracingSpan + { Platform.name = "root span", + Platform.succeeded = Platform.Failed + } + |> toBatchEvents + |> encodesTo "honeycomb-failure-without-exception", + test "if an exception was thrown use that exceptions name" <| \_ -> + emptyTracingSpan + { Platform.name = "root span", + Platform.frame = Just ("function1", Stack.SrcLoc "package1" "Module2" "Filename1.hs" 0 1 2 3) + } + |> toBatchEvents + |> encodesTo "honeycomb-source-location", + test "encodes span with source location" <| \_ -> + emptyTracingSpan + { Platform.name = "root span", + Platform.succeeded = + Platform.FailedWith (Exception.SomeException (CustomException "something went wrong")) + } + |> toBatchEvents + |> encodesTo "honeycomb-failure-with-exception", + test "encodes information about an incoming http request" <| \_ -> + emptyTracingSpan + { Platform.name = "Incoming HTTP Request", + Platform.succeeded = Platform.Failed, + Platform.details = + HttpRequest.emptyDetails + { HttpRequest.httpVersion = Just "1", + HttpRequest.method = Just "GET", + HttpRequest.path = Just "/hats/5", + HttpRequest.queryString = Just "?top=flat", + HttpRequest.endpoint = Just "GET /hats/:hat_id", + HttpRequest.headers = Dict.fromList [("Accept", "application/json")], + HttpRequest.status = Just 500 + } + |> HttpRequest.Incoming + |> Platform.toTracingSpanDetails + |> Just + } + |> toBatchEvents + |> encodesTo "honeycomb-failure-incoming-http-request", + test "encodes information about an processing kafka message" <| \_ -> + emptyTracingSpan + { Platform.name = "Processing Kafka Message", + Platform.succeeded = Platform.Failed, + Platform.details = + Kafka.emptyDetails + { Kafka.topic = Just "topic", + Kafka.partitionId = Just 12, + Kafka.key = Just "key", + Kafka.contents = Just (Kafka.mkContents ()), + Kafka.createTime = Just (Clock.POSIX.posixSecondsToUTCTime 0), + Kafka.logAppendTime = Just (Clock.POSIX.posixSecondsToUTCTime 0), + Kafka.timeSinceLastRebalance = Just 0, + Kafka.processAttempt = Just 0, + Kafka.assignedPartitions = Just 1, + Kafka.pausedPartitions = Just 2, + Kafka.requestId = Just "requestId" + } + |> Platform.toTracingSpanDetails + |> Just + } + |> toBatchEvents + |> encodesTo "honeycomb-failure-processing-kafka-message", + test "renders sql query failures correctly" <| \_ -> + emptyTracingSpan + { Platform.name = "MySQL Query", + Platform.succeeded = Platform.Failed, + Platform.details = + SqlQuery.emptyDetails + { SqlQuery.databaseType = Just SqlQuery.postgresql, + SqlQuery.query = Just (Log.mkSecret "SELECT name FROM ants WHERE id = ?"), + SqlQuery.queryTemplate = Just "SELECT name FROM ants WHERE id = ${id}", + SqlQuery.sqlOperation = Just "SELECT", + SqlQuery.queriedRelation = Just "ants", + SqlQuery.host = Just "http://antsonline.com", + SqlQuery.port = Just 5432, + SqlQuery.database = Just "nri", + SqlQuery.rowsReturned = Just 5 + } + |> Platform.toTracingSpanDetails + |> Just + } + |> toBatchEvents + |> encodesTo "honeycomb-failure-sql", + test "renders redis query failures correctly" <| \_ -> + emptyTracingSpan + { Platform.name = "Make Redis Query", + Platform.succeeded = Platform.Failed, + Platform.details = + RedisCommands.emptyDetails + { RedisCommands.host = Just "cache.noredink.com", + RedisCommands.port = Just 6379, + RedisCommands.commands = ["GET somekey"] + } + |> Platform.toTracingSpanDetails + |> Just + } + |> toBatchEvents + |> encodesTo "honeycomb-failure-redis", + test "renders outgoing http request failures correctly" <| \_ -> + emptyTracingSpan + { Platform.name = "Making HTTP request", + Platform.succeeded = Platform.Failed, + Platform.details = + HttpRequest.emptyDetails + { HttpRequest.host = Just "http://antsonline.com", + HttpRequest.path = Just "/bulletin", + HttpRequest.method = Just "GET" + } + |> HttpRequest.Outgoing + |> Platform.toTracingSpanDetails + |> Just + } + |> toBatchEvents + |> encodesTo "honeycomb-failure-http", + test "renders log failures correctly" <| \_ -> + emptyTracingSpan + { Platform.succeeded = Platform.Failed, + Platform.name = "log message", + Platform.details = + Log.LogContexts + [ Log.context "number" (4 :: Int), + Log.context "text" ("Hi!" :: Text), + Log.context "advisory" "close the windows!" + ] + |> Platform.toTracingSpanDetails + |> Just + } + |> toBatchEvents + |> encodesTo "honeycomb-failure-log", + test "renders withContext failures correctly" <| \_ -> + emptyTracingSpan + { Platform.succeeded = Platform.Failed, + Platform.name = "some context", + Platform.details = + Log.LogContexts + [ Log.context "number" (4 :: Int) + ] + |> Platform.toTracingSpanDetails + |> Just, + Platform.children = + [ emptyTracingSpan + { Platform.succeeded = Platform.Succeeded + } + ] + } + |> toBatchEvents + |> encodesTo "honeycomb-failure-with-context", + test "merges unknown span details from nested spans into metadata" <| \_ -> + emptyTracingSpan + { Platform.name = "measure weather", + Platform.succeeded = Platform.Failed, + Platform.details = + CustomDetails "32 C" + |> Platform.toTracingSpanDetails + |> Just, + Platform.children = + [ emptyTracingSpan + { Platform.name = "measure humidity", + Platform.succeeded = Platform.Failed, + Platform.details = + CustomDetails "25 %" + |> Platform.toTracingSpanDetails + |> Just + } + ] + } + |> toBatchEvents + |> encodesTo "honeycomb-failure-unknown", + test "tags all child spans with the root's endpoint" <| \_ -> + emptyTracingSpan + { Platform.name = "root span", + Platform.children = + [ emptyTracingSpan + { Platform.children = [emptyTracingSpan] + } + ], + Platform.details = + HttpRequest.emptyDetails + { HttpRequest.httpVersion = Just "1", + HttpRequest.method = Just "GET", + HttpRequest.path = Just "/hats/5", + HttpRequest.queryString = Just "?top=flat", + HttpRequest.endpoint = Just "GET /hats/:hat_id", + HttpRequest.headers = Dict.fromList [("Accept", "application/json")], + HttpRequest.status = Just 500 + } + |> HttpRequest.Incoming + |> Platform.toTracingSpanDetails + |> Just + } + |> toBatchEvents + |> encodesTo "honeycomb-child-spans-endpoint", + test "de-noises nested log events at enrichment time" <| \_ -> + emptyTracingSpan + { Platform.name = "root span", + Platform.children = + [ emptyTracingSpan + { Platform.succeeded = Platform.Failed, + Platform.name = "log message", + Platform.details = + Log.LogContexts + [ Log.context "number" (4 :: Int), + Log.context "text" ("Hi!" :: Text), + Log.context + "nested" + ( HashMap.fromList + [ ("a", HashMap.fromList [("b", 1)]) + ] :: + HashMap.HashMap Text (HashMap.HashMap Text Int) + ) + ] + |> Platform.toTracingSpanDetails + |> Just + } + ] + } + |> toBatchEvents + |> encodesTo "honeycomb-denoising-log", + test "de-noises redis queries at enrichment time" <| \_ -> + emptyTracingSpan + { Platform.name = "Make Redis query", + Platform.children = + [ emptyTracingSpan + { Platform.succeeded = Platform.Succeeded, + Platform.details = + RedisCommands.emptyDetails + { RedisCommands.host = Just "cache.noredink.com", + RedisCommands.port = Just 6379, + RedisCommands.commands = + ["GET somekey", "GET otherkey", "HGETALL idk"] + } + |> Platform.toTracingSpanDetails + |> Just + } + ] + } + |> toBatchEvents + |> encodesTo "honeycomb-denoising-redis", + test "doesn't touch sql spans" <| \_ -> + emptyTracingSpan + { Platform.name = "Make Postgres query", + Platform.children = + [ emptyTracingSpan + { Platform.succeeded = Platform.Succeeded, + Platform.details = + SqlQuery.emptyDetails + { SqlQuery.databaseType = Just SqlQuery.postgresql, + SqlQuery.query = Just (Log.mkSecret "SELECT name FROM ants WHERE id = ?"), + SqlQuery.queryTemplate = Just "SELECT name FROM ants WHERE id = ${id}", + SqlQuery.sqlOperation = Just "SELECT", + SqlQuery.queriedRelation = Just "ants", + SqlQuery.host = Just "http://antsonline.com", + SqlQuery.port = Just 5432, + SqlQuery.database = Just "nri", + SqlQuery.rowsReturned = Just 5 + } + |> Platform.toTracingSpanDetails + |> Just + } + ] + } + |> toBatchEvents + |> encodesTo "honeycomb-denoising-sql", + describe + "sampleRateForDuration" + [ test "request duration affects sample rate as expected" <| \_ -> do + let baseRate = 0.001 + let apdexTMs = 10 + let durations = List.map (\n -> round (2 ^ toFloat n)) (List.range 1 8) + let sampleRates = + List.map + ( \duration -> + Honeycomb.sampleRateForDuration + baseRate + (toFloat duration) + apdexTMs + ) + durations + List.map2 + ( \duration sampleRate -> + Text.fromInt duration ++ "ms: " ++ Text.fromFloat sampleRate + ) + durations + sampleRates + |> (:) ("apdex T: " ++ Text.fromFloat apdexTMs ++ "ms") + |> Text.join "\n" + |> Expect.equalToContentsOf "test/golden-results/observability-spec-honeycomb-sampling" + ] + ] + +newtype CustomException = CustomException Text deriving (Show) + +instance Exception.Exception CustomException + +newtype CustomDetails = CustomDetails Text + deriving (Aeson.ToJSON) + +instance Platform.TracingSpanDetails CustomDetails + +timer :: Timer.Timer +timer = Timer.Timer 0 LocalTime.utc + +emptyTracingSpan :: Platform.TracingSpan +emptyTracingSpan = + Platform.emptyTracingSpan + { Platform.name = "some-span", + Platform.started = 0, + Platform.finished = 0, + Platform.frame = Nothing, + Platform.details = Nothing, + Platform.succeeded = Platform.Succeeded, + Platform.allocated = 0, + Platform.children = [] + } + +toBatchEvents :: Platform.TracingSpan -> [Honeycomb.BatchEvent] +toBatchEvents span = + let commonFields = + Honeycomb.SharedTraceData + { Honeycomb.timer = timer, + Honeycomb.requestId = "request-id-123", + Honeycomb.endpoint = Just "GET /hats/:hat_id", + Honeycomb.sampleRate = 1, + Honeycomb.initSpan = + Honeycomb.emptySpan + |> Honeycomb.addField "service_name" "some service" + |> Honeycomb.addField "hostname" "some-service-oaiefiowh-aoidawi" + |> Honeycomb.addField "apdex" 1 + |> Honeycomb.addField "revision" (Honeycomb.Revision "gitref") + -- Don't use requestId if we don't do Distributed Tracing + -- Else, it will create traces with no parent sharing the same TraceId + -- Which makes Honeycomb's UI confused + |> Honeycomb.addField "trace.trace_id" "request-id-123" + } + in Honeycomb.toBatchEvents commonFields span + +encodesTo :: Text -> [Honeycomb.BatchEvent] -> Expect.Expectation +encodesTo filename events = + events + |> Data.Aeson.Encode.Pretty.encodePretty + |> Data.ByteString.Lazy.toStrict + |> Data.Text.Encoding.decodeUtf8 + |> Expect.equalToContentsOf ("test/golden-results/" ++ filename ++ ".json")