{-# 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
        { codenameFrom = "honeycomb"
        , setupConfigFrom = setupHoneycombConfig
        , setupActionFrom = 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 config0 =
    let config1 =
            appendOption
                ( Variable
                    "HONEYCOMB_TEAM"
                    "The API key used to permit writes to Honeycomb."
                )
                config0

        config2 =
            appendOption
                ( Option
                    "dataset"
                    Nothing
                    (Value "DATASET")
                    "The name of the dataset within your Honeycomb account that this program's telemetry will be written to."
                )
                config1
     in config2

setupHoneycombAction :: Context τ -> IO Forwarder
setupHoneycombAction context = do
    let params = commandLineFrom context
        pairs = environmentValuesFrom params
        possibleTeam = lookupKeyValue "HONEYCOMB_TEAM" pairs

    apikey <- case possibleTeam of
        Nothing -> do
            putStrLn "error: Need to supply an API key in the HONEYCOMB_TEAM environment variable."
            Posix.exitImmediately (ExitFailure 99)
            undefined
        Just param -> case param of
            Empty -> do
                putStrLn "error: Need to actually supply a value in HONEYCOMB_TEAM environment variable."
                Posix.exitImmediately (ExitFailure 99)
                undefined
            Value value -> pure (intoRope value)

    let options = parameterValuesFrom params
        possibleDataset = lookupKeyValue "dataset" options

    dataset <- case possibleDataset of
        Nothing -> do
            putStrLn "error: Need to specify the dataset that metrics will be written to via --dataset."
            Posix.exitImmediately (ExitFailure 99)
            undefined
        Just param -> case param of
            Empty -> do
                putStrLn "error: Need to actually supply a value to the --dataset option."
                Posix.exitImmediately (ExitFailure 99)
                undefined
            Value "" -> do
                putStrLn "error: Need to actually supply a value to the --dataset option."
                Posix.exitImmediately (ExitFailure 99)
                undefined
            Value value -> pure (intoRope value)

    r <- newIORef Nothing

    pure
        Forwarder
            { telemetryHandlerFrom = process r apikey dataset
            }

-- use partually applied
process :: IORef (Maybe Connection) -> ApiKey -> Dataset -> [Datum] -> IO ()
process r apikey dataset datums = do
    let json = JsonArray (fmap convertDatumToJson datums)
    postEventToHoneycombAPI r apikey dataset json

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

        meta1 = insertKeyValue "name" (JsonString (spanNameFrom datum)) meta0

        meta2 = case spani of
            Nothing -> case trace of
                Nothing -> meta1
                Just _ -> insertKeyValue "meta.annotation_type" (JsonString "span_event") meta1
            Just value -> insertKeyValue "trace.span_id" (JsonString (unSpan value)) meta1

        meta3 = case parent of
            Nothing -> case trace of
                Nothing -> meta2
                Just _ -> insertKeyValue "meta.span_type" (JsonString "root") meta2
            Just value -> insertKeyValue "trace.parent_id" (JsonString (unSpan value)) meta2

        meta4 = case trace of
            Nothing -> meta3
            Just value -> insertKeyValue "trace.trace_id" (JsonString (unTrace value)) meta3

        meta5 = case serviceNameFrom datum of
            Nothing -> meta4
            Just service -> insertKeyValue "service.name" (JsonString service) meta4

        meta6 = case durationFrom datum of
            Nothing -> meta5
            Just duration ->
                insertKeyValue
                    "duration_ms"
                    (JsonNumber (fromRational (toRational duration / 1e6)))
                    meta5

        time = intoRope (show (spanTimeFrom datum))
        point =
            JsonObject
                ( intoMap
                    [ (JsonKey "time", JsonString time)
                    , (JsonKey "data", JsonObject meta6)
                    ]
                )
     in point

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

            writeIORef r (Just c)
            pure c
        Just c -> do
            pure c

cleanupConnection :: IORef (Maybe Connection) -> IO ()
cleanupConnection r = do
    Safe.finally
        ( do
            possible <- readIORef r
            case possible of
                Nothing -> pure ()
                Just c -> closeConnection c
        )
        ( do
            writeIORef r Nothing
        )

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

postEventToHoneycombAPI :: IORef (Maybe Connection) -> ApiKey -> Dataset -> JsonValue -> IO ()
postEventToHoneycombAPI r apikey dataset json = attempt False
  where
    attempt retrying = do
        Safe.catch
            ( do
                c <- acquireConnection r

                -- actually transmit telemetry to Honeycomb
                sendRequest c q (compressBody (encodeToUTF8 json))
                receiveResponse c handler
            )
            ( \(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.
                cleanupConnection r
                case retrying of
                    False -> do
                        putStrLn "internal: Reconnecting to Honeycomb"
                        attempt True
                    True -> do
                        putStrLn "internal: Failed to re-establish connection to Honeycomb"
                        Safe.throw e
            )

    q = buildRequest1 $ do
        http POST (fromRope ("/1/batch/" <> dataset))
        setContentType "application/json"
        setHeader "Content-Encoding" "gzip"
        setHeader "X-Honeycomb-Team" (fromRope (apikey))

    {-
    Response to Batch API looks like:

    [{"status":202}]

    TODO we need to handle other status responses properly.
    -}
    handler :: Response -> InputStream ByteString -> IO ()
    handler p i = do
        let code = getStatusCode p
        case code of
            200 -> do
                body <- simpleHandler p i
                let responses = decodeFromUTF8 (intoBytes body)
                case responses of
                    Just (JsonArray pairs) -> mapM_ f pairs
                      where
                        f pair = case pair of
                            JsonObject kvs -> case lookupKeyValue "status" kvs of
                                Just (JsonNumber 202) -> do
                                    -- normal response
                                    pure ()
                                _ -> do
                                    -- some other status!
                                    putStrLn "internal: Unexpected status returned;"
                                    C.putStrLn body
                            _ -> putStrLn "internal: wtf?"
                    _ -> do
                        putStrLn "internal: Unexpected response from Honeycomb"
                        C.putStrLn body
            _ -> do
                putStrLn "internal: Failed to post to Honeycomb"
                debugHandler p i