{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
module Core.Telemetry.Honeycomb
( Dataset
, honeycombExporter
, setDatasetName
) where
import Codec.Compression.GZip qualified as GZip (compress)
import Control.Concurrent.MVar (modifyMVar_)
import Control.Exception.Safe qualified as Safe (catch, finally, throw)
import Control.Monad (forM_)
import Core.Data.Clock (Time, getCurrentTimeNanoseconds, unTime)
import Core.Data.Structures (Map, emptyMap, 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, pack, 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 :: Dataset
codenameFrom = Dataset
"honeycomb"
, $sel:setupConfigFrom:Exporter :: Config -> Config
setupConfigFrom = Config -> Config
setupHoneycombConfig
, $sel:setupActionFrom:Exporter :: forall τ. Context τ -> IO Forwarder
setupActionFrom = forall τ. Context τ -> IO Forwarder
setupHoneycombAction
}
setDatasetName :: Dataset -> Program τ ()
setDatasetName :: forall τ. Dataset -> Program τ ()
setDatasetName Dataset
dataset = do
Context τ
context <- forall τ. Program τ (Context τ)
getContext
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
let v :: MVar Datum
v = forall τ. Context τ -> MVar Datum
currentDatumFrom Context τ
context
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_
MVar Datum
v
(\Datum
datum -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Datum
datum {$sel:datasetFrom:Datum :: Maybe Dataset
datasetFrom = forall a. a -> Maybe a
Just Dataset
dataset})
setupHoneycombConfig :: Config -> Config
setupHoneycombConfig :: Config -> Config
setupHoneycombConfig Config
config0 =
let config1 :: Config
config1 =
Options -> Config -> Config
appendOption
( LongName -> Dataset -> Options
Variable
LongName
"HONEYCOMB_TEAM"
Dataset
"The API key used to permit writes to Honeycomb."
)
Config
config0
config2 :: Config
config2 =
Options -> Config -> Config
appendOption
( LongName -> Maybe ShortName -> ParameterValue -> Dataset -> Options
Option
LongName
"dataset"
forall a. Maybe a
Nothing
(String -> ParameterValue
Value String
"DATASET")
Dataset
"The name of the dataset within your Honeycomb account that this program's telemetry will be written to."
)
Config
config1
config3 :: Config
config3 =
Options -> Config -> Config
appendOption
( LongName -> Dataset -> Options
Variable
LongName
"HONEYCOMB_HOST"
Dataset
"Override the default API endpoint for occasions where telemetry needs to be proxied through an intermediate service. Default: api.honeycomb.io"
)
Config
config2
in Config
config3
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
possibleHoneycombHostOverride :: Maybe ParameterValue
possibleHoneycombHostOverride = forall κ ν. Key κ => κ -> Map κ ν -> Maybe ν
lookupKeyValue LongName
"HONEYCOMB_HOST" Map LongName ParameterValue
pairs
let defaultHoneycombHost :: ByteString
defaultHoneycombHost = ByteString
"api.honeycomb.io"
honeycombHost :: ByteString
honeycombHost = case Maybe ParameterValue
possibleHoneycombHostOverride of
Maybe ParameterValue
Nothing -> ByteString
defaultHoneycombHost
Just ParameterValue
Empty -> ByteString
defaultHoneycombHost
Just (Value String
"") -> ByteString
defaultHoneycombHost
Just (Value String
host) -> String -> ByteString
C.pack String
host
Dataset
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 α => α -> Dataset
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
Dataset
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 α => α -> Dataset
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)
-> ByteString -> Dataset -> Dataset -> [Datum] -> IO ()
process IORef (Maybe Connection)
r ByteString
honeycombHost Dataset
apikey Dataset
dataset
}
process :: IORef (Maybe Connection) -> Hostname -> ApiKey -> Dataset -> [Datum] -> IO ()
process :: IORef (Maybe Connection)
-> ByteString -> Dataset -> Dataset -> [Datum] -> IO ()
process IORef (Maybe Connection)
r ByteString
honeycombHost Dataset
apikey Dataset
dataset [Datum]
datums = do
let targets :: Map Dataset [JsonValue]
targets = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' Map Dataset [JsonValue] -> Datum -> Map Dataset [JsonValue]
f forall κ ν. Map κ ν
emptyMap [Datum]
datums :: Map Dataset [JsonValue]
let pairs :: [(Dataset, [JsonValue])]
pairs = forall α. Dictionary α => Map (K α) (V α) -> α
fromMap Map Dataset [JsonValue]
targets :: [(Dataset, [JsonValue])]
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Dataset, [JsonValue])]
pairs forall a b. (a -> b) -> a -> b
$ \(Dataset
dataset', [JsonValue]
values') -> do
let json :: JsonValue
json = [JsonValue] -> JsonValue
JsonArray [JsonValue]
values'
IORef (Maybe Connection)
-> ByteString -> Dataset -> Dataset -> JsonValue -> IO ()
postEventToHoneycombAPI IORef (Maybe Connection)
r ByteString
honeycombHost Dataset
apikey Dataset
dataset' JsonValue
json
where
f :: Map Dataset [JsonValue] -> Datum -> Map Dataset [JsonValue]
f :: Map Dataset [JsonValue] -> Datum -> Map Dataset [JsonValue]
f Map Dataset [JsonValue]
acc Datum
datum =
let
(Maybe Dataset
override, JsonValue
point) = Datum -> (Maybe Dataset, JsonValue)
convertDatumToJson Datum
datum
dataset' :: Dataset
dataset' = case Maybe Dataset
override of
Maybe Dataset
Nothing -> Dataset
dataset
Just Dataset
value -> Dataset
value
list' :: [JsonValue]
list' = case forall κ ν. Key κ => κ -> Map κ ν -> Maybe ν
lookupKeyValue Dataset
dataset' Map Dataset [JsonValue]
acc of
Maybe [JsonValue]
Nothing -> JsonValue
point forall a. a -> [a] -> [a]
: []
Just [JsonValue]
list -> JsonValue
point forall a. a -> [a] -> [a]
: [JsonValue]
list
in
forall κ ν. Key κ => κ -> ν -> Map κ ν -> Map κ ν
insertKeyValue Dataset
dataset' [JsonValue]
list' Map Dataset [JsonValue]
acc
convertDatumToJson :: Datum -> (Maybe Dataset, JsonValue)
convertDatumToJson :: Datum -> (Maybe Dataset, 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" (Dataset -> JsonValue
JsonString (Datum -> Dataset
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" (Dataset -> JsonValue
JsonString Dataset
"span_event") Map JsonKey JsonValue
meta1
Just Span
value -> forall κ ν. Key κ => κ -> ν -> Map κ ν -> Map κ ν
insertKeyValue JsonKey
"trace.span_id" (Dataset -> JsonValue
JsonString (Span -> Dataset
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" (Dataset -> JsonValue
JsonString Dataset
"root") Map JsonKey JsonValue
meta2
Just Span
value -> forall κ ν. Key κ => κ -> ν -> Map κ ν -> Map κ ν
insertKeyValue JsonKey
"trace.parent_id" (Dataset -> JsonValue
JsonString (Span -> Dataset
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" (Dataset -> JsonValue
JsonString (Trace -> Dataset
unTrace Trace
value)) Map JsonKey JsonValue
meta3
meta5 :: Map JsonKey JsonValue
meta5 = case Datum -> Maybe Dataset
serviceNameFrom Datum
datum of
Maybe Dataset
Nothing -> Map JsonKey JsonValue
meta4
Just Dataset
service -> forall κ ν. Key κ => κ -> ν -> Map κ ν -> Map κ ν
insertKeyValue JsonKey
"service.name" (Dataset -> JsonValue
JsonString Dataset
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 :: Dataset
time = forall α. Textual α => α -> Dataset
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
[ (Dataset -> JsonKey
JsonKey Dataset
"time", Dataset -> JsonValue
JsonString Dataset
time)
, (Dataset -> JsonKey
JsonKey Dataset
"data", Map JsonKey JsonValue -> JsonValue
JsonObject Map JsonKey JsonValue
meta6)
]
)
override :: Maybe Dataset
override = Datum -> Maybe Dataset
datasetFrom Datum
datum
in (Maybe Dataset
override, JsonValue
point)
acquireConnection :: IORef (Maybe Connection) -> Hostname -> IO Connection
acquireConnection :: IORef (Maybe Connection) -> ByteString -> IO Connection
acquireConnection IORef (Maybe Connection)
r ByteString
honeycombHost = 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 -> ByteString -> Port -> IO Connection
openConnectionSSL SSLContext
ctx ByteString
honeycombHost 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) -> Hostname -> ApiKey -> Dataset -> JsonValue -> IO ()
postEventToHoneycombAPI :: IORef (Maybe Connection)
-> ByteString -> Dataset -> Dataset -> JsonValue -> IO ()
postEventToHoneycombAPI IORef (Maybe Connection)
r ByteString
honeycombHost Dataset
apikey Dataset
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) -> ByteString -> IO Connection
acquireConnection IORef (Maybe Connection)
r ByteString
honeycombHost
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 ByteString -> IO β) -> IO β
receiveResponse Connection
c Response -> InputStream ByteString -> 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 -> ByteString -> RequestBuilder ()
http Method
POST (forall α. Textual α => Dataset -> α
fromRope (Dataset
"/1/batch/" forall a. Semigroup a => a -> a -> a
<> Dataset
dataset))
ByteString -> RequestBuilder ()
setContentType ByteString
"application/json"
ByteString -> ByteString -> RequestBuilder ()
setHeader ByteString
"Content-Encoding" ByteString
"gzip"
ByteString -> ByteString -> RequestBuilder ()
setHeader ByteString
"X-Honeycomb-Team" (forall α. Textual α => Dataset -> α
fromRope (Dataset
apikey))
handler :: Response -> InputStream ByteString -> IO ()
handler :: Response -> InputStream ByteString -> IO ()
handler Response
p InputStream ByteString
i = do
let code :: StatusCode
code = Response -> StatusCode
getStatusCode Response
p
case StatusCode
code of
StatusCode
200 -> do
ByteString
body <- Response -> InputStream ByteString -> IO ByteString
simpleHandler Response
p InputStream ByteString
i
let responses :: Maybe JsonValue
responses = Bytes -> Maybe JsonValue
decodeFromUTF8 (forall α. Binary α => α -> Bytes
intoBytes ByteString
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;"
ByteString -> IO ()
C.putStrLn ByteString
body
JsonValue
_ -> String -> IO ()
putStrLn String
"internal: wtf?"
Maybe JsonValue
_ -> do
String -> IO ()
putStrLn String
"internal: Unexpected response from Honeycomb"
ByteString -> IO ()
C.putStrLn ByteString
body
StatusCode
_ -> do
String -> IO ()
putStrLn String
"internal: Failed to post to Honeycomb"
Response -> InputStream ByteString -> IO ()
debugHandler Response
p InputStream ByteString
i