{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-unused-imports #-}

{- |
A exporter backend that sends telemetry in the form of traces of your
application's behaviour, or event data—accompanied either way by [conceivably
very wide] additional metadata—to the Honeycomb observability service.

When specifying the 'honeycombExporter' you have to specify certain
command-line options and environment variables to enable it:

@
\$ export HONEYCOMB_TEAM="62e3626a2cc34475adef4d799eca0407"
\$ burger-service --telemetry=honeycomb --dataset=prod-restaurant-001
@

If you annotate your program with spans, you can get a trace like this:

![Example Trace](HoneycombTraceExample.png)

/Notice/

This library is Open Source but the Honeycomb service is /not/. Honeycomb
offers a free tier which is quite suitable for individual use and small local
applications. You can also look at "Core.Telemetry.General" if you instead
want to forward to a generic OpenTelemetry provider. There's also
"Core.Telemetry.Console" which simply dumps telemetry to console.
-}
module Core.Telemetry.Honeycomb (
    Dataset,
    honeycombExporter,
) where

import Core.Data.Structures (Map, fromMap, insertKeyValue, intoMap, lookupKeyValue)
import Core.Encoding.Json
import Core.Program.Arguments
import Core.Program.Context
import Core.Program.Logging
import Core.System.Base (stdout)
import Core.System.External (TimeStamp (unTimeStamp), getCurrentTimeNanoseconds)
import Core.Text.Bytes
import Core.Text.Colour
import Core.Text.Rope
import Core.Text.Utilities
import Data.ByteString (ByteString)
import qualified Data.ByteString as B (ByteString)
import qualified Data.ByteString.Char8 as C (append, null, putStrLn)
import qualified Data.ByteString.Lazy as L (ByteString)
import Data.Fixed
import qualified Data.List as List
import Network.Http.Client
import System.Environment (lookupEnv)
import System.Exit (ExitCode (..))
import System.IO.Streams (InputStream)
import qualified System.Posix.Process as Posix (exitImmediately)

{- |
Indicate which \"dataset\" spans and events will be posted into
-}
type Dataset = Rope

type ApiKey = Rope

{- |
Configure your application to send telemetry in the form of spans and traces
to the Honeycomb observability service.

@
    context <- 'Core.Program.Execute.configure' ...
    context' <- 'Core.Telemetry.Observability.initializeTelemetry' ['honeycombExporter'] context
    'Core.Program.Execute.executeWith' context' ...
@
-}
honeycombExporter :: Exporter
honeycombExporter :: Exporter
honeycombExporter =
    Exporter :: Rope
-> (Config -> Config)
-> (forall τ. Context τ -> IO Forwarder)
-> Exporter
Exporter
        { $sel:codenameFrom:Exporter :: Rope
codenameFrom = Rope
"honeycomb"
        , $sel:setupConfigFrom:Exporter :: Config -> Config
setupConfigFrom = Config -> Config
setupHoneycombConfig
        , $sel:setupActionFrom:Exporter :: forall τ. Context τ -> IO Forwarder
setupActionFrom = forall τ. Context τ -> IO Forwarder
setupHoneycombAction
        }

-- so this is annoying: we're _under_ (and indeed, before) the Program monad
-- and in the guts of the library. So all the work we've done to provide
-- sensible access to environment variables etc isn't available here and we
-- have to replicate a bunch of stuff we've done elsewhere.

setupHoneycombConfig :: Config -> Config
setupHoneycombConfig :: Config -> Config
setupHoneycombConfig Config
config0 =
    let config1 :: Config
config1 =
            Options -> Config -> Config
appendOption
                ( LongName -> Rope -> Options
Variable
                    LongName
"HONEYCOMB_TEAM"
                    Rope
"The API key used to permit writes to Honeycomb."
                )
                Config
config0

        config2 :: Config
config2 =
            Options -> Config -> Config
appendOption
                ( LongName -> Maybe ShortName -> ParameterValue -> Rope -> Options
Option
                    LongName
"dataset"
                    Maybe ShortName
forall a. Maybe a
Nothing
                    (String -> ParameterValue
Value String
"DATASET")
                    Rope
"The name of the dataset within your Honeycomb account that this program's telemetry will be written to."
                )
                Config
config1
     in Config
config2

setupHoneycombAction :: Context τ -> IO Forwarder
setupHoneycombAction :: Context τ -> IO Forwarder
setupHoneycombAction Context τ
context = do
    let params :: Parameters
params = Context τ -> Parameters
forall τ. Context τ -> Parameters
commandLineFrom Context τ
context
        pairs :: Map LongName ParameterValue
pairs = Parameters -> Map LongName ParameterValue
environmentValuesFrom Parameters
params
        possibleTeam :: Maybe ParameterValue
possibleTeam = LongName -> Map LongName ParameterValue -> Maybe ParameterValue
forall κ ν. Key κ => κ -> Map κ ν -> Maybe ν
lookupKeyValue LongName
"HONEYCOMB_TEAM" Map LongName ParameterValue
pairs

    Rope
apikey <- case Maybe ParameterValue
possibleTeam of
        Maybe ParameterValue
Nothing -> do
            String -> IO ()
putStrLn String
"error: Need to supply an API key in the HONEYCOMB_TEAM environment variable."
            ExitCode -> IO ()
Posix.exitImmediately (Int -> ExitCode
ExitFailure Int
99)
            IO Rope
forall a. HasCallStack => a
undefined
        Just ParameterValue
param -> case ParameterValue
param of
            ParameterValue
Empty -> do
                String -> IO ()
putStrLn String
"error: Need to actually supply a value in HONEYCOMB_TEAM environment variable."
                ExitCode -> IO ()
Posix.exitImmediately (Int -> ExitCode
ExitFailure Int
99)
                IO Rope
forall a. HasCallStack => a
undefined
            Value String
value -> Rope -> IO Rope
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Rope
forall α. Textual α => α -> Rope
intoRope String
value)

    let options :: Map LongName ParameterValue
options = Parameters -> Map LongName ParameterValue
parameterValuesFrom Parameters
params
        possibleDataset :: Maybe ParameterValue
possibleDataset = LongName -> Map LongName ParameterValue -> Maybe ParameterValue
forall κ ν. Key κ => κ -> Map κ ν -> Maybe ν
lookupKeyValue LongName
"dataset" Map LongName ParameterValue
options

    Rope
dataset <- case Maybe ParameterValue
possibleDataset of
        Maybe ParameterValue
Nothing -> do
            String -> IO ()
putStrLn String
"error: Need to specify the dataset that metrics will be written to via --dataset."
            ExitCode -> IO ()
Posix.exitImmediately (Int -> ExitCode
ExitFailure Int
99)
            IO Rope
forall a. HasCallStack => a
undefined
        Just ParameterValue
param -> case ParameterValue
param of
            ParameterValue
Empty -> do
                String -> IO ()
putStrLn String
"error: Need to actually supply a value to the --dataset option."
                ExitCode -> IO ()
Posix.exitImmediately (Int -> ExitCode
ExitFailure Int
99)
                IO Rope
forall a. HasCallStack => a
undefined
            Value String
"" -> do
                String -> IO ()
putStrLn String
"error: Need to actually supply a value to the --dataset option."
                ExitCode -> IO ()
Posix.exitImmediately (Int -> ExitCode
ExitFailure Int
99)
                IO Rope
forall a. HasCallStack => a
undefined
            Value String
value -> Rope -> IO Rope
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Rope
forall α. Textual α => α -> Rope
intoRope String
value)

    Forwarder -> IO Forwarder
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        Forwarder :: ([Datum] -> IO ()) -> Forwarder
Forwarder
            { $sel:telemetryHandlerFrom:Forwarder :: [Datum] -> IO ()
telemetryHandlerFrom = Rope -> Rope -> [Datum] -> IO ()
process Rope
apikey Rope
dataset
            }

-- use partually applied
process :: ApiKey -> Dataset -> [Datum] -> IO ()
process :: Rope -> Rope -> [Datum] -> IO ()
process Rope
apikey Rope
dataset [Datum]
datums = do
    let json :: JsonValue
json = [JsonValue] -> JsonValue
JsonArray ((Datum -> JsonValue) -> [Datum] -> [JsonValue]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Datum -> JsonValue
convertDatumToJson [Datum]
datums)
    Rope -> Rope -> JsonValue -> IO ()
postEventToHoneycombAPI Rope
apikey Rope
dataset JsonValue
json

-- implements the spec described at <https://docs.honeycomb.io/getting-data-in/tracing/send-trace-data/>
convertDatumToJson :: Datum -> JsonValue
convertDatumToJson :: Datum -> JsonValue
convertDatumToJson Datum
datum =
    let spani :: Maybe Span
spani = Datum -> Maybe Span
spanIdentifierFrom Datum
datum
        trace :: Maybe Trace
trace = Datum -> Maybe Trace
traceIdentifierFrom Datum
datum
        parent :: Maybe Span
parent = Datum -> Maybe Span
parentIdentifierFrom Datum
datum
        meta0 :: Map JsonKey JsonValue
meta0 = Datum -> Map JsonKey JsonValue
attachedMetadataFrom Datum
datum

        meta1 :: Map JsonKey JsonValue
meta1 = JsonKey
-> JsonValue -> Map JsonKey JsonValue -> Map JsonKey JsonValue
forall κ ν. Key κ => κ -> ν -> Map κ ν -> Map κ ν
insertKeyValue JsonKey
"name" (Rope -> JsonValue
JsonString (Datum -> Rope
spanNameFrom Datum
datum)) Map JsonKey JsonValue
meta0

        meta2 :: Map JsonKey JsonValue
meta2 = case Maybe Span
spani of
            Maybe Span
Nothing -> case Maybe Trace
trace of
                Maybe Trace
Nothing -> Map JsonKey JsonValue
meta1
                Just Trace
_ -> JsonKey
-> JsonValue -> Map JsonKey JsonValue -> Map JsonKey JsonValue
forall κ ν. Key κ => κ -> ν -> Map κ ν -> Map κ ν
insertKeyValue JsonKey
"meta.annotation_type" (Rope -> JsonValue
JsonString Rope
"span_event") Map JsonKey JsonValue
meta1
            Just Span
value -> JsonKey
-> JsonValue -> Map JsonKey JsonValue -> Map JsonKey JsonValue
forall κ ν. Key κ => κ -> ν -> Map κ ν -> Map κ ν
insertKeyValue JsonKey
"trace.span_id" (Rope -> JsonValue
JsonString (Span -> Rope
unSpan Span
value)) Map JsonKey JsonValue
meta1

        meta3 :: Map JsonKey JsonValue
meta3 = case Maybe Span
parent of
            Maybe Span
Nothing -> Map JsonKey JsonValue
meta2
            Just Span
value -> JsonKey
-> JsonValue -> Map JsonKey JsonValue -> Map JsonKey JsonValue
forall κ ν. Key κ => κ -> ν -> Map κ ν -> Map κ ν
insertKeyValue JsonKey
"trace.parent_id" (Rope -> JsonValue
JsonString (Span -> Rope
unSpan Span
value)) Map JsonKey JsonValue
meta2

        meta4 :: Map JsonKey JsonValue
meta4 = case Maybe Trace
trace of
            Maybe Trace
Nothing -> Map JsonKey JsonValue
meta3
            Just Trace
value -> JsonKey
-> JsonValue -> Map JsonKey JsonValue -> Map JsonKey JsonValue
forall κ ν. Key κ => κ -> ν -> Map κ ν -> Map κ ν
insertKeyValue JsonKey
"trace.trace_id" (Rope -> JsonValue
JsonString (Trace -> Rope
unTrace Trace
value)) Map JsonKey JsonValue
meta3

        meta5 :: Map JsonKey JsonValue
meta5 = case Datum -> Maybe Rope
serviceNameFrom Datum
datum of
            Maybe Rope
Nothing -> Map JsonKey JsonValue
meta4
            Just Rope
service -> JsonKey
-> JsonValue -> Map JsonKey JsonValue -> Map JsonKey JsonValue
forall κ ν. Key κ => κ -> ν -> Map κ ν -> Map κ ν
insertKeyValue JsonKey
"service_name" (Rope -> JsonValue
JsonString Rope
service) Map JsonKey JsonValue
meta4

        meta6 :: Map JsonKey JsonValue
meta6 = case Datum -> Maybe Int64
durationFrom Datum
datum of
            Maybe Int64
Nothing -> Map JsonKey JsonValue
meta5
            Just Int64
duration ->
                JsonKey
-> JsonValue -> Map JsonKey JsonValue -> Map JsonKey JsonValue
forall κ ν. Key κ => κ -> ν -> Map κ ν -> Map κ ν
insertKeyValue
                    JsonKey
"duration_ms"
                    (Scientific -> JsonValue
JsonNumber (Rational -> Scientific
forall a. Fractional a => Rational -> a
fromRational (Int64 -> Rational
forall a. Real a => a -> Rational
toRational Int64
duration Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ Rational
1e6)))
                    Map JsonKey JsonValue
meta5

        time :: Rope
time = String -> Rope
forall α. Textual α => α -> Rope
intoRope (TimeStamp -> String
forall a. Show a => a -> String
show (Datum -> TimeStamp
spanTimeFrom Datum
datum))
        point :: JsonValue
point =
            Map JsonKey JsonValue -> JsonValue
JsonObject
                ( [(JsonKey, JsonValue)]
-> Map (K [(JsonKey, JsonValue)]) (V [(JsonKey, JsonValue)])
forall α. Dictionary α => α -> Map (K α) (V α)
intoMap
                    [ (Rope -> JsonKey
JsonKey Rope
"time", Rope -> JsonValue
JsonString Rope
time)
                    , (Rope -> JsonKey
JsonKey Rope
"data", Map JsonKey JsonValue -> JsonValue
JsonObject Map JsonKey JsonValue
meta6)
                    ]
                )
     in JsonValue
point

postEventToHoneycombAPI :: ApiKey -> Dataset -> JsonValue -> IO ()
postEventToHoneycombAPI :: Rope -> Rope -> JsonValue -> IO ()
postEventToHoneycombAPI Rope
apikey Rope
dataset JsonValue
json = do
    SSLContext
ctx <- IO SSLContext
baselineContextSSL
    Connection
c <- SSLContext -> Hostname -> Port -> IO Connection
openConnectionSSL SSLContext
ctx Hostname
"api.honeycomb.io" Port
443

    let q :: Request
q = RequestBuilder () -> Request
forall α. RequestBuilder α -> Request
buildRequest1 (RequestBuilder () -> Request) -> RequestBuilder () -> Request
forall a b. (a -> b) -> a -> b
$ do
            Method -> Hostname -> RequestBuilder ()
http Method
POST (Hostname -> Hostname -> Hostname
C.append Hostname
"/1/batch/" (Rope -> Hostname
forall α. Textual α => Rope -> α
fromRope Rope
dataset))
            Hostname -> RequestBuilder ()
setContentType Hostname
"application/json"
            Hostname -> Hostname -> RequestBuilder ()
setHeader Hostname
"X-Honeycomb-Team" (Rope -> Hostname
forall α. Textual α => Rope -> α
fromRope (Rope
apikey))

    Connection -> Request -> (OutputStream Builder -> IO ()) -> IO ()
forall α.
Connection -> Request -> (OutputStream Builder -> IO α) -> IO α
sendRequest Connection
c Request
q (Hostname -> OutputStream Builder -> IO ()
simpleBody (Bytes -> Hostname
forall α. Binary α => Bytes -> α
fromBytes (JsonValue -> Bytes
encodeToUTF8 JsonValue
json)))
    Connection -> (Response -> InputStream Hostname -> IO ()) -> IO ()
forall β.
Connection -> (Response -> InputStream Hostname -> IO β) -> IO β
receiveResponse Connection
c Response -> InputStream Hostname -> IO ()
handler
  where
    {-
    Response to Batch API looks like:

    [{"status":202}]

    -}
    handler :: Response -> InputStream ByteString -> IO ()
    handler :: Response -> InputStream Hostname -> IO ()
handler Response
p InputStream Hostname
i = do
        let code :: Int
code = Response -> Int
getStatusCode Response
p
        case Int
code of
            Int
200 -> do
                Hostname
body <- Response -> InputStream Hostname -> IO Hostname
simpleHandler Response
p InputStream Hostname
i
                let responses :: Maybe JsonValue
responses = Bytes -> Maybe JsonValue
decodeFromUTF8 (Hostname -> Bytes
forall α. Binary α => α -> Bytes
intoBytes Hostname
body)
                case Maybe JsonValue
responses of
                    Just (JsonArray [JsonValue]
pairs) -> (JsonValue -> IO ()) -> [JsonValue] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ JsonValue -> IO ()
f [JsonValue]
pairs
                      where
                        f :: JsonValue -> IO ()
f JsonValue
pair = case JsonValue
pair of
                            JsonObject Map JsonKey JsonValue
kvs -> case JsonKey -> Map JsonKey JsonValue -> Maybe JsonValue
forall κ ν. Key κ => κ -> Map κ ν -> Maybe ν
lookupKeyValue JsonKey
"status" Map JsonKey JsonValue
kvs of
                                Just (JsonNumber Scientific
202) -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                                Maybe JsonValue
_ -> do
                                    String -> IO ()
putStrLn String
"No status returned;"
                                    Hostname -> IO ()
C.putStrLn Hostname
body
                            JsonValue
_ -> String -> IO ()
putStrLn String
"internal: wtf?"
                    Maybe JsonValue
_ -> do
                        String -> IO ()
putStrLn String
"internal: Unexpected response from Honeycomb"
                        Hostname -> IO ()
C.putStrLn Hostname
body
            Int
_ -> do
                String -> IO ()
putStrLn String
"internal: Failed to post to Honeycomb"
                Response -> InputStream Hostname -> IO ()
debugHandler Response
p InputStream Hostname
i