{-# 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 :: Token
headerHoneycombApiKey = [Baggage.token|x-honeycomb-team|]


headerHoneycombLegacyDataset :: Baggage.Token
headerHoneycombLegacyDataset :: Token
headerHoneycombLegacyDataset = [Baggage.token|x-honeycomb-dataset|]


-- | Honeycomb team name; generally appears in the URL after @ui.honeycomb.io/@.
newtype HoneycombTeam = HoneycombTeam {HoneycombTeam -> Text
unHoneycombTeam :: Text}
  deriving stock (Int -> HoneycombTeam -> ShowS
[HoneycombTeam] -> ShowS
HoneycombTeam -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HoneycombTeam] -> ShowS
$cshowList :: [HoneycombTeam] -> ShowS
show :: HoneycombTeam -> String
$cshow :: HoneycombTeam -> String
showsPrec :: Int -> HoneycombTeam -> ShowS
$cshowsPrec :: Int -> HoneycombTeam -> ShowS
Show, HoneycombTeam -> HoneycombTeam -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HoneycombTeam -> HoneycombTeam -> Bool
$c/= :: HoneycombTeam -> HoneycombTeam -> Bool
== :: HoneycombTeam -> HoneycombTeam -> Bool
$c== :: HoneycombTeam -> HoneycombTeam -> Bool
Eq)
  deriving newtype (String -> HoneycombTeam
forall a. (String -> a) -> IsString a
fromString :: String -> HoneycombTeam
$cfromString :: String -> HoneycombTeam
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 {EnvironmentName -> Text
unEnvironmentName :: Text}
  deriving stock (Int -> EnvironmentName -> ShowS
[EnvironmentName] -> ShowS
EnvironmentName -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EnvironmentName] -> ShowS
$cshowList :: [EnvironmentName] -> ShowS
show :: EnvironmentName -> String
$cshow :: EnvironmentName -> String
showsPrec :: Int -> EnvironmentName -> ShowS
$cshowsPrec :: Int -> EnvironmentName -> ShowS
Show, EnvironmentName -> EnvironmentName -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EnvironmentName -> EnvironmentName -> Bool
$c/= :: EnvironmentName -> EnvironmentName -> Bool
== :: EnvironmentName -> EnvironmentName -> Bool
$c== :: EnvironmentName -> EnvironmentName -> Bool
Eq)
  deriving newtype (String -> EnvironmentName
forall a. (String -> a) -> IsString a
fromString :: String -> EnvironmentName
$cfromString :: String -> EnvironmentName
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 :: forall (m :: * -> *).
MonadIO m =>
TracerProvider -> m (Maybe (Text, DatasetName))
getConfigPartsFromEnv TracerProvider
_ = do
  Maybe String
mheaders <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO (Maybe String)
lookupEnv String
"OTEL_EXPORTER_OTLP_HEADERS"
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ String -> Maybe (Text, DatasetName)
getValues forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe String
mheaders
  where
    discardLeft :: Either a a -> Maybe a
discardLeft (Left a
_) = forall a. Maybe a
Nothing
    discardLeft (Right a
a) = forall a. a -> Maybe a
Just a
a

    getValues :: String -> Maybe (Text, DatasetName)
getValues String
headers = do
      Baggage
baggage <- forall {a} {a}. Either a a -> Maybe a
discardLeft forall a b. (a -> b) -> a -> b
$ ByteString -> Either String Baggage
Baggage.decodeBaggageHeader (String -> ByteString
BS8.pack String
headers)
      Text
token <- Element -> Text
Baggage.value forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Token
headerHoneycombApiKey forall a b. (a -> b) -> a -> b
$ Baggage -> HashMap Token Element
Baggage.values Baggage
baggage)
      let dataset :: Text
dataset = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" Element -> Text
Baggage.value (forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Token
headerHoneycombLegacyDataset forall a b. (a -> b) -> a -> b
$ Baggage -> HashMap Token Element
Baggage.values Baggage
baggage)
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
token, Text -> DatasetName
DatasetName Text
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 :: forall (m :: * -> *).
MonadIO m =>
Config -> m (HoneycombTeam, Maybe EnvironmentName)
getHoneycombData Config
cfg = do
  Auth
auth <- forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT forall (m :: * -> *) client.
(MonadIO m, MonadHoneycombConfig client m) =>
m Auth
Auth.getAuth Config
cfg
  let envSlug :: Text
envSlug = NameAndSlug -> Text
Auth.slug forall b c a. (b -> c) -> (a -> b) -> a -> c
. Auth -> NameAndSlug
Auth.environment forall a b. (a -> b) -> a -> b
$ Auth
auth
      mEnvSlug :: Maybe EnvironmentName
mEnvSlug = if Text -> Bool
T.null Text
envSlug then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just (Text -> EnvironmentName
EnvironmentName Text
envSlug)

      team :: HoneycombTeam
team = Text -> HoneycombTeam
HoneycombTeam forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameAndSlug -> Text
Auth.slug forall b c a. (b -> c) -> (a -> b) -> a -> c
. Auth -> NameAndSlug
Auth.team forall a b. (a -> b) -> a -> b
$ Auth
auth
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (HoneycombTeam
team, Maybe EnvironmentName
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 :: forall (m :: * -> *).
MonadIO m =>
TracerProvider -> Config -> m (Maybe HoneycombTarget)
resolveHoneycombTarget TracerProvider
tracer Config
cfg = do
  (HoneycombTeam
team, Maybe EnvironmentName
mEnvName) <- forall (m :: * -> *).
MonadIO m =>
Config -> m (HoneycombTeam, Maybe EnvironmentName)
getHoneycombData Config
cfg
  let resources :: Attributes
resources = MaterializedResources -> Attributes
getMaterializedResourcesAttributes forall b c a. (b -> c) -> (a -> b) -> a -> c
. TracerProvider -> MaterializedResources
getTracerProviderResources forall a b. (a -> b) -> a -> b
$ TracerProvider
tracer
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    HoneycombTeam -> DatasetInfo -> HoneycombTarget
HoneycombTarget HoneycombTeam
team forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case Maybe EnvironmentName
mEnvName of
      -- There is an env name -> Current-Honeycomb
      Just EnvironmentName
envName -> do
        AttributeValue (TextAttribute Text
serviceName) <- Attributes -> Text -> Maybe Attribute
lookupAttribute Attributes
resources Text
"service.name"
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ EnvironmentName -> DatasetName -> DatasetInfo
Current EnvironmentName
envName (Text -> DatasetName
DatasetName Text
serviceName)
      -- Honeycomb Classic
      Maybe EnvironmentName
Nothing -> do
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ DatasetName -> DatasetInfo
Classic (Config -> DatasetName
Config.defaultDataset Config
cfg)


-- | Either a current-Honeycomb environment+dataset pair, or a Honeycomb Classic dataset
data DatasetInfo
  = Current EnvironmentName DatasetName
  | Classic DatasetName
  deriving stock (Int -> DatasetInfo -> ShowS
[DatasetInfo] -> ShowS
DatasetInfo -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DatasetInfo] -> ShowS
$cshowList :: [DatasetInfo] -> ShowS
show :: DatasetInfo -> String
$cshow :: DatasetInfo -> String
showsPrec :: Int -> DatasetInfo -> ShowS
$cshowsPrec :: Int -> DatasetInfo -> ShowS
Show, DatasetInfo -> DatasetInfo -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DatasetInfo -> DatasetInfo -> Bool
$c/= :: DatasetInfo -> DatasetInfo -> Bool
== :: DatasetInfo -> DatasetInfo -> Bool
$c== :: DatasetInfo -> DatasetInfo -> Bool
Eq)


-- | A fully qualified Honeycomb dataset, possibly with environment.
data HoneycombTarget = HoneycombTarget
  { HoneycombTarget -> HoneycombTeam
targetTeam :: HoneycombTeam
  , HoneycombTarget -> DatasetInfo
targetDataset :: DatasetInfo
  }
  deriving stock (Int -> HoneycombTarget -> ShowS
[HoneycombTarget] -> ShowS
HoneycombTarget -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HoneycombTarget] -> ShowS
$cshowList :: [HoneycombTarget] -> ShowS
show :: HoneycombTarget -> String
$cshow :: HoneycombTarget -> String
showsPrec :: Int -> HoneycombTarget -> ShowS
$cshowsPrec :: Int -> HoneycombTarget -> ShowS
Show, HoneycombTarget -> HoneycombTarget -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HoneycombTarget -> HoneycombTarget -> Bool
$c/= :: HoneycombTarget -> HoneycombTarget -> Bool
== :: HoneycombTarget -> HoneycombTarget -> Bool
$c== :: HoneycombTarget -> HoneycombTarget -> Bool
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 -> UTCTime -> TraceId -> ByteString
makeDirectTraceLink HoneycombTarget {DatasetInfo
HoneycombTeam
targetDataset :: DatasetInfo
targetTeam :: HoneycombTeam
targetDataset :: HoneycombTarget -> DatasetInfo
targetTeam :: HoneycombTarget -> HoneycombTeam
..} UTCTime
timestamp TraceId
traceId =
  case DatasetInfo
targetDataset of
    Current EnvironmentName
env DatasetName
ds ->
      ByteString
teamPrefix
        forall a. Semigroup a => a -> a -> a
<> ByteString
"/environments/"
        forall a. Semigroup a => a -> a -> a
<> (Text -> ByteString
encodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. EnvironmentName -> Text
unEnvironmentName forall a b. (a -> b) -> a -> b
$ EnvironmentName
env)
        forall a. Semigroup a => a -> a -> a
<> ByteString
"/datasets/"
        forall a. Semigroup a => a -> a -> a
<> (Text -> ByteString
encodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. DatasetName -> Text
fromDatasetName forall a b. (a -> b) -> a -> b
$ DatasetName
ds)
        forall a. Semigroup a => a -> a -> a
<> ByteString
"/trace"
        forall a. Semigroup a => a -> a -> a
<> ByteString
query
    Classic DatasetName
ds -> ByteString
teamPrefix forall a. Semigroup a => a -> a -> a
<> ByteString
"/datasets/" forall a. Semigroup a => a -> a -> a
<> (Text -> ByteString
encodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. DatasetName -> Text
fromDatasetName forall a b. (a -> b) -> a -> b
$ DatasetName
ds) forall a. Semigroup a => a -> a -> a
<> ByteString
"/trace" forall a. Semigroup a => a -> a -> a
<> ByteString
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 :: NominalDiffTime
oneHour = Pico -> NominalDiffTime
secondsToNominalDiffTime Pico
3600
    guessedStart :: UTCTime
guessedStart = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (-NominalDiffTime
oneHour) UTCTime
timestamp
    guessedEnd :: UTCTime
guessedEnd = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
oneHour UTCTime
timestamp
    convertTimestamp :: UTCTime -> ByteString
convertTimestamp = String -> ByteString
BS8.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show @Integer forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (RealFrac a, Integral b) => a -> b
truncate forall b c a. (b -> c) -> (a -> b) -> a -> c
. NominalDiffTime -> Pico
nominalDiffTimeToSeconds forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> NominalDiffTime
utcTimeToPOSIXSeconds

    teamPrefix :: ByteString
teamPrefix = ByteString
"https://ui.honeycomb.io/" forall a. Semigroup a => a -> a -> a
<> Text -> ByteString
encodeUtf8 (HoneycombTeam -> Text
unHoneycombTeam HoneycombTeam
targetTeam)
    query :: ByteString
query =
      URINormalizationOptions -> Query -> ByteString
serializeQuery' URINormalizationOptions
httpNormalization forall a b. (a -> b) -> a -> b
$
        [(ByteString, ByteString)] -> Query
Query
          [ (ByteString
"trace_id", Base -> TraceId -> ByteString
traceIdBaseEncodedByteString Base
Base16 TraceId
traceId)
          , (ByteString
"trace_start_ts", UTCTime -> ByteString
convertTimestamp UTCTime
guessedStart)
          , (ByteString
"trace_end_ts", UTCTime -> ByteString
convertTimestamp UTCTime
guessedEnd)
          ]


honeycombTargetKey :: Context.Key (Maybe HoneycombTarget)
honeycombTargetKey :: Key (Maybe HoneycombTarget)
honeycombTargetKey = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => Text -> m (Key a)
Context.newKey Text
"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 =>
  -- | Timeout for the operation before assuming Honeycomb is inaccessible
  NominalDiffTime ->
  m (Maybe HoneycombTarget)
getOrInitializeHoneycombTargetInContext :: forall (m :: * -> *).
MonadIO m =>
NominalDiffTime -> m (Maybe HoneycombTarget)
getOrInitializeHoneycombTargetInContext NominalDiffTime
theTimeout = do
  Maybe (Maybe HoneycombTarget)
mmTarget <- forall (m :: * -> *).
MonadIO m =>
m (Maybe (Maybe HoneycombTarget))
getHoneycombTargetInContext'
  case Maybe (Maybe HoneycombTarget)
mmTarget of
    -- It was fetched before (and possibly was Nothing)
    Just Maybe HoneycombTarget
t -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe HoneycombTarget
t
    -- It has not been fetched yet
    Maybe (Maybe HoneycombTarget)
Nothing -> do
      Maybe HoneycombTarget
mTarget <- forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. NominalDiffTime -> IO a -> IO (Maybe a)
timeoutMicroseconds NominalDiffTime
theTimeout IO (Maybe HoneycombTarget)
getTarget)
      forall (m :: * -> *). MonadIO m => (Context -> Context) -> m ()
TLContext.adjustContext (forall a. Key a -> a -> Context -> Context
Context.insert Key (Maybe HoneycombTarget)
honeycombTargetKey Maybe HoneycombTarget
mTarget)
      forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe HoneycombTarget
mTarget
  where
    microsecondsPerSecond :: Pico
microsecondsPerSecond = Pico
1000 forall a. Num a => a -> a -> a
* Pico
1000
    timeoutMicroseconds :: NominalDiffTime -> IO a -> IO (Maybe a)
    timeoutMicroseconds :: forall a. NominalDiffTime -> IO a -> IO (Maybe a)
timeoutMicroseconds NominalDiffTime
limit = forall a. Int -> IO a -> IO (Maybe a)
timeout (forall a b. (RealFrac a, Integral b) => a -> b
truncate forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> Pico
nominalDiffTimeToSeconds NominalDiffTime
limit forall a. Num a => a -> a -> a
* Pico
microsecondsPerSecond)

    getTarget :: IO (Maybe HoneycombTarget)
    getTarget :: IO (Maybe HoneycombTarget)
getTarget = forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT forall a b. (a -> b) -> a -> b
$ do
      TracerProvider
tracer <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (m :: * -> *). MonadIO m => m TracerProvider
getGlobalTracerProvider
      Config
theConfig <- forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Text -> DatasetName -> Config
config forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (forall (m :: * -> *).
MonadIO m =>
TracerProvider -> m (Maybe (Text, DatasetName))
getConfigPartsFromEnv TracerProvider
tracer)
      forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
TracerProvider -> Config -> m (Maybe HoneycombTarget)
resolveHoneycombTarget TracerProvider
tracer Config
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 :: forall (m :: * -> *). MonadIO m => m (Maybe HoneycombTarget)
getHoneycombTargetInContext = do
  forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
MonadIO m =>
m (Maybe (Maybe HoneycombTarget))
getHoneycombTargetInContext'


-- | Gets the thread-local context. The outer Maybe represents whether one has been set yet.
getHoneycombTargetInContext' :: MonadIO m => m (Maybe (Maybe HoneycombTarget))
getHoneycombTargetInContext' :: forall (m :: * -> *).
MonadIO m =>
m (Maybe (Maybe HoneycombTarget))
getHoneycombTargetInContext' = do
  forall a. Key a -> Context -> Maybe a
Context.lookup Key (Maybe HoneycombTarget)
honeycombTargetKey forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadIO m => m Context
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 :: forall (m :: * -> *). MonadIO m => m (Maybe ByteString)
getHoneycombLink = do
  Maybe HoneycombTarget
mTarget <- forall (m :: * -> *). MonadIO m => m (Maybe HoneycombTarget)
getHoneycombTargetInContext
  case Maybe HoneycombTarget
mTarget of
    Just HoneycombTarget
target -> forall (m :: * -> *).
MonadIO m =>
HoneycombTarget -> m (Maybe ByteString)
getHoneycombLink' HoneycombTarget
target
    Maybe HoneycombTarget
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing


-- | Gets a trace link for the current trace with an explicitly provided target.
getHoneycombLink' :: MonadIO m => HoneycombTarget -> m (Maybe ByteString)
getHoneycombLink' :: forall (m :: * -> *).
MonadIO m =>
HoneycombTarget -> m (Maybe ByteString)
getHoneycombLink' HoneycombTarget
target = do
  Maybe Span
theSpan <- Context -> Maybe Span
lookupSpan forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadIO m => m Context
TLContext.getContext
  Maybe TraceId
inTraceId <- Maybe Span -> m (Maybe TraceId)
traceIdForSpan Maybe Span
theSpan
  UTCTime
time <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime

  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ HoneycombTarget -> UTCTime -> TraceId -> ByteString
makeDirectTraceLink HoneycombTarget
target UTCTime
time forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe TraceId
inTraceId
  where
    traceIdForSpan :: Maybe Span -> m (Maybe TraceId)
traceIdForSpan = \case
      Just Span
s -> do
        SpanContext
spanCtx <- forall (m :: * -> *). MonadIO m => Span -> m SpanContext
getSpanContext Span
s
        -- if not sampled, it's not useful to give a link
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
          if TraceFlags -> Bool
isSampled (SpanContext -> TraceFlags
traceFlags SpanContext
spanCtx)
            then forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ SpanContext -> TraceId
traceId SpanContext
spanCtx
            else forall a. Maybe a
Nothing
      Maybe Span
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing