nri-observability 0.1.0.3 → 0.1.1.0

raw patch · 13 files changed

+1178/−10 lines, 13 filesdep +uuidPVP ok

version bump matches the API change (PVP)

Dependencies added: uuid

API changes (from Hackage documentation)

Files

• CHANGELOG.md +5/−0
• nri-observability.cabal +10/−1
• src/Log/HttpRequest.hs +4/−0
• src/Log/Kafka.hs +121/−0
• src/Log/SqlQuery.hs +2/−0
• src/Reporter/Bugsnag/Internal.hs +3/−3
• src/Reporter/Dev.hs +0/−1
• src/Reporter/Dev/Internal.hs +3/−1
• src/Reporter/File/Internal.hs +7/−3
• src/Reporter/Honeycomb.hs +11/−0
• src/Reporter/Honeycomb/Internal.hs +636/−0
• tests/Main.hs +3/−1
• tests/Spec/Reporter/Honeycomb.hs +373/−0

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

@@ -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 <https://github.com/NoRedInk/haskell-libraries/tree/trunk/nri-observability#readme>. 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

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

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

@@ -63,8 +63,10 @@  instance Platform.TracingSpanDetails Details +-- | MySQL mysql :: Text mysql = "MySQL" +-- | Postgresql postgresql :: Text postgresql = "PostgreSQL"

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

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

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

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

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

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

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

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