{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
{- | Vendor integration for Honeycomb.
This lets you link to traces. You don't need this to send data to Honeycomb,
for which @hs-opentelemetry-exporter-otlp@ is suitable.
-}
module OpenTelemetry.Vendor.Honeycomb (
-- * Types
HoneycombTeam (..),
EnvironmentName (..),
-- * Getting the Honeycomb target dataset/team name
getOrInitializeHoneycombTargetInContext,
getHoneycombTargetInContext,
-- ** Detailed API
getConfigPartsFromEnv,
getHoneycombData,
resolveHoneycombTarget,
DatasetInfo (..),
HoneycombTarget (..),
-- * Making trace links
makeDirectTraceLink,
getHoneycombLink,
getHoneycombLink',
-- * Performing manual Honeycomb requests
module Auth,
module Config,
) where
import Control.Monad (join)
import Control.Monad.Reader (MonadIO (..), MonadTrans (..), ReaderT (runReaderT))
import Control.Monad.Trans.Maybe (MaybeT (..))
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BS8
import qualified Data.HashMap.Strict as HM
import Data.String (IsString)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import Data.Time.Clock
import Data.Time.Clock.POSIX
import Honeycomb.API.Auth as Auth
import Honeycomb.Config as Config
import Honeycomb.Types (DatasetName (..))
import OpenTelemetry.Attributes (
Attribute (AttributeValue),
PrimitiveAttribute (TextAttribute),
lookupAttribute,
)
import qualified OpenTelemetry.Baggage as Baggage
import OpenTelemetry.Context (lookupSpan)
import qualified OpenTelemetry.Context as Context
import qualified OpenTelemetry.Context.ThreadLocal as TLContext
import OpenTelemetry.Resource (
getMaterializedResourcesAttributes,
)
import OpenTelemetry.Trace.Core (
TracerProvider,
getGlobalTracerProvider,
getSpanContext,
getTracerProviderResources,
isSampled,
traceFlags,
traceId,
)
import OpenTelemetry.Trace.Id (Base (..), TraceId, traceIdBaseEncodedByteString)
import System.Environment (lookupEnv)
import System.IO.Unsafe (unsafePerformIO)
import System.Timeout (timeout)
import URI.ByteString (Query (..), httpNormalization, serializeQuery')
import Prelude
headerHoneycombApiKey :: Baggage.Token
headerHoneycombApiKey = [Baggage.token|x-honeycomb-team|]
headerHoneycombLegacyDataset :: Baggage.Token
headerHoneycombLegacyDataset = [Baggage.token|x-honeycomb-dataset|]
-- | Honeycomb team name; generally appears in the URL after @ui.honeycomb.io/@.
newtype HoneycombTeam = HoneycombTeam {unHoneycombTeam :: Text}
deriving stock (Show, Eq)
deriving newtype (IsString)
{- | Environment name in the Environments & Services data model (referred to as
\"Current\" in this package).
See https://docs.honeycomb.io/honeycomb-classic/ for more details.
-}
newtype EnvironmentName = EnvironmentName {unEnvironmentName :: Text}
deriving stock (Show, Eq)
deriving newtype (IsString)
{- | Gets the Honeycomb configuration from the environment.
This does not do any HTTP.
FIXME(jadel): This should ideally fetch this from the tracer provider, but
it's nonobvious how to architect being able to do that (requires changes in
hs-opentelemetry-api). For now let's take a Tracer such that we
can fix it later, then do it the obvious way.
-}
getConfigPartsFromEnv :: (MonadIO m) => TracerProvider -> m (Maybe (Text, DatasetName))
getConfigPartsFromEnv _ = do
mheaders <- liftIO $ lookupEnv "OTEL_EXPORTER_OTLP_HEADERS"
pure $ getValues =<< mheaders
where
discardLeft (Left _) = Nothing
discardLeft (Right a) = Just a
getValues headers = do
baggage <- discardLeft $ Baggage.decodeBaggageHeader (BS8.pack headers)
token <- Baggage.value <$> (HM.lookup headerHoneycombApiKey $ Baggage.values baggage)
let dataset = maybe "" Baggage.value (HM.lookup headerHoneycombLegacyDataset $ Baggage.values baggage)
pure (token, DatasetName dataset)
{- | Gets the team name and environment name for the OTLP exporter using the API
key from the environment.
This calls Honeycomb.
N.B. Use 'Config.config' to construct a config from 'getConfigPartsFromEnv'.
N.B. The EnvironmentName will be Nothing if the API key is for a Honeycomb
Classic instance.
-}
getHoneycombData :: (MonadIO m) => Config.Config -> m (HoneycombTeam, Maybe EnvironmentName)
getHoneycombData cfg = do
auth <- runReaderT Auth.getAuth cfg
let envSlug = Auth.slug . Auth.environment $ auth
mEnvSlug = if T.null envSlug then Nothing else Just (EnvironmentName envSlug)
team = HoneycombTeam . Auth.slug . Auth.team $ auth
pure (team, mEnvSlug)
{- | Takes a 'Config.Config' and pokes around both Honeycomb HTTP API and the
trace environment to figure out where events will land in Honeycomb.
-}
resolveHoneycombTarget :: (MonadIO m) => TracerProvider -> Config.Config -> m (Maybe HoneycombTarget)
resolveHoneycombTarget tracer cfg = do
(team, mEnvName) <- getHoneycombData cfg
let resources = getMaterializedResourcesAttributes . getTracerProviderResources $ tracer
pure $
HoneycombTarget team <$> case mEnvName of
-- There is an env name -> Current-Honeycomb
Just envName -> do
AttributeValue (TextAttribute serviceName) <- lookupAttribute resources "service.name"
pure $ Current envName (DatasetName serviceName)
-- Honeycomb Classic
Nothing -> do
pure $ Classic (Config.defaultDataset cfg)
-- | Either a current-Honeycomb environment+dataset pair, or a Honeycomb Classic dataset
data DatasetInfo
= Current EnvironmentName DatasetName
| Classic DatasetName
deriving stock (Show, Eq)
-- | A fully qualified Honeycomb dataset, possibly with environment.
data HoneycombTarget = HoneycombTarget
{ targetTeam :: HoneycombTeam
, targetDataset :: DatasetInfo
}
deriving stock (Show, Eq)
{- | Formats a direct link to a trace.
See https://docs.honeycomb.io/api/direct-trace-links/ for more details.
The URLs generated will look like the following:
Honeycomb Current:
> https://ui.honeycomb.io/<team>/environments/<environment>/datasets/<dataset>/trace
> ?trace_id=<traceId>
> &trace_start_ts=<ts>
> &trace_end_ts=<ts>
Honeycomb Classic:
> https://ui.honeycomb.io/<team>/datasets/<dataset>/trace
> ?trace_id=<traceId>
> &trace_start_ts=<ts>
> &trace_end_ts=<ts>
-}
makeDirectTraceLink :: HoneycombTarget -> UTCTime -> TraceId -> ByteString
makeDirectTraceLink HoneycombTarget {..} timestamp traceId =
case targetDataset of
Current env ds ->
teamPrefix
<> "/environments/"
<> (encodeUtf8 . unEnvironmentName $ env)
<> "/datasets/"
<> (encodeUtf8 . fromDatasetName $ ds)
<> "/trace"
<> query
Classic ds -> teamPrefix <> "/datasets/" <> (encodeUtf8 . fromDatasetName $ ds) <> "/trace" <> query
where
-- XXX(jadel): I feel like there's not really any way to know what these
-- actual values are, even if we are omniscient of the Haskell application.
-- For instance, if someone else calls us, we simply don't know when the
-- trace started. So it's kind of a fool's errand. Let's just give ± 1hr and
-- call it a day.
oneHour = secondsToNominalDiffTime 3600
guessedStart = addUTCTime (-oneHour) timestamp
guessedEnd = addUTCTime oneHour timestamp
convertTimestamp = BS8.pack . show @Integer . truncate . nominalDiffTimeToSeconds . utcTimeToPOSIXSeconds
teamPrefix = "https://ui.honeycomb.io/" <> encodeUtf8 (unHoneycombTeam targetTeam)
query =
serializeQuery' httpNormalization $
Query
[ ("trace_id", traceIdBaseEncodedByteString Base16 traceId)
, ("trace_start_ts", convertTimestamp guessedStart)
, ("trace_end_ts", convertTimestamp guessedEnd)
]
honeycombTargetKey :: Context.Key (Maybe HoneycombTarget)
honeycombTargetKey = unsafePerformIO $ Context.newKey "honeycombTarget"
{-# NOINLINE honeycombTargetKey #-}
{- | Gets or initializes the Honeycomb target in the thread-local
'Context.Context'.
This should be called inside the root span at application startup in order to
ensure that this context is the parent of all child contexts in which you might
want to get the target (for instance to generate Honeycomb links).
-}
getOrInitializeHoneycombTargetInContext
:: (MonadIO m)
=> NominalDiffTime
-- ^ Timeout for the operation before assuming Honeycomb is inaccessible
-> m (Maybe HoneycombTarget)
getOrInitializeHoneycombTargetInContext theTimeout = do
mmTarget <- getHoneycombTargetInContext'
case mmTarget of
-- It was fetched before (and possibly was Nothing)
Just t -> pure t
-- It has not been fetched yet
Nothing -> do
mTarget <- join <$> liftIO (timeoutMicroseconds theTimeout getTarget)
TLContext.adjustContext (Context.insert honeycombTargetKey mTarget)
pure mTarget
where
microsecondsPerSecond = 1000 * 1000
timeoutMicroseconds :: NominalDiffTime -> IO a -> IO (Maybe a)
timeoutMicroseconds limit = timeout (truncate $ nominalDiffTimeToSeconds limit * microsecondsPerSecond)
getTarget :: IO (Maybe HoneycombTarget)
getTarget = runMaybeT $ do
tracer <- lift getGlobalTracerProvider
theConfig <- uncurry config <$> MaybeT (getConfigPartsFromEnv tracer)
MaybeT $ resolveHoneycombTarget tracer theConfig
{- | Simple function to get the Honeycomb target out of the global context.
At application startup, run 'getOrInitializeHoneycombTargetInContext' before
calling this, or else you will get 'Nothing'.
This is the right function for most use cases.
-}
getHoneycombTargetInContext :: (MonadIO m) => m (Maybe HoneycombTarget)
getHoneycombTargetInContext = do
join <$> getHoneycombTargetInContext'
-- | Gets the thread-local context. The outer Maybe represents whether one has been set yet.
getHoneycombTargetInContext' :: (MonadIO m) => m (Maybe (Maybe HoneycombTarget))
getHoneycombTargetInContext' = do
Context.lookup honeycombTargetKey <$> TLContext.getContext
{- | Gets a trace link for the current trace.
Needs to have the thread-local target initialized; see
'getOrInitializeHoneycombTargetInContext'.
-}
getHoneycombLink :: (MonadIO m) => m (Maybe ByteString)
getHoneycombLink = do
mTarget <- getHoneycombTargetInContext
case mTarget of
Just target -> getHoneycombLink' target
Nothing -> pure Nothing
-- | Gets a trace link for the current trace with an explicitly provided target.
getHoneycombLink' :: (MonadIO m) => HoneycombTarget -> m (Maybe ByteString)
getHoneycombLink' target = do
theSpan <- lookupSpan <$> TLContext.getContext
inTraceId <- traceIdForSpan theSpan
time <- liftIO getCurrentTime
pure $ makeDirectTraceLink target time <$> inTraceId
where
traceIdForSpan = \case
Just s -> do
spanCtx <- getSpanContext s
-- if not sampled, it's not useful to give a link
pure $
if isSampled (traceFlags spanCtx)
then Just $ traceId spanCtx
else Nothing
Nothing -> pure Nothing