{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
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
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 Data.IORef (IORef, newIORef, readIORef, writeIORef)
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)
type Dataset = Rope
type ApiKey = Rope
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
}
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)
IORef (Maybe Connection)
r <- Maybe Connection -> IO (IORef (Maybe Connection))
forall a. a -> IO (IORef a)
newIORef Maybe Connection
forall a. Maybe a
Nothing
Forwarder -> IO Forwarder
forall (f :: * -> *) a. Applicative f => a -> f a
pure
Forwarder :: ([Datum] -> IO ()) -> Forwarder
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 ((Datum -> JsonValue) -> [Datum] -> [JsonValue]
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 = 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
acquireConnection :: IORef (Maybe Connection) -> IO Connection
acquireConnection :: IORef (Maybe Connection) -> IO Connection
acquireConnection IORef (Maybe Connection)
r = do
Maybe Connection
possible <- IORef (Maybe Connection) -> IO (Maybe Connection)
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
IORef (Maybe Connection) -> Maybe Connection -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe Connection)
r (Connection -> Maybe Connection
forall a. a -> Maybe a
Just Connection
c)
Connection -> IO Connection
forall (f :: * -> *) a. Applicative f => a -> f a
pure Connection
c
Just Connection
c -> do
Connection -> IO Connection
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
IO () -> IO () -> IO ()
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
finally
( do
Maybe Connection
possible <- IORef (Maybe Connection) -> IO (Maybe Connection)
forall a. IORef a -> IO a
readIORef IORef (Maybe Connection)
r
case Maybe Connection
possible of
Maybe Connection
Nothing -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Just Connection
c -> Connection -> IO ()
closeConnection Connection
c
)
( do
IORef (Maybe Connection) -> Maybe Connection -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe Connection)
r Maybe Connection
forall a. Maybe a
Nothing
)
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
IO () -> (SomeException -> IO ()) -> IO ()
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch
( do
Connection
c <- IORef (Maybe Connection) -> IO Connection
acquireConnection IORef (Maybe Connection)
r
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
)
( \(SomeException
e :: SomeException) -> do
IORef (Maybe Connection) -> IO ()
cleanupConnection IORef (Maybe Connection)
r
case Bool
retrying of
Bool
False -> do
String -> IO ()
putStrLn String
"Reattempting"
Bool -> IO ()
attempt Bool
True
Bool
True -> SomeException -> IO ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throw SomeException
e
)
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))
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) -> do
() -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Maybe JsonValue
_ -> do
String -> IO ()
putStrLn String
"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
Int
_ -> do
String -> IO ()
putStrLn String
"internal: Failed to post to Honeycomb"
Response -> InputStream Hostname -> IO ()
debugHandler Response
p InputStream Hostname
i