{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
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)
type Dataset = Rope
type ApiKey = Rope
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
}
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
}
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
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
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
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))
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
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Maybe JsonValue
_ -> do
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