{-# 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.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.AesonHelpers as AesonHelpers
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 :: Text -> Text
batchApiEndpoint Text
datasetName = Text
"https://api.honeycomb.io/1/batch/" Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
datasetName

-- | Report a tracing span to Honeycomb.
report :: Handler -> Text -> Platform.TracingSpan -> Prelude.IO ()
report :: Handler -> Text -> TracingSpan -> IO ()
report Handler
handler' Text
_requestId TracingSpan
span = do
  SendOrSample
sendOrSample <- Handler -> TracingSpan -> IO SendOrSample
makeSharedTraceData Handler
handler' TracingSpan
span
  case SendOrSample
sendOrSample of
    SendOrSample
SampledOut -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure ()
    SendToHoneycomb SharedTraceData
sharedTraceData -> Handler -> SharedTraceData -> TracingSpan -> IO ()
sendToHoneycomb Handler
handler' SharedTraceData
sharedTraceData TracingSpan
span

sendToHoneycomb :: Handler -> SharedTraceData -> Platform.TracingSpan -> Prelude.IO ()
sendToHoneycomb :: Handler -> SharedTraceData -> TracingSpan -> IO ()
sendToHoneycomb Handler
handler' SharedTraceData
sharedTraceData TracingSpan
span = do
  let events :: List BatchEvent
events = SharedTraceData -> TracingSpan -> List BatchEvent
toBatchEvents SharedTraceData
sharedTraceData TracingSpan
span
  Request
baseRequest <-
    Handler -> Settings
settings Handler
handler'
      Settings -> (Settings -> Text) -> Text
forall a b. a -> (a -> b) -> b
|> Settings -> Text
datasetName
      Text -> (Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
|> Text -> Text
batchApiEndpoint
      Text -> (Text -> List Char) -> List Char
forall a b. a -> (a -> b) -> b
|> Text -> List Char
Text.toList
      List Char -> (List Char -> IO Request) -> IO Request
forall a b. a -> (a -> b) -> b
|> List Char -> IO Request
forall (m :: * -> *). MonadThrow m => List Char -> m Request
HTTP.parseRequest
  let req :: Request
req =
        Request
baseRequest
          { method :: Method
HTTP.method = Method
"POST",
            requestHeaders :: RequestHeaders
HTTP.requestHeaders =
              [ ( HeaderName
"X-Honeycomb-Team",
                  Handler -> Settings
settings Handler
handler'
                    Settings -> (Settings -> Secret Method) -> Secret Method
forall a b. a -> (a -> b) -> b
|> Settings -> Secret Method
apiKey
                    Secret Method -> (Secret Method -> Method) -> Method
forall a b. a -> (a -> b) -> b
|> Secret Method -> Method
forall a. Secret a -> a
Log.unSecret
                )
              ],
            requestBody :: RequestBody
HTTP.requestBody = ByteString -> RequestBody
HTTP.RequestBodyLBS (List BatchEvent -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode List BatchEvent
events)
          }
  Response ()
_ <- Request -> Manager -> IO (Response ())
HTTP.httpNoBody Request
req (Handler -> Manager
http Handler
handler')
  () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure ()

getRootSpanRequestPath :: Platform.TracingSpan -> Maybe Text
getRootSpanRequestPath :: TracingSpan -> Maybe Text
getRootSpanRequestPath TracingSpan
rootSpan =
  TracingSpan -> Maybe SomeTracingSpanDetails
Platform.details TracingSpan
rootSpan
    Maybe SomeTracingSpanDetails
-> (Maybe SomeTracingSpanDetails -> Maybe (Maybe Text))
-> Maybe (Maybe Text)
forall a b. a -> (a -> b) -> b
|> (SomeTracingSpanDetails -> Maybe (Maybe Text))
-> Maybe SomeTracingSpanDetails -> Maybe (Maybe Text)
forall a b. (a -> Maybe b) -> Maybe a -> Maybe b
Maybe.andThen
      ( [Renderer (Maybe Text)]
-> SomeTracingSpanDetails -> Maybe (Maybe Text)
forall a. [Renderer a] -> SomeTracingSpanDetails -> Maybe a
Platform.renderTracingSpanDetails
          [ (Incoming -> Maybe Text) -> Renderer (Maybe Text)
forall s a. TracingSpanDetails s => (s -> a) -> Renderer a
Platform.Renderer (\(HttpRequest.Incoming Details
details) -> Details -> Maybe Text
HttpRequest.endpoint Details
details)
          ]
      )
    Maybe (Maybe Text)
-> (Maybe (Maybe Text) -> Maybe Text) -> Maybe Text
forall a b. a -> (a -> b) -> b
|> (Maybe Text -> Maybe Text) -> Maybe (Maybe Text) -> Maybe Text
forall a b. (a -> Maybe b) -> Maybe a -> Maybe b
Maybe.andThen Maybe Text -> Maybe Text
forall a. a -> a
identity

getSpanEndpoint :: Platform.TracingSpan -> Maybe Text
getSpanEndpoint :: TracingSpan -> Maybe Text
getSpanEndpoint TracingSpan
span =
  TracingSpan
span
    TracingSpan
-> (TracingSpan -> Maybe SomeTracingSpanDetails)
-> Maybe SomeTracingSpanDetails
forall a b. a -> (a -> b) -> b
|> TracingSpan -> Maybe SomeTracingSpanDetails
Platform.details
    Maybe SomeTracingSpanDetails
-> (Maybe SomeTracingSpanDetails -> Maybe (Maybe Text))
-> Maybe (Maybe Text)
forall a b. a -> (a -> b) -> b
|> (SomeTracingSpanDetails -> Maybe (Maybe Text))
-> Maybe SomeTracingSpanDetails -> Maybe (Maybe Text)
forall a b. (a -> Maybe b) -> Maybe a -> Maybe b
Maybe.andThen
      ( [Renderer (Maybe Text)]
-> SomeTracingSpanDetails -> Maybe (Maybe Text)
forall a. [Renderer a] -> SomeTracingSpanDetails -> Maybe a
Platform.renderTracingSpanDetails
          [ (Incoming -> Maybe Text) -> Renderer (Maybe Text)
forall s a. TracingSpanDetails s => (s -> a) -> Renderer a
Platform.Renderer (\(HttpRequest.Incoming Details
details) -> Details -> Maybe Text
HttpRequest.endpoint Details
details),
            (Details -> Maybe Text) -> Renderer (Maybe Text)
forall s a. TracingSpanDetails s => (s -> a) -> Renderer a
Platform.Renderer Details -> Maybe Text
Kafka.topic
          ]
      )
    Maybe (Maybe Text)
-> (Maybe (Maybe Text) -> Maybe Text) -> Maybe Text
forall a b. a -> (a -> b) -> b
|> (Maybe Text -> Maybe Text) -> Maybe (Maybe Text) -> Maybe Text
forall a b. (a -> Maybe b) -> Maybe a -> Maybe b
Maybe.andThen Maybe Text -> Maybe Text
forall a. a -> a
identity

deriveSampleRate :: Platform.TracingSpan -> Settings -> Float
deriveSampleRate :: TracingSpan -> Settings -> Float
deriveSampleRate TracingSpan
rootSpan Settings
settings =
  let isNonAppRequestPath :: Bool
isNonAppRequestPath =
        case TracingSpan -> Maybe Text
getRootSpanRequestPath TracingSpan
rootSpan of
          Maybe Text
Nothing -> Bool
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 Text
requestPath -> (Text -> Bool) -> List Text -> Bool
forall a. (a -> Bool) -> List a -> Bool
List.any (Text
requestPath Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
==) [Text
"/health/readiness", Text
"/metrics", Text
"/health/liveness"]
      baseRate :: Float
baseRate = Settings -> Float -> TracingSpan -> Float
modifyFractionOfSuccessRequestsLogged Settings
settings (Settings -> Float
fractionOfSuccessRequestsLogged Settings
settings) TracingSpan
rootSpan
      requestDurationMs :: Float
requestDurationMs =
        MonotonicTime -> MonotonicTime -> MonotonicTime
Timer.difference (TracingSpan -> MonotonicTime
Platform.started TracingSpan
rootSpan) (TracingSpan -> MonotonicTime
Platform.finished TracingSpan
rootSpan)
          MonotonicTime -> (MonotonicTime -> Word64) -> Word64
forall a b. a -> (a -> b) -> b
|> MonotonicTime -> Word64
Platform.inMicroseconds
          Word64 -> (Word64 -> Float) -> Float
forall a b. a -> (a -> b) -> b
|> Word64 -> Float
forall a b. (Integral a, Num b) => a -> b
Prelude.fromIntegral
          Float -> (Float -> Float) -> Float
forall a b. a -> (a -> b) -> b
|> Float -> Float -> Float
forall number. Num number => number -> number -> number
(*) Float
1e-3
      apdexTMs :: Float
apdexTMs =
        Settings -> Int -> TracingSpan -> Int
modifyApdexTimeMs Settings
settings (Settings -> Int
apdexTimeMs Settings
settings) TracingSpan
rootSpan
          Int -> (Int -> Float) -> Float
forall a b. a -> (a -> b) -> b
|> Int -> Float
forall a b. (Integral a, Num b) => a -> b
Prelude.fromIntegral
   in if Bool
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.
          Float
baseRate Float -> Float -> Float
/ Float
500
        else Float -> Float -> Float -> Float
sampleRateForDuration Float
baseRate Float
requestDurationMs Float
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 :: Float -> Float -> Float -> Float
sampleRateForDuration Float
baseRate Float
requestDurationMs Float
apdexTMs =
  Float
baseRate Float -> Float -> Float
forall number. Num number => number -> number -> number
* (Float
1.5 Float -> Float -> Float
^ (Float
requestDurationMs Float -> Float -> Float
/ Float
apdexTMs))
    Float -> (Float -> Float) -> Float
forall a b. a -> (a -> b) -> b
|> Float -> Float -> Float -> Float
forall number. Ord number => number -> number -> number -> number
clamp Float
baseRate Float
1

calculateApdex :: Settings -> Platform.TracingSpan -> Float
calculateApdex :: Settings -> TracingSpan -> Float
calculateApdex Settings
settings TracingSpan
span =
  case TracingSpan -> Succeeded
Platform.succeeded TracingSpan
span of
    Succeeded
Platform.Failed -> Float
0
    Platform.FailedWith SomeException
_ -> Float
0
    Succeeded
Platform.Succeeded ->
      let duration :: Int
duration =
            TracingSpan -> MonotonicTime
spanDuration TracingSpan
span
              MonotonicTime -> (MonotonicTime -> Word64) -> Word64
forall a b. a -> (a -> b) -> b
|> MonotonicTime -> Word64
Platform.inMicroseconds
              Word64 -> (Word64 -> Int) -> Int
forall a b. a -> (a -> b) -> b
|> Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
Prelude.fromIntegral
          apdexTUs :: Int
apdexTUs = Int
1000 Int -> Int -> Int
forall number. Num number => number -> number -> number
* Settings -> Int
apdexTimeMs Settings
settings
       in if Int
duration Int -> Int -> Bool
forall comparable.
Ord comparable =>
comparable -> comparable -> Bool
< Int
apdexTUs
            then Float
1
            else
              if Int
duration Int -> Int -> Bool
forall comparable.
Ord comparable =>
comparable -> comparable -> Bool
< (Int
4 Int -> Int -> Int
forall number. Num number => number -> number -> number
* Int
apdexTUs)
                then Float
0.5
                else Float
0

toBatchEvents :: SharedTraceData -> Platform.TracingSpan -> List BatchEvent
toBatchEvents :: SharedTraceData -> TracingSpan -> List BatchEvent
toBatchEvents SharedTraceData
sharedTraceData TracingSpan
span =
  let ((StatsByName, Int)
_, List BatchEvent
events) =
        SharedTraceData
-> Maybe SpanId
-> (StatsByName, Int)
-> TracingSpan
-> ((StatsByName, Int), List BatchEvent)
batchEventsHelper
          SharedTraceData
sharedTraceData
          Maybe SpanId
forall a. Maybe a
Nothing
          (StatsByName
emptyStatsByName, Int
0)
          TracingSpan
span
   in List BatchEvent
events

batchEventsHelper ::
  SharedTraceData ->
  Maybe SpanId ->
  (StatsByName, Int) ->
  Platform.TracingSpan ->
  ((StatsByName, Int), [BatchEvent])
batchEventsHelper :: SharedTraceData
-> Maybe SpanId
-> (StatsByName, Int)
-> TracingSpan
-> ((StatsByName, Int), List BatchEvent)
batchEventsHelper SharedTraceData
sharedTraceData Maybe SpanId
parentSpanId (StatsByName
statsByName, Int
spanIndex) TracingSpan
span = do
  let isRootSpan :: Bool
isRootSpan = Maybe SpanId
parentSpanId Maybe SpanId -> Maybe SpanId -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe SpanId
forall a. Maybe a
Nothing
  let thisSpansId :: SpanId
thisSpansId = Text -> SpanId
SpanId (SharedTraceData -> Text
requestId SharedTraceData
sharedTraceData Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
"-" Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Int -> Text
NriText.fromInt Int
spanIndex)
  let ((StatsByName
lastStatsByName, Int
lastSpanIndex), [List BatchEvent]
nestedChildren) =
        ((StatsByName, Int)
 -> TracingSpan -> ((StatsByName, Int), List BatchEvent))
-> (StatsByName, Int)
-> [TracingSpan]
-> ((StatsByName, Int), [List BatchEvent])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
Data.List.mapAccumL
          (SharedTraceData
-> Maybe SpanId
-> (StatsByName, Int)
-> TracingSpan
-> ((StatsByName, Int), List BatchEvent)
batchEventsHelper SharedTraceData
sharedTraceData (SpanId -> Maybe SpanId
forall a. a -> Maybe a
Just SpanId
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 Bool
isRootSpan
              then StatsByName
statsByName
              else TracingSpan -> StatsByName -> StatsByName
recordStats TracingSpan
span StatsByName
statsByName,
            Int
spanIndex Int -> Int -> Int
forall number. Num number => number -> number -> number
+ Int
1
          )
          (TracingSpan -> [TracingSpan]
Platform.children TracingSpan
span)
  let children :: List BatchEvent
children = [List BatchEvent] -> List BatchEvent
forall a. List (List a) -> List a
List.concat [List BatchEvent]
nestedChildren
  let duration :: Word64
duration =
        MonotonicTime -> MonotonicTime -> MonotonicTime
Timer.difference (TracingSpan -> MonotonicTime
Platform.started TracingSpan
span) (TracingSpan -> MonotonicTime
Platform.finished TracingSpan
span)
          MonotonicTime -> (MonotonicTime -> Word64) -> Word64
forall a b. a -> (a -> b) -> b
|> MonotonicTime -> Word64
Platform.inMicroseconds
  let timestamp :: Text
timestamp = Timer -> MonotonicTime -> Text
Timer.toISO8601 (SharedTraceData -> Timer
timer SharedTraceData
sharedTraceData) (TracingSpan -> MonotonicTime
Platform.started TracingSpan
span)
  let sourceLocation :: Maybe Text
sourceLocation =
        TracingSpan -> Maybe (Text, SrcLoc)
Platform.frame TracingSpan
span
          Maybe (Text, SrcLoc)
-> (Maybe (Text, SrcLoc) -> Maybe Text) -> Maybe Text
forall a b. a -> (a -> b) -> b
|> ((Text, SrcLoc) -> Text) -> Maybe (Text, SrcLoc) -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
Maybe.map
            ( \(Text
_, SrcLoc
frame) ->
                List Char -> Text
Text.fromList (SrcLoc -> List Char
Stack.srcLocFile SrcLoc
frame)
                  Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
":"
                  Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Int -> Text
Text.fromInt (Int -> Int
forall a b. (Integral a, Num b) => a -> b
Prelude.fromIntegral (SrcLoc -> Int
Stack.srcLocStartLine SrcLoc
frame))
            )
  let isError :: Bool
isError = case TracingSpan -> Succeeded
Platform.succeeded TracingSpan
span of
        Succeeded
Platform.Succeeded -> Bool
False
        Succeeded
Platform.Failed -> Bool
True
        Platform.FailedWith SomeException
_ -> Bool
True
  let addStats :: Span -> Span
addStats Span
span' =
        if Bool
isRootSpan
          then StatsByName -> Span -> Span
perSpanNameStats StatsByName
lastStatsByName Span
span'
          else Span
span'
  let addEndpoint :: Span -> Span
addEndpoint Span
span' =
        case SharedTraceData -> Maybe Text
endpoint SharedTraceData
sharedTraceData of
          Maybe Text
Nothing -> Span
span'
          Just Text
endpoint -> Text -> Text -> Span -> Span
forall a. ToJSON a => Text -> a -> Span -> Span
addField Text
"endpoint" Text
endpoint Span
span'
  let hcSpan :: Span
hcSpan =
        SharedTraceData -> Span
initSpan SharedTraceData
sharedTraceData
          Span -> (Span -> Span) -> Span
forall a b. a -> (a -> b) -> b
|> Text -> Text -> Span -> Span
forall a. ToJSON a => Text -> a -> Span -> Span
addField Text
"name" (TracingSpan -> Text
Platform.name TracingSpan
span)
          Span -> (Span -> Span) -> Span
forall a b. a -> (a -> b) -> b
|> Text -> SpanId -> Span -> Span
forall a. ToJSON a => Text -> a -> Span -> Span
addField Text
"trace.span_id" SpanId
thisSpansId
          Span -> (Span -> Span) -> Span
forall a b. a -> (a -> b) -> b
|> Text -> Maybe SpanId -> Span -> Span
forall a. ToJSON a => Text -> a -> Span -> Span
addField Text
"trace.parent_id" Maybe SpanId
parentSpanId
          Span -> (Span -> Span) -> Span
forall a b. a -> (a -> b) -> b
|> Text -> Float -> Span -> Span
forall a. ToJSON a => Text -> a -> Span -> Span
addField Text
"duration_ms" (Word64 -> Float
forall a b. (Integral a, Num b) => a -> b
Prelude.fromIntegral Word64
duration Float -> Float -> Float
/ Float
1000)
          Span -> (Span -> Span) -> Span
forall a b. a -> (a -> b) -> b
|> Text -> Int -> Span -> Span
forall a. ToJSON a => Text -> a -> Span -> Span
addField Text
"allocated_bytes" (TracingSpan -> Int
Platform.allocated TracingSpan
span)
          Span -> (Span -> Span) -> Span
forall a b. a -> (a -> b) -> b
|> Text -> Bool -> Span -> Span
forall a. ToJSON a => Text -> a -> Span -> Span
addField Text
"failed" Bool
isError
          Span -> (Span -> Span) -> Span
forall a b. a -> (a -> b) -> b
|> Text -> Maybe Text -> Span -> Span
forall a. ToJSON a => Text -> a -> Span -> Span
addField Text
"source_location" Maybe Text
sourceLocation
          Span -> (Span -> Span) -> Span
forall a b. a -> (a -> b) -> b
|> TracingSpan -> Span -> Span
addDetails TracingSpan
span
          Span -> (Span -> Span) -> Span
forall a b. a -> (a -> b) -> b
|> Span -> Span
addEndpoint
          Span -> (Span -> Span) -> Span
forall a b. a -> (a -> b) -> b
|> Span -> Span
addStats
  ( (StatsByName
lastStatsByName, Int
lastSpanIndex),
    BatchEvent :: Text -> Span -> Int -> BatchEvent
BatchEvent
      { batchevent_time :: Text
batchevent_time = Text
timestamp,
        batchevent_data :: Span
batchevent_data = Span
hcSpan,
        batchevent_samplerate :: Int
batchevent_samplerate = SharedTraceData -> Int
sampleRate SharedTraceData
sharedTraceData
      } BatchEvent -> List BatchEvent -> List BatchEvent
forall a. a -> [a] -> [a]
:
    List BatchEvent
children
    )

data Stats = Stats
  { Stats -> Int
count :: Int,
    Stats -> Word64
totalTimeMicroseconds :: Data.Word.Word64
  }

newtype StatsByName = StatsByName (Dict.Dict Text Stats)

emptyStatsByName :: StatsByName
emptyStatsByName :: StatsByName
emptyStatsByName = Dict Text Stats -> StatsByName
StatsByName Dict Text Stats
forall k v. Dict k v
Dict.empty

recordStats :: Platform.TracingSpan -> StatsByName -> StatsByName
recordStats :: TracingSpan -> StatsByName -> StatsByName
recordStats TracingSpan
span (StatsByName Dict Text Stats
statsByName) =
  let name :: Text
name = TracingSpan -> Text
Platform.name TracingSpan
span
      duration :: Word64
duration = MonotonicTime -> Word64
Platform.inMicroseconds (TracingSpan -> MonotonicTime
spanDuration TracingSpan
span)
      newStats :: Stats
newStats =
        case Text -> Dict Text Stats -> Maybe Stats
forall comparable v.
Ord comparable =>
comparable -> Dict comparable v -> Maybe v
Dict.get Text
name Dict Text Stats
statsByName of
          Maybe Stats
Nothing ->
            Stats :: Int -> Word64 -> Stats
Stats
              { count :: Int
count = Int
1,
                totalTimeMicroseconds :: Word64
totalTimeMicroseconds = Word64
duration
              }
          Just Stats
stats ->
            Stats :: Int -> Word64 -> Stats
Stats
              { count :: Int
count = Int
1 Int -> Int -> Int
forall number. Num number => number -> number -> number
+ Stats -> Int
count Stats
stats,
                totalTimeMicroseconds :: Word64
totalTimeMicroseconds = Word64
duration Word64 -> Word64 -> Word64
forall number. Num number => number -> number -> number
+ Stats -> Word64
totalTimeMicroseconds Stats
stats
              }
   in Dict Text Stats -> StatsByName
StatsByName (Text -> Stats -> Dict Text Stats -> Dict Text Stats
forall comparable v.
Ord comparable =>
comparable -> v -> Dict comparable v -> Dict comparable v
Dict.insert Text
name Stats
newStats Dict Text Stats
statsByName)

spanDuration :: Platform.TracingSpan -> Platform.MonotonicTime
spanDuration :: TracingSpan -> MonotonicTime
spanDuration TracingSpan
span =
  MonotonicTime -> MonotonicTime -> MonotonicTime
Timer.difference (TracingSpan -> MonotonicTime
Platform.started TracingSpan
span) (TracingSpan -> MonotonicTime
Platform.finished TracingSpan
span)

perSpanNameStats :: StatsByName -> Span -> Span
perSpanNameStats :: StatsByName -> Span -> Span
perSpanNameStats (StatsByName Dict Text Stats
statsByName) Span
span =
  let -- chose foldr to preserve order, not super important tho
      statsForCategory :: (Text, Stats) -> Span -> Span
statsForCategory (Text
name, Stats
stats) Span
acc =
        let calls :: Int
calls = Stats -> Int
count Stats
stats
            total :: Float
total = Word64 -> Float
forall a b. (Integral a, Num b) => a -> b
Prelude.fromIntegral (Stats -> Word64
totalTimeMicroseconds Stats
stats) Float -> Float -> Float
/ Float
1000
            average :: Float
average = Float
total Float -> Float -> Float
/ Int -> Float
forall a b. (Integral a, Num b) => a -> b
Prelude.fromIntegral Int
calls
            saneName :: Text
saneName = Text -> Text
useAsKey Text
name
         in Span
acc
              Span -> (Span -> Span) -> Span
forall a b. a -> (a -> b) -> b
|> Text -> Float -> Span -> Span
forall a. ToJSON a => Text -> a -> Span -> Span
addField (Text
"stats.total_time_ms." Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
saneName) Float
total
              Span -> (Span -> Span) -> Span
forall a b. a -> (a -> b) -> b
|> Text -> Float -> Span -> Span
forall a. ToJSON a => Text -> a -> Span -> Span
addField (Text
"stats.average_time_ms." Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
saneName) Float
average
              Span -> (Span -> Span) -> Span
forall a b. a -> (a -> b) -> b
|> Text -> Int -> Span -> Span
forall a. ToJSON a => Text -> a -> Span -> Span
addField (Text
"stats.count." Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
saneName) Int
calls
   in ((Text, Stats) -> Span -> Span)
-> Span -> List (Text, Stats) -> Span
forall a b. (a -> b -> b) -> b -> List a -> b
List.foldl (Text, Stats) -> Span -> Span
statsForCategory Span
span (Dict Text Stats -> List (Text, Stats)
forall k v. Dict k v -> List (k, v)
Dict.toList Dict Text Stats
statsByName)

useAsKey :: Text -> Text
useAsKey :: Text -> Text
useAsKey Text
str =
  Text
str
    Text -> (Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
|> Text -> Text
NriText.toLower
    Text -> (Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
|> Text -> Text -> Text -> Text
NriText.replace Text
" " Text
"_"

-- 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 -> Span -> Span
addDetails TracingSpan
tracingSpan Span
honeycombSpan =
  case TracingSpan -> Maybe SomeTracingSpanDetails
Platform.details TracingSpan
tracingSpan of
    Just SomeTracingSpanDetails
details ->
      SomeTracingSpanDetails
details
        SomeTracingSpanDetails
-> (SomeTracingSpanDetails -> Maybe Span) -> Maybe Span
forall a b. a -> (a -> b) -> b
|> [Renderer Span] -> SomeTracingSpanDetails -> Maybe Span
forall a. [Renderer a] -> SomeTracingSpanDetails -> Maybe a
Platform.renderTracingSpanDetails
          [ (LogContexts -> Span) -> Renderer Span
forall s a. TracingSpanDetails s => (s -> a) -> Renderer a
Platform.Renderer (Span -> LogContexts -> Span
renderDetailsLog Span
honeycombSpan),
            (Details -> Span) -> Renderer Span
forall s a. TracingSpanDetails s => (s -> a) -> Renderer a
Platform.Renderer (Span -> Details -> Span
renderDetailsRedis Span
honeycombSpan),
            (Incoming -> Span) -> Renderer Span
forall s a. TracingSpanDetails s => (s -> a) -> Renderer a
Platform.Renderer
              ( \(Incoming
_ :: HttpRequest.Incoming) ->
                  Text -> SomeTracingSpanDetails -> Span -> Span
renderDetailsGeneric Text
"http" SomeTracingSpanDetails
details Span
honeycombSpan
              ),
            (Details -> Span) -> Renderer Span
forall s a. TracingSpanDetails s => (s -> a) -> Renderer a
Platform.Renderer
              ( \(Details
_ :: SqlQuery.Details) ->
                  Text -> SomeTracingSpanDetails -> Span -> Span
renderDetailsGeneric Text
"sql" SomeTracingSpanDetails
details Span
honeycombSpan
              ),
            (Details -> Span) -> Renderer Span
forall s a. TracingSpanDetails s => (s -> a) -> Renderer a
Platform.Renderer
              ( \(Details
_ :: Kafka.Details) ->
                  Text -> SomeTracingSpanDetails -> Span -> Span
renderDetailsGeneric Text
"kafka" SomeTracingSpanDetails
details Span
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 Span -> (Maybe Span -> Span) -> Span
forall a b. a -> (a -> b) -> b
|> Span -> Maybe Span -> Span
forall a. a -> Maybe a -> a
Maybe.withDefault
          (Text -> SomeTracingSpanDetails -> Span -> Span
renderDetailsGeneric (TracingSpan -> Text
Platform.name TracingSpan
tracingSpan) SomeTracingSpanDetails
details Span
honeycombSpan)
    Maybe SomeTracingSpanDetails
Nothing -> Span
honeycombSpan

renderDetailsGeneric :: Text -> Platform.SomeTracingSpanDetails -> Span -> Span
renderDetailsGeneric :: Text -> SomeTracingSpanDetails -> Span -> Span
renderDetailsGeneric Text
keyPrefix SomeTracingSpanDetails
details Span
honeycombSpan =
  case SomeTracingSpanDetails -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON SomeTracingSpanDetails
details of
    Aeson.Object Object
object ->
      (Text -> Value -> Span -> Span) -> Span -> Object -> Span
forall acc. (Text -> Value -> acc -> acc) -> acc -> Object -> acc
AesonHelpers.foldObject
        (\Text
key Value
value -> Text -> Value -> Span -> Span
forall a. ToJSON a => Text -> a -> Span -> Span
addField (Text -> Text
useAsKey (Text
keyPrefix Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
"." Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
key)) Value
value)
        Span
honeycombSpan
        Object
object
    Value
jsonVal -> Text -> Value -> Span -> Span
forall a. ToJSON a => Text -> a -> Span -> Span
addField Text
keyPrefix Value
jsonVal Span
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 -> LogContexts -> Span
renderDetailsLog Span
span context :: LogContexts
context@(Log.LogContexts [Context]
contexts) =
  if [Context] -> Int
forall a. List a -> Int
List.length [Context]
contexts Int -> Int -> Bool
forall comparable.
Ord comparable =>
comparable -> comparable -> Bool
> Int
5
    then Text -> LogContexts -> Span -> Span
forall a. ToJSON a => Text -> a -> Span -> Span
addField Text
"log.context" LogContexts
context Span
span
    else
      (Context -> Span -> Span) -> Span -> [Context] -> Span
forall a b. (a -> b -> b) -> b -> List a -> b
List.foldl
        (\(Log.Context Text
key a
val) -> Text -> a -> Span -> Span
forall a. ToJSON a => Text -> a -> Span -> Span
addField (Text
"log." Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
key) a
val)
        Span
span
        [Context]
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 -> Details -> Span
renderDetailsRedis Span
span Details
redisInfo =
  let addCommandCounts :: Span -> Span
addCommandCounts Span
span' =
        Details
redisInfo
          Details -> (Details -> List Text) -> List Text
forall a b. a -> (a -> b) -> b
|> Details -> List Text
RedisCommands.commands
          List Text -> (List Text -> List Text) -> List Text
forall a b. a -> (a -> b) -> b
|> (Text -> Maybe Text) -> List Text -> List Text
forall a b. (a -> Maybe b) -> List a -> List b
List.filterMap (Text -> List Text
NriText.words (Text -> List Text)
-> (List Text -> Maybe Text) -> Text -> Maybe Text
forall a b c. (a -> b) -> (b -> c) -> a -> c
>> List Text -> Maybe Text
forall a. List a -> Maybe a
List.head)
          List Text -> (List Text -> [NonEmpty Text]) -> [NonEmpty Text]
forall a b. a -> (a -> b) -> b
|> (Text -> Text) -> List Text -> [NonEmpty Text]
forall (f :: * -> *) b a.
(Foldable f, Eq b) =>
(a -> b) -> f a -> [NonEmpty a]
NonEmpty.groupWith Text -> Text
forall a. a -> a
identity
          [NonEmpty Text] -> ([NonEmpty Text] -> Span) -> Span
forall a b. a -> (a -> b) -> b
|> (NonEmpty Text -> Span -> Span) -> Span -> [NonEmpty Text] -> Span
forall a b. (a -> b -> b) -> b -> List a -> b
List.foldr
            ( \NonEmpty Text
xs ->
                Text -> Int -> Span -> Span
forall a. ToJSON a => Text -> a -> Span -> Span
addField
                  (Text
"redis." Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ NonEmpty Text -> Text
forall a. NonEmpty a -> a
NonEmpty.head NonEmpty Text
xs Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
".count")
                  (NonEmpty Text -> Int
forall a. NonEmpty a -> Int
NonEmpty.length NonEmpty Text
xs)
            )
            Span
span'
      fullBlob :: Value
fullBlob =
        Details
redisInfo
          Details -> (Details -> List Text) -> List Text
forall a b. a -> (a -> b) -> b
|> Details -> List Text
RedisCommands.commands
          List Text -> (List Text -> Value) -> Value
forall a b. a -> (a -> b) -> b
|> List Text -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON
   in Span
span
        Span -> (Span -> Span) -> Span
forall a b. a -> (a -> b) -> b
|> Text -> Value -> Span -> Span
forall a. ToJSON a => Text -> a -> Span -> Span
addField Text
"redis.commands" Value
fullBlob
        Span -> (Span -> Span) -> Span
forall a b. a -> (a -> b) -> b
|> Text -> Maybe Text -> Span -> Span
forall a. ToJSON a => Text -> a -> Span -> Span
addField Text
"redis.host" (Details -> Maybe Text
RedisCommands.host Details
redisInfo)
        Span -> (Span -> Span) -> Span
forall a b. a -> (a -> b) -> b
|> Text -> Maybe Int -> Span -> Span
forall a. ToJSON a => Text -> a -> Span -> Span
addField Text
"redis.port" (Details -> Maybe Int
RedisCommands.port Details
redisInfo)
        Span -> (Span -> Span) -> Span
forall a b. a -> (a -> b) -> b
|> Span -> Span
addCommandCounts

data BatchEvent = BatchEvent
  { BatchEvent -> Text
batchevent_time :: Text,
    BatchEvent -> Span
batchevent_data :: Span,
    BatchEvent -> Int
batchevent_samplerate :: Int
  }
  deriving ((forall x. BatchEvent -> Rep BatchEvent x)
-> (forall x. Rep BatchEvent x -> BatchEvent) -> Generic BatchEvent
forall x. Rep BatchEvent x -> BatchEvent
forall x. BatchEvent -> Rep BatchEvent x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep BatchEvent x -> BatchEvent
$cfrom :: forall x. BatchEvent -> Rep BatchEvent x
Generic, Int -> BatchEvent -> ShowS
List BatchEvent -> ShowS
BatchEvent -> List Char
(Int -> BatchEvent -> ShowS)
-> (BatchEvent -> List Char)
-> (List BatchEvent -> ShowS)
-> Show BatchEvent
forall a.
(Int -> a -> ShowS) -> (a -> List Char) -> ([a] -> ShowS) -> Show a
showList :: List BatchEvent -> ShowS
$cshowList :: List BatchEvent -> ShowS
show :: BatchEvent -> List Char
$cshow :: BatchEvent -> List Char
showsPrec :: Int -> BatchEvent -> ShowS
$cshowsPrec :: Int -> BatchEvent -> ShowS
Show)

options :: Aeson.Options
options :: Options
options =
  Options
Aeson.defaultOptions
    { -- Drop the batchevent_ prefix
      fieldLabelModifier :: ShowS
Aeson.fieldLabelModifier = Int -> ShowS
forall a. Int -> List a -> List a
List.drop Int
1 ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
<< (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
Prelude.dropWhile (Char
'_' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=)
    }

instance Aeson.ToJSON BatchEvent where
  toJSON :: BatchEvent -> Value
toJSON = Options -> BatchEvent -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
Aeson.genericToJSON Options
options

data SharedTraceData = SharedTraceData
  { -- | We use this to turn GHC.Clock-produced timestamps into regular times.
    SharedTraceData -> Timer
timer :: Timer.Timer,
    -- | Each request has a unique id, for correlating spans for the same request.
    SharedTraceData -> Text
requestId :: Text,
    -- | A honeycomb span with the common fields for this request pre-applied.
    SharedTraceData -> Span
initSpan :: Span,
    -- | The 'endpoint' of the request this trace describes. Honeycomb uses
    -- this for a breakdown-by-endpoint on the dataset home.
    SharedTraceData -> Maybe Text
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.
    SharedTraceData -> Int
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 ([Span] -> Encoding
[Span] -> Value
Span -> Encoding
Span -> Value
(Span -> Value)
-> (Span -> Encoding)
-> ([Span] -> Value)
-> ([Span] -> Encoding)
-> ToJSON Span
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [Span] -> Encoding
$ctoEncodingList :: [Span] -> Encoding
toJSONList :: [Span] -> Value
$ctoJSONList :: [Span] -> Value
toEncoding :: Span -> Encoding
$ctoEncoding :: Span -> Encoding
toJSON :: Span -> Value
$ctoJSON :: Span -> Value
Aeson.ToJSON, Int -> Span -> ShowS
[Span] -> ShowS
Span -> List Char
(Int -> Span -> ShowS)
-> (Span -> List Char) -> ([Span] -> ShowS) -> Show Span
forall a.
(Int -> a -> ShowS) -> (a -> List Char) -> ([a] -> ShowS) -> Show a
showList :: [Span] -> ShowS
$cshowList :: [Span] -> ShowS
show :: Span -> List Char
$cshow :: Span -> List Char
showsPrec :: Int -> Span -> ShowS
$cshowsPrec :: Int -> Span -> ShowS
Show)

data JsonEncodable where
  JsonEncodable :: Aeson.ToJSON a => a -> JsonEncodable

instance Aeson.ToJSON JsonEncodable where
  toEncoding :: JsonEncodable -> Encoding
toEncoding (JsonEncodable a
x) = a -> Encoding
forall a. ToJSON a => a -> Encoding
Aeson.toEncoding a
x
  toJSON :: JsonEncodable -> Value
toJSON (JsonEncodable a
x) = a -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON a
x

instance Show JsonEncodable where
  show :: JsonEncodable -> List Char
show (JsonEncodable a
x) = Value -> List Char
forall a. Show a => a -> List Char
Prelude.show (a -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON a
x)

emptySpan :: Span
emptySpan :: Span
emptySpan = Dict Text JsonEncodable -> Span
Span Dict Text JsonEncodable
forall k v. Dict k v
Dict.empty

addField :: Aeson.ToJSON a => Text -> a -> Span -> Span
addField :: Text -> a -> Span -> Span
addField Text
key a
val (Span Dict Text JsonEncodable
span) = Dict Text JsonEncodable -> Span
Span (Text
-> JsonEncodable
-> Dict Text JsonEncodable
-> Dict Text JsonEncodable
forall comparable v.
Ord comparable =>
comparable -> v -> Dict comparable v -> Dict comparable v
Dict.insert Text
key (a -> JsonEncodable
forall a. ToJSON a => a -> JsonEncodable
JsonEncodable a
val) Dict Text JsonEncodable
span)

newtype SpanId = SpanId Text
  deriving ([SpanId] -> Encoding
[SpanId] -> Value
SpanId -> Encoding
SpanId -> Value
(SpanId -> Value)
-> (SpanId -> Encoding)
-> ([SpanId] -> Value)
-> ([SpanId] -> Encoding)
-> ToJSON SpanId
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [SpanId] -> Encoding
$ctoEncodingList :: [SpanId] -> Encoding
toJSONList :: [SpanId] -> Value
$ctoJSONList :: [SpanId] -> Value
toEncoding :: SpanId -> Encoding
$ctoEncoding :: SpanId -> Encoding
toJSON :: SpanId -> Value
$ctoJSON :: SpanId -> Value
Aeson.ToJSON, SpanId -> SpanId -> Bool
(SpanId -> SpanId -> Bool)
-> (SpanId -> SpanId -> Bool) -> Eq SpanId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SpanId -> SpanId -> Bool
$c/= :: SpanId -> SpanId -> Bool
== :: SpanId -> SpanId -> Bool
$c== :: SpanId -> SpanId -> Bool
Eq, Int -> SpanId -> ShowS
[SpanId] -> ShowS
SpanId -> List Char
(Int -> SpanId -> ShowS)
-> (SpanId -> List Char) -> ([SpanId] -> ShowS) -> Show SpanId
forall a.
(Int -> a -> ShowS) -> (a -> List Char) -> ([a] -> ShowS) -> Show a
showList :: [SpanId] -> ShowS
$cshowList :: [SpanId] -> ShowS
show :: SpanId -> List Char
$cshow :: SpanId -> List Char
showsPrec :: Int -> SpanId -> ShowS
$cshowsPrec :: Int -> SpanId -> ShowS
Show)

-- | Contextual information this reporter needs to do its work. You can create
-- one using 'handler'.
data Handler = Handler
  { Handler -> Manager
http :: HTTP.Manager,
    Handler -> Settings
settings :: Settings,
    Handler -> TracingSpan -> IO SendOrSample
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 -> IO Handler
handler Settings
settings = do
  Timer
timer <- IO Timer
Timer.mkTimer
  Manager
http <- IO Manager
HTTP.TLS.getGlobalManager
  Revision
revision <- IO Revision
getRevision
  List Char
hostname' <- IO (List Char)
Network.HostName.getHostName
  let baseSpan :: Span
baseSpan =
        Span
emptySpan
          Span -> (Span -> Span) -> Span
forall a b. a -> (a -> b) -> b
|> Text -> Text -> Span -> Span
forall a. ToJSON a => Text -> a -> Span -> Span
addField Text
"service_name" (Settings -> Text
serviceName Settings
settings)
          Span -> (Span -> Span) -> Span
forall a b. a -> (a -> b) -> b
|> Text -> Text -> Span -> Span
forall a. ToJSON a => Text -> a -> Span -> Span
addField Text
"hostname" (List Char -> Text
Text.fromList List Char
hostname')
          Span -> (Span -> Span) -> Span
forall a b. a -> (a -> b) -> b
|> Text -> Revision -> Span -> Span
forall a. ToJSON a => Text -> a -> Span -> Span
addField Text
"revision" Revision
revision
  Handler -> IO Handler
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure
    Handler :: Manager -> Settings -> (TracingSpan -> IO SendOrSample) -> Handler
Handler
      { http :: Manager
http = Manager
http,
        settings :: Settings
settings = Settings
settings,
        makeSharedTraceData :: TracingSpan -> IO SendOrSample
makeSharedTraceData = \TracingSpan
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

          (Bool
skipLogging, Int
sampleRate) <-
            case TracingSpan -> Succeeded
Platform.succeeded TracingSpan
span of
              Succeeded
Platform.Succeeded -> do
                let probability :: Float
probability = TracingSpan -> Settings -> Float
deriveSampleRate TracingSpan
span Settings
settings
                Float
roll <- (Float, Float) -> IO Float
forall a (m :: * -> *). (Random a, MonadIO m) => (a, a) -> m a
Random.randomRIO (Float
0.0, Float
1.0)
                (Bool, Int) -> IO (Bool, Int)
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure (Float
roll Float -> Float -> Bool
forall comparable.
Ord comparable =>
comparable -> comparable -> Bool
> Float
probability, Float -> Int
round (Float
1 Float -> Float -> Float
/ Float
probability))
              Succeeded
Platform.Failed -> (Bool, Int) -> IO (Bool, Int)
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure (Bool
False, Int
1)
              Platform.FailedWith SomeException
_ -> (Bool, Int) -> IO (Bool, Int)
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure (Bool
False, Int
1)
          UUID
uuid <- IO UUID
Data.UUID.V4.nextRandom
          if Bool
skipLogging
            then SendOrSample -> IO SendOrSample
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure SendOrSample
SampledOut
            else
              SendOrSample -> IO SendOrSample
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure
                (SendOrSample -> IO SendOrSample)
-> SendOrSample -> IO SendOrSample
forall a b. (a -> b) -> a -> b
<| SharedTraceData -> SendOrSample
SendToHoneycomb
                  SharedTraceData :: Timer -> Text -> Span -> Maybe Text -> Int -> SharedTraceData
SharedTraceData
                    { Timer
timer :: Timer
timer :: Timer
timer,
                      Int
sampleRate :: Int
sampleRate :: Int
sampleRate,
                      requestId :: Text
requestId = UUID -> Text
Data.UUID.toText UUID
uuid,
                      endpoint :: Maybe Text
endpoint = TracingSpan -> Maybe Text
getSpanEndpoint TracingSpan
span,
                      initSpan :: Span
initSpan =
                        Span
baseSpan
                          Span -> (Span -> Span) -> Span
forall a b. a -> (a -> b) -> b
|> Text -> Float -> Span -> Span
forall a. ToJSON a => Text -> a -> Span -> Span
addField Text
"apdex" (Settings -> TracingSpan -> Float
calculateApdex Settings
settings TracingSpan
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
                          Span -> (Span -> Span) -> Span
forall a b. a -> (a -> b) -> b
|> Text -> Text -> Span -> Span
forall a. ToJSON a => Text -> a -> Span -> Span
addField Text
"trace.trace_id" (UUID -> Text
Data.UUID.toText UUID
uuid)
                    }
      }

newtype Revision = Revision Text
  deriving (Int -> Revision -> ShowS
[Revision] -> ShowS
Revision -> List Char
(Int -> Revision -> ShowS)
-> (Revision -> List Char)
-> ([Revision] -> ShowS)
-> Show Revision
forall a.
(Int -> a -> ShowS) -> (a -> List Char) -> ([a] -> ShowS) -> Show a
showList :: [Revision] -> ShowS
$cshowList :: [Revision] -> ShowS
show :: Revision -> List Char
$cshow :: Revision -> List Char
showsPrec :: Int -> Revision -> ShowS
$cshowsPrec :: Int -> Revision -> ShowS
Show, [Revision] -> Encoding
[Revision] -> Value
Revision -> Encoding
Revision -> Value
(Revision -> Value)
-> (Revision -> Encoding)
-> ([Revision] -> Value)
-> ([Revision] -> Encoding)
-> ToJSON Revision
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [Revision] -> Encoding
$ctoEncodingList :: [Revision] -> Encoding
toJSONList :: [Revision] -> Value
$ctoJSONList :: [Revision] -> Value
toEncoding :: Revision -> Encoding
$ctoEncoding :: Revision -> Encoding
toJSON :: Revision -> Value
$ctoJSON :: Revision -> Value
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 :: IO Revision
getRevision = do
  Either SomeException Text
eitherRevision <- IO Text -> IO (Either SomeException Text)
forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either SomeException a)
Exception.tryAny (IO Text -> IO (Either SomeException Text))
-> IO Text -> IO (Either SomeException Text)
forall a b. (a -> b) -> a -> b
<| List Char -> IO Text
Data.Text.IO.readFile List Char
"revision"
  case Either SomeException Text
eitherRevision of
    Prelude.Left SomeException
_err -> Revision -> IO Revision
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure (Text -> Revision
Revision Text
"no revision file found")
    Prelude.Right Text
version -> Revision -> IO Revision
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure (Text -> Revision
Revision Text
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.
    Settings -> Secret Method
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@] *****
    Settings -> Text
datasetName :: Text,
    -- | The name of the service we're reporting for.
    --
    -- [@environment variable@] HONEYCOMB_SERVICE_NAME
    -- [@default value@] service
    Settings -> Text
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
    Settings -> Float
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
    Settings -> Int
apdexTimeMs :: Int,
    -- | Allows overriding the default sample rates for given spans.
    -- This allows us to change the sample rate for certain endpoints within an
    -- application, for example if a path is critical but low volume we may choose
    -- to increase the rate.
    -- [@default value@] the input float
    Settings -> Float -> TracingSpan -> Float
modifyFractionOfSuccessRequestsLogged :: Float -> Platform.TracingSpan -> Float,
    -- | Allows overriding the default apdex rates for given spans.
    -- This allows us to change the apdex for certain endpoints within an
    -- application, for example if a path is significantly lower volume than
    -- another the apdex may require tuning.
    -- [@default value@] the input int
    Settings -> Int -> TracingSpan -> Int
modifyApdexTimeMs :: Int -> Platform.TracingSpan -> 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 :: Decoder Settings
decoder =
  (Secret Method
 -> Text
 -> Text
 -> Float
 -> Int
 -> (Float -> TracingSpan -> Float)
 -> (Int -> TracingSpan -> Int)
 -> Settings)
-> Decoder
     (Secret Method
      -> Text
      -> Text
      -> Float
      -> Int
      -> (Float -> TracingSpan -> Float)
      -> (Int -> TracingSpan -> Int)
      -> Settings)
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure Secret Method
-> Text
-> Text
-> Float
-> Int
-> (Float -> TracingSpan -> Float)
-> (Int -> TracingSpan -> Int)
-> Settings
Settings
    Decoder
  (Secret Method
   -> Text
   -> Text
   -> Float
   -> Int
   -> (Float -> TracingSpan -> Float)
   -> (Int -> TracingSpan -> Int)
   -> Settings)
-> (Decoder
      (Secret Method
       -> Text
       -> Text
       -> Float
       -> Int
       -> (Float -> TracingSpan -> Float)
       -> (Int -> TracingSpan -> Int)
       -> Settings)
    -> Decoder
         (Text
          -> Text
          -> Float
          -> Int
          -> (Float -> TracingSpan -> Float)
          -> (Int -> TracingSpan -> Int)
          -> Settings))
-> Decoder
     (Text
      -> Text
      -> Float
      -> Int
      -> (Float -> TracingSpan -> Float)
      -> (Int -> TracingSpan -> Int)
      -> Settings)
forall a b. a -> (a -> b) -> b
|> Decoder (Secret Method)
-> Decoder
     (Secret Method
      -> Text
      -> Text
      -> Float
      -> Int
      -> (Float -> TracingSpan -> Float)
      -> (Int -> TracingSpan -> Int)
      -> Settings)
-> Decoder
     (Text
      -> Text
      -> Float
      -> Int
      -> (Float -> TracingSpan -> Float)
      -> (Int -> TracingSpan -> Int)
      -> Settings)
forall (m :: * -> *) a b. Applicative m => m a -> m (a -> b) -> m b
andMap Decoder (Secret Method)
honeycombApiKeyDecoder
    Decoder
  (Text
   -> Text
   -> Float
   -> Int
   -> (Float -> TracingSpan -> Float)
   -> (Int -> TracingSpan -> Int)
   -> Settings)
-> (Decoder
      (Text
       -> Text
       -> Float
       -> Int
       -> (Float -> TracingSpan -> Float)
       -> (Int -> TracingSpan -> Int)
       -> Settings)
    -> Decoder
         (Text
          -> Float
          -> Int
          -> (Float -> TracingSpan -> Float)
          -> (Int -> TracingSpan -> Int)
          -> Settings))
-> Decoder
     (Text
      -> Float
      -> Int
      -> (Float -> TracingSpan -> Float)
      -> (Int -> TracingSpan -> Int)
      -> Settings)
forall a b. a -> (a -> b) -> b
|> Decoder Text
-> Decoder
     (Text
      -> Text
      -> Float
      -> Int
      -> (Float -> TracingSpan -> Float)
      -> (Int -> TracingSpan -> Int)
      -> Settings)
-> Decoder
     (Text
      -> Float
      -> Int
      -> (Float -> TracingSpan -> Float)
      -> (Int -> TracingSpan -> Int)
      -> Settings)
forall (m :: * -> *) a b. Applicative m => m a -> m (a -> b) -> m b
andMap Decoder Text
datasetNameDecoder
    Decoder
  (Text
   -> Float
   -> Int
   -> (Float -> TracingSpan -> Float)
   -> (Int -> TracingSpan -> Int)
   -> Settings)
-> (Decoder
      (Text
       -> Float
       -> Int
       -> (Float -> TracingSpan -> Float)
       -> (Int -> TracingSpan -> Int)
       -> Settings)
    -> Decoder
         (Float
          -> Int
          -> (Float -> TracingSpan -> Float)
          -> (Int -> TracingSpan -> Int)
          -> Settings))
-> Decoder
     (Float
      -> Int
      -> (Float -> TracingSpan -> Float)
      -> (Int -> TracingSpan -> Int)
      -> Settings)
forall a b. a -> (a -> b) -> b
|> Decoder Text
-> Decoder
     (Text
      -> Float
      -> Int
      -> (Float -> TracingSpan -> Float)
      -> (Int -> TracingSpan -> Int)
      -> Settings)
-> Decoder
     (Float
      -> Int
      -> (Float -> TracingSpan -> Float)
      -> (Int -> TracingSpan -> Int)
      -> Settings)
forall (m :: * -> *) a b. Applicative m => m a -> m (a -> b) -> m b
andMap Decoder Text
honeycombAppNameDecoder
    Decoder
  (Float
   -> Int
   -> (Float -> TracingSpan -> Float)
   -> (Int -> TracingSpan -> Int)
   -> Settings)
-> (Decoder
      (Float
       -> Int
       -> (Float -> TracingSpan -> Float)
       -> (Int -> TracingSpan -> Int)
       -> Settings)
    -> Decoder
         (Int
          -> (Float -> TracingSpan -> Float)
          -> (Int -> TracingSpan -> Int)
          -> Settings))
-> Decoder
     (Int
      -> (Float -> TracingSpan -> Float)
      -> (Int -> TracingSpan -> Int)
      -> Settings)
forall a b. a -> (a -> b) -> b
|> Decoder Float
-> Decoder
     (Float
      -> Int
      -> (Float -> TracingSpan -> Float)
      -> (Int -> TracingSpan -> Int)
      -> Settings)
-> Decoder
     (Int
      -> (Float -> TracingSpan -> Float)
      -> (Int -> TracingSpan -> Int)
      -> Settings)
forall (m :: * -> *) a b. Applicative m => m a -> m (a -> b) -> m b
andMap Decoder Float
fractionOfSuccessRequestsLoggedDecoder
    Decoder
  (Int
   -> (Float -> TracingSpan -> Float)
   -> (Int -> TracingSpan -> Int)
   -> Settings)
-> (Decoder
      (Int
       -> (Float -> TracingSpan -> Float)
       -> (Int -> TracingSpan -> Int)
       -> Settings)
    -> Decoder
         ((Float -> TracingSpan -> Float)
          -> (Int -> TracingSpan -> Int) -> Settings))
-> Decoder
     ((Float -> TracingSpan -> Float)
      -> (Int -> TracingSpan -> Int) -> Settings)
forall a b. a -> (a -> b) -> b
|> Decoder Int
-> Decoder
     (Int
      -> (Float -> TracingSpan -> Float)
      -> (Int -> TracingSpan -> Int)
      -> Settings)
-> Decoder
     ((Float -> TracingSpan -> Float)
      -> (Int -> TracingSpan -> Int) -> Settings)
forall (m :: * -> *) a b. Applicative m => m a -> m (a -> b) -> m b
andMap Decoder Int
apdexTimeMsDecoder
    Decoder
  ((Float -> TracingSpan -> Float)
   -> (Int -> TracingSpan -> Int) -> Settings)
-> (Decoder
      ((Float -> TracingSpan -> Float)
       -> (Int -> TracingSpan -> Int) -> Settings)
    -> Decoder ((Int -> TracingSpan -> Int) -> Settings))
-> Decoder ((Int -> TracingSpan -> Int) -> Settings)
forall a b. a -> (a -> b) -> b
|> Decoder (Float -> TracingSpan -> Float)
-> Decoder
     ((Float -> TracingSpan -> Float)
      -> (Int -> TracingSpan -> Int) -> Settings)
-> Decoder ((Int -> TracingSpan -> Int) -> Settings)
forall (m :: * -> *) a b. Applicative m => m a -> m (a -> b) -> m b
andMap ((Float -> TracingSpan -> Float)
-> Decoder (Float -> TracingSpan -> Float)
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure Float -> TracingSpan -> Float
forall a b. a -> b -> a
always)
    Decoder ((Int -> TracingSpan -> Int) -> Settings)
-> (Decoder ((Int -> TracingSpan -> Int) -> Settings)
    -> Decoder Settings)
-> Decoder Settings
forall a b. a -> (a -> b) -> b
|> Decoder (Int -> TracingSpan -> Int)
-> Decoder ((Int -> TracingSpan -> Int) -> Settings)
-> Decoder Settings
forall (m :: * -> *) a b. Applicative m => m a -> m (a -> b) -> m b
andMap ((Int -> TracingSpan -> Int) -> Decoder (Int -> TracingSpan -> Int)
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure Int -> TracingSpan -> Int
forall a b. a -> b -> a
always)

honeycombApiKeyDecoder :: Environment.Decoder (Log.Secret ByteString.ByteString)
honeycombApiKeyDecoder :: Decoder (Secret Method)
honeycombApiKeyDecoder =
  Variable -> Parser (Secret Method) -> Decoder (Secret Method)
forall a. Variable -> Parser a -> Decoder a
Environment.variable
    Variable :: Text -> Text -> Text -> Variable
Environment.Variable
      { name :: Text
Environment.name = Text
"HONEYCOMB_API_KEY",
        description :: Text
Environment.description = Text
"The API key for Honeycomb",
        defaultValue :: Text
Environment.defaultValue = Text
"*****"
      }
    (Parser Text
Environment.text Parser Text -> (Parser Text -> Parser Method) -> Parser Method
forall a b. a -> (a -> b) -> b
|> (Text -> Method) -> Parser Text -> Parser Method
forall (m :: * -> *) a value.
Functor m =>
(a -> value) -> m a -> m value
map Text -> Method
Encoding.encodeUtf8 Parser Method
-> (Parser Method -> Parser (Secret Method))
-> Parser (Secret Method)
forall a b. a -> (a -> b) -> b
|> Parser Method -> Parser (Secret Method)
forall a. Parser a -> Parser (Secret a)
Environment.secret)

datasetNameDecoder :: Environment.Decoder Text
datasetNameDecoder :: Decoder Text
datasetNameDecoder =
  Variable -> Parser Text -> Decoder Text
forall a. Variable -> Parser a -> Decoder a
Environment.variable
    Variable :: Text -> Text -> Text -> Variable
Environment.Variable
      { name :: Text
Environment.name = Text
"HONEYCOMB_DATASET",
        description :: Text
Environment.description = Text
"Name of the dataset honeycomb should log to.",
        defaultValue :: Text
Environment.defaultValue = Text
"dataset"
      }
    Parser Text
Environment.text

honeycombAppNameDecoder :: Environment.Decoder Text
honeycombAppNameDecoder :: Decoder Text
honeycombAppNameDecoder =
  Variable -> Parser Text -> Decoder Text
forall a. Variable -> Parser a -> Decoder a
Environment.variable
    Variable :: Text -> Text -> Text -> Variable
Environment.Variable
      { name :: Text
Environment.name = Text
"HONEYCOMB_SERVICE_NAME",
        description :: Text
Environment.description = Text
"Variable that sets the honeycomb service name.",
        defaultValue :: Text
Environment.defaultValue = Text
"service"
      }
    Parser Text
Environment.text

fractionOfSuccessRequestsLoggedDecoder :: Environment.Decoder Float
fractionOfSuccessRequestsLoggedDecoder :: Decoder Float
fractionOfSuccessRequestsLoggedDecoder =
  Variable -> Parser Float -> Decoder Float
forall a. Variable -> Parser a -> Decoder a
Environment.variable
    Variable :: Text -> Text -> Text -> Variable
Environment.Variable
      { name :: Text
Environment.name = Text
"HONEYCOMB_FRACTION_OF_SUCCESS_REQUESTS_LOGGED",
        description :: Text
Environment.description = Text
"The fraction of successful requests logged. Defaults to logging all successful requests.",
        defaultValue :: Text
Environment.defaultValue = Text
"1"
      }
    Parser Float
Environment.float

apdexTimeMsDecoder :: Environment.Decoder Int
apdexTimeMsDecoder :: Decoder Int
apdexTimeMsDecoder =
  Variable -> Parser Int -> Decoder Int
forall a. Variable -> Parser a -> Decoder a
Environment.variable
    Variable :: Text -> Text -> Text -> Variable
Environment.Variable
      { name :: Text
Environment.name = Text
"HONEYCOMB_APDEX_TIME_IN_MILLISECONDS",
        description :: Text
Environment.description = Text
"The T value in the apdex, the time in milliseconds in which a healthy request should complete.",
        defaultValue :: Text
Environment.defaultValue = Text
"100"
      }
    Parser Int
forall a. Integral a => Parser a
Environment.int