{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# 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. In the future you may be able to look at
"Core.Telemetry.General" if you instead want to forward to a generic
OpenTelemetry provider.
-}
module Core.Telemetry.Honeycomb (
    Dataset,
    honeycombExporter,
) where

import Codec.Compression.GZip qualified as GZip (compress)
import Control.Exception.Safe qualified as Safe (catch, finally, throw)
import Core.Data.Clock (Time, getCurrentTimeNanoseconds, unTime)
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 (SomeException, liftIO, stdout)
import Core.Text.Bytes
import Core.Text.Colour
import Core.Text.Rope
import Core.Text.Utilities
import Data.ByteString (ByteString)
import Data.ByteString qualified as B (ByteString)
import Data.ByteString.Builder (Builder)
import Data.ByteString.Builder qualified as Builder (lazyByteString)
import Data.ByteString.Char8 qualified as C (append, null, putStrLn)
import Data.ByteString.Lazy qualified as L (ByteString)
import Data.Fixed
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Data.List qualified as List
import Network.Http.Client
import System.Environment (lookupEnv)
import System.Exit (ExitCode (..))
import System.IO.Streams (InputStream, OutputStream)
import System.IO.Streams qualified as Streams (write)
import System.Posix.Process qualified 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
        { $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"
                    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 :: forall τ. Context τ -> IO Forwarder
setupHoneycombAction Context τ
context = do
    let params :: Parameters
params = forall τ. Context τ -> Parameters
commandLineFrom Context τ
context
        pairs :: Map LongName ParameterValue
pairs = Parameters -> Map LongName ParameterValue
environmentValuesFrom Parameters
params
        possibleTeam :: Maybe ParameterValue
possibleTeam = 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 (StatusCode -> ExitCode
ExitFailure StatusCode
99)
            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 (StatusCode -> ExitCode
ExitFailure StatusCode
99)
                forall a. HasCallStack => a
undefined
            Value String
value -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall α. Textual α => α -> Rope
intoRope String
value)

    let options :: Map LongName ParameterValue
options = Parameters -> Map LongName ParameterValue
parameterValuesFrom Parameters
params
        possibleDataset :: Maybe ParameterValue
possibleDataset = 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 (StatusCode -> ExitCode
ExitFailure StatusCode
99)
            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 (StatusCode -> ExitCode
ExitFailure StatusCode
99)
                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 (StatusCode -> ExitCode
ExitFailure StatusCode
99)
                forall a. HasCallStack => a
undefined
            Value String
value -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall α. Textual α => α -> Rope
intoRope String
value)

    IORef (Maybe Connection)
r <- forall a. a -> IO (IORef a)
newIORef forall a. Maybe a
Nothing

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

-- use partually applied
process :: IORef (Maybe Connection) -> ApiKey -> Dataset -> [Datum] -> IO ()
process :: IORef (Maybe Connection) -> Rope -> Rope -> [Datum] -> IO ()
process IORef (Maybe Connection)
r Rope
apikey Rope
dataset [Datum]
datums = do
    let json :: JsonValue
json = [JsonValue] -> JsonValue
JsonArray (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Datum -> JsonValue
convertDatumToJson [Datum]
datums)
    IORef (Maybe Connection) -> Rope -> Rope -> JsonValue -> IO ()
postEventToHoneycombAPI IORef (Maybe Connection)
r 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 = 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
_ -> forall κ ν. Key κ => κ -> ν -> Map κ ν -> Map κ ν
insertKeyValue JsonKey
"meta.annotation_type" (Rope -> JsonValue
JsonString Rope
"span_event") Map JsonKey JsonValue
meta1
            Just Span
value -> 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 -> case Maybe Trace
trace of
                Maybe Trace
Nothing -> Map JsonKey JsonValue
meta2
                Just Trace
_ -> forall κ ν. Key κ => κ -> ν -> Map κ ν -> Map κ ν
insertKeyValue JsonKey
"meta.span_type" (Rope -> JsonValue
JsonString Rope
"root") Map JsonKey JsonValue
meta2
            Just Span
value -> 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 -> 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 -> 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 ->
                forall κ ν. Key κ => κ -> ν -> Map κ ν -> Map κ ν
insertKeyValue
                    JsonKey
"duration_ms"
                    (Scientific -> JsonValue
JsonNumber (forall a. Fractional a => Rational -> a
fromRational (forall a. Real a => a -> Rational
toRational Int64
duration forall a. Fractional a => a -> a -> a
/ Rational
1e6)))
                    Map JsonKey JsonValue
meta5

        time :: Rope
time = forall α. Textual α => α -> Rope
intoRope (forall a. Show a => a -> String
show (Datum -> Time
spanTimeFrom Datum
datum))
        point :: JsonValue
point =
            Map JsonKey JsonValue -> JsonValue
JsonObject
                ( 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

acquireConnection :: IORef (Maybe Connection) -> IO Connection
acquireConnection :: IORef (Maybe Connection) -> IO Connection
acquireConnection IORef (Maybe Connection)
r = do
    Maybe Connection
possible <- forall a. IORef a -> IO a
readIORef IORef (Maybe Connection)
r
    case Maybe Connection
possible of
        Maybe Connection
Nothing -> do
            SSLContext
ctx <- IO SSLContext
baselineContextSSL
            Connection
c <- SSLContext -> Hostname -> Port -> IO Connection
openConnectionSSL SSLContext
ctx Hostname
"api.honeycomb.io" Port
443

            forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe Connection)
r (forall a. a -> Maybe a
Just Connection
c)
            forall (f :: * -> *) a. Applicative f => a -> f a
pure Connection
c
        Just Connection
c -> do
            forall (f :: * -> *) a. Applicative f => a -> f a
pure Connection
c

cleanupConnection :: IORef (Maybe Connection) -> IO ()
cleanupConnection :: IORef (Maybe Connection) -> IO ()
cleanupConnection IORef (Maybe Connection)
r = do
    forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
Safe.finally
        ( do
            Maybe Connection
possible <- forall a. IORef a -> IO a
readIORef IORef (Maybe Connection)
r
            case Maybe Connection
possible of
                Maybe Connection
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                Just Connection
c -> Connection -> IO ()
closeConnection Connection
c
        )
        ( do
            forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe Connection)
r forall a. Maybe a
Nothing
        )

compressBody :: Bytes -> OutputStream Builder -> IO ()
compressBody :: Bytes -> OutputStream Builder -> IO ()
compressBody Bytes
bytes OutputStream Builder
o = do
    let x :: ByteString
x = forall α. Binary α => Bytes -> α
fromBytes Bytes
bytes
    let x' :: ByteString
x' = ByteString -> ByteString
GZip.compress ByteString
x
    let b :: Builder
b = ByteString -> Builder
Builder.lazyByteString ByteString
x'
    forall a. Maybe a -> OutputStream a -> IO ()
Streams.write (forall a. a -> Maybe a
Just Builder
b) OutputStream Builder
o

postEventToHoneycombAPI :: IORef (Maybe Connection) -> ApiKey -> Dataset -> JsonValue -> IO ()
postEventToHoneycombAPI :: IORef (Maybe Connection) -> Rope -> Rope -> JsonValue -> IO ()
postEventToHoneycombAPI IORef (Maybe Connection)
r Rope
apikey Rope
dataset JsonValue
json = Bool -> IO ()
attempt Bool
False
  where
    attempt :: Bool -> IO ()
attempt Bool
retrying = do
        forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
Safe.catch
            ( do
                Connection
c <- IORef (Maybe Connection) -> IO Connection
acquireConnection IORef (Maybe Connection)
r

                -- actually transmit telemetry to Honeycomb
                forall α.
Connection -> Request -> (OutputStream Builder -> IO α) -> IO α
sendRequest Connection
c Request
q (Bytes -> OutputStream Builder -> IO ()
compressBody (JsonValue -> Bytes
encodeToUTF8 JsonValue
json))
                forall β.
Connection -> (Response -> InputStream Hostname -> IO β) -> IO β
receiveResponse Connection
c Response -> InputStream Hostname -> IO ()
handler
            )
            ( \(SomeException
e :: SomeException) -> do
                -- ideally we don't get here, but if the SSL connection collapses
                -- we will. We retry /once/, and otherwise throw the exception out.
                IORef (Maybe Connection) -> IO ()
cleanupConnection IORef (Maybe Connection)
r
                case Bool
retrying of
                    Bool
False -> do
                        String -> IO ()
putStrLn String
"internal: Reconnecting to Honeycomb"
                        Bool -> IO ()
attempt Bool
True
                    Bool
True -> do
                        String -> IO ()
putStrLn String
"internal: Failed to re-establish connection to Honeycomb"
                        forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
Safe.throw SomeException
e
            )

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

    {-
    Response to Batch API looks like:

    [{"status":202}]

    TODO we need to handle other status responses properly.
    -}
    handler :: Response -> InputStream ByteString -> IO ()
    handler :: Response -> InputStream Hostname -> IO ()
handler Response
p InputStream Hostname
i = do
        let code :: StatusCode
code = Response -> StatusCode
getStatusCode Response
p
        case StatusCode
code of
            StatusCode
200 -> do
                Hostname
body <- Response -> InputStream Hostname -> IO Hostname
simpleHandler Response
p InputStream Hostname
i
                let responses :: Maybe JsonValue
responses = Bytes -> Maybe JsonValue
decodeFromUTF8 (forall α. Binary α => α -> Bytes
intoBytes Hostname
body)
                case Maybe JsonValue
responses of
                    Just (JsonArray [JsonValue]
pairs) -> 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 forall κ ν. Key κ => κ -> Map κ ν -> Maybe ν
lookupKeyValue JsonKey
"status" Map JsonKey JsonValue
kvs of
                                Just (JsonNumber Scientific
202) -> do
                                    -- normal response
                                    forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                                Maybe JsonValue
_ -> do
                                    -- some other status!
                                    String -> IO ()
putStrLn String
"internal: Unexpected 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
            StatusCode
_ -> do
                String -> IO ()
putStrLn String
"internal: Failed to post to Honeycomb"
                Response -> InputStream Hostname -> IO ()
debugHandler Response
p InputStream Hostname
i