{-# 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
(Int -> HoneycombTeam -> ShowS)
-> (HoneycombTeam -> String)
-> ([HoneycombTeam] -> ShowS)
-> Show HoneycombTeam
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HoneycombTeam -> ShowS
showsPrec :: Int -> HoneycombTeam -> ShowS
$cshow :: HoneycombTeam -> String
show :: HoneycombTeam -> String
$cshowList :: [HoneycombTeam] -> ShowS
showList :: [HoneycombTeam] -> ShowS
Show, HoneycombTeam -> HoneycombTeam -> Bool
(HoneycombTeam -> HoneycombTeam -> Bool)
-> (HoneycombTeam -> HoneycombTeam -> Bool) -> Eq HoneycombTeam
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HoneycombTeam -> HoneycombTeam -> Bool
== :: HoneycombTeam -> HoneycombTeam -> Bool
$c/= :: HoneycombTeam -> HoneycombTeam -> Bool
/= :: HoneycombTeam -> HoneycombTeam -> Bool
Eq)
  deriving newtype (String -> HoneycombTeam
(String -> HoneycombTeam) -> IsString HoneycombTeam
forall a. (String -> a) -> IsString a
$cfromString :: String -> HoneycombTeam
fromString :: 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
(Int -> EnvironmentName -> ShowS)
-> (EnvironmentName -> String)
-> ([EnvironmentName] -> ShowS)
-> Show EnvironmentName
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> EnvironmentName -> ShowS
showsPrec :: Int -> EnvironmentName -> ShowS
$cshow :: EnvironmentName -> String
show :: EnvironmentName -> String
$cshowList :: [EnvironmentName] -> ShowS
showList :: [EnvironmentName] -> ShowS
Show, EnvironmentName -> EnvironmentName -> Bool
(EnvironmentName -> EnvironmentName -> Bool)
-> (EnvironmentName -> EnvironmentName -> Bool)
-> Eq EnvironmentName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: EnvironmentName -> EnvironmentName -> Bool
== :: EnvironmentName -> EnvironmentName -> Bool
$c/= :: EnvironmentName -> EnvironmentName -> Bool
/= :: EnvironmentName -> EnvironmentName -> Bool
Eq)
  deriving newtype (String -> EnvironmentName
(String -> EnvironmentName) -> IsString EnvironmentName
forall a. (String -> a) -> IsString a
$cfromString :: String -> EnvironmentName
fromString :: 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 <- IO (Maybe String) -> m (Maybe String)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe String) -> m (Maybe String))
-> IO (Maybe String) -> m (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> IO (Maybe String)
lookupEnv String
"OTEL_EXPORTER_OTLP_HEADERS"
  Maybe (Text, DatasetName) -> m (Maybe (Text, DatasetName))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Text, DatasetName) -> m (Maybe (Text, DatasetName)))
-> Maybe (Text, DatasetName) -> m (Maybe (Text, DatasetName))
forall a b. (a -> b) -> a -> b
$ String -> Maybe (Text, DatasetName)
getValues (String -> Maybe (Text, DatasetName))
-> Maybe String -> Maybe (Text, DatasetName)
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
_) = Maybe a
forall a. Maybe a
Nothing
    discardLeft (Right a
a) = a -> Maybe a
forall a. a -> Maybe a
Just a
a

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

      team :: HoneycombTeam
team = Text -> HoneycombTeam
HoneycombTeam (Text -> HoneycombTeam) -> (Auth -> Text) -> Auth -> HoneycombTeam
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameAndSlug -> Text
Auth.slug (NameAndSlug -> Text) -> (Auth -> NameAndSlug) -> Auth -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Auth -> NameAndSlug
Auth.team (Auth -> HoneycombTeam) -> Auth -> HoneycombTeam
forall a b. (a -> b) -> a -> b
$ Auth
auth
  (HoneycombTeam, Maybe EnvironmentName)
-> m (HoneycombTeam, Maybe EnvironmentName)
forall a. a -> m a
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) <- Config -> m (HoneycombTeam, Maybe EnvironmentName)
forall (m :: * -> *).
MonadIO m =>
Config -> m (HoneycombTeam, Maybe EnvironmentName)
getHoneycombData Config
cfg
  let resources :: Attributes
resources = MaterializedResources -> Attributes
getMaterializedResourcesAttributes (MaterializedResources -> Attributes)
-> (TracerProvider -> MaterializedResources)
-> TracerProvider
-> Attributes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TracerProvider -> MaterializedResources
getTracerProviderResources (TracerProvider -> Attributes) -> TracerProvider -> Attributes
forall a b. (a -> b) -> a -> b
$ TracerProvider
tracer
  Maybe HoneycombTarget -> m (Maybe HoneycombTarget)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe HoneycombTarget -> m (Maybe HoneycombTarget))
-> Maybe HoneycombTarget -> m (Maybe HoneycombTarget)
forall a b. (a -> b) -> a -> b
$
    HoneycombTeam -> DatasetInfo -> HoneycombTarget
HoneycombTarget HoneycombTeam
team (DatasetInfo -> HoneycombTarget)
-> Maybe DatasetInfo -> Maybe HoneycombTarget
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"
        DatasetInfo -> Maybe DatasetInfo
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DatasetInfo -> Maybe DatasetInfo)
-> DatasetInfo -> Maybe DatasetInfo
forall a b. (a -> b) -> a -> b
$ EnvironmentName -> DatasetName -> DatasetInfo
Current EnvironmentName
envName (Text -> DatasetName
DatasetName Text
serviceName)
      -- Honeycomb Classic
      Maybe EnvironmentName
Nothing -> do
        DatasetInfo -> Maybe DatasetInfo
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DatasetInfo -> Maybe DatasetInfo)
-> DatasetInfo -> Maybe DatasetInfo
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
(Int -> DatasetInfo -> ShowS)
-> (DatasetInfo -> String)
-> ([DatasetInfo] -> ShowS)
-> Show DatasetInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DatasetInfo -> ShowS
showsPrec :: Int -> DatasetInfo -> ShowS
$cshow :: DatasetInfo -> String
show :: DatasetInfo -> String
$cshowList :: [DatasetInfo] -> ShowS
showList :: [DatasetInfo] -> ShowS
Show, DatasetInfo -> DatasetInfo -> Bool
(DatasetInfo -> DatasetInfo -> Bool)
-> (DatasetInfo -> DatasetInfo -> Bool) -> Eq DatasetInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DatasetInfo -> DatasetInfo -> Bool
== :: DatasetInfo -> DatasetInfo -> Bool
$c/= :: DatasetInfo -> DatasetInfo -> Bool
/= :: 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
(Int -> HoneycombTarget -> ShowS)
-> (HoneycombTarget -> String)
-> ([HoneycombTarget] -> ShowS)
-> Show HoneycombTarget
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HoneycombTarget -> ShowS
showsPrec :: Int -> HoneycombTarget -> ShowS
$cshow :: HoneycombTarget -> String
show :: HoneycombTarget -> String
$cshowList :: [HoneycombTarget] -> ShowS
showList :: [HoneycombTarget] -> ShowS
Show, HoneycombTarget -> HoneycombTarget -> Bool
(HoneycombTarget -> HoneycombTarget -> Bool)
-> (HoneycombTarget -> HoneycombTarget -> Bool)
-> Eq HoneycombTarget
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HoneycombTarget -> HoneycombTarget -> Bool
== :: HoneycombTarget -> HoneycombTarget -> Bool
$c/= :: HoneycombTarget -> HoneycombTarget -> Bool
/= :: 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
targetTeam :: HoneycombTarget -> HoneycombTeam
targetDataset :: HoneycombTarget -> DatasetInfo
targetTeam :: HoneycombTeam
targetDataset :: DatasetInfo
..} UTCTime
timestamp TraceId
traceId =
  case DatasetInfo
targetDataset of
    Current EnvironmentName
env DatasetName
ds ->
      ByteString
teamPrefix
        ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"/environments/"
        ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> (Text -> ByteString
encodeUtf8 (Text -> ByteString)
-> (EnvironmentName -> Text) -> EnvironmentName -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EnvironmentName -> Text
unEnvironmentName (EnvironmentName -> ByteString) -> EnvironmentName -> ByteString
forall a b. (a -> b) -> a -> b
$ EnvironmentName
env)
        ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"/datasets/"
        ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> (Text -> ByteString
encodeUtf8 (Text -> ByteString)
-> (DatasetName -> Text) -> DatasetName -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DatasetName -> Text
fromDatasetName (DatasetName -> ByteString) -> DatasetName -> ByteString
forall a b. (a -> b) -> a -> b
$ DatasetName
ds)
        ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"/trace"
        ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
query
    Classic DatasetName
ds -> ByteString
teamPrefix ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"/datasets/" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> (Text -> ByteString
encodeUtf8 (Text -> ByteString)
-> (DatasetName -> Text) -> DatasetName -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DatasetName -> Text
fromDatasetName (DatasetName -> ByteString) -> DatasetName -> ByteString
forall a b. (a -> b) -> a -> b
$ DatasetName
ds) ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"/trace" ByteString -> ByteString -> ByteString
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 (String -> ByteString)
-> (UTCTime -> String) -> UTCTime -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show @Integer (Integer -> String) -> (UTCTime -> Integer) -> UTCTime -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pico -> Integer
forall b. Integral b => Pico -> b
forall a b. (RealFrac a, Integral b) => a -> b
truncate (Pico -> Integer) -> (UTCTime -> Pico) -> UTCTime -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NominalDiffTime -> Pico
nominalDiffTimeToSeconds (NominalDiffTime -> Pico)
-> (UTCTime -> NominalDiffTime) -> UTCTime -> Pico
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> NominalDiffTime
utcTimeToPOSIXSeconds

    teamPrefix :: ByteString
teamPrefix = ByteString
"https://ui.honeycomb.io/" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Text -> ByteString
encodeUtf8 (HoneycombTeam -> Text
unHoneycombTeam HoneycombTeam
targetTeam)
    query :: ByteString
query =
      URINormalizationOptions -> Query -> ByteString
serializeQuery' URINormalizationOptions
httpNormalization (Query -> ByteString) -> Query -> ByteString
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 = IO (Key (Maybe HoneycombTarget)) -> Key (Maybe HoneycombTarget)
forall a. IO a -> a
unsafePerformIO (IO (Key (Maybe HoneycombTarget)) -> Key (Maybe HoneycombTarget))
-> IO (Key (Maybe HoneycombTarget)) -> Key (Maybe HoneycombTarget)
forall a b. (a -> b) -> a -> b
$ Text -> IO (Key (Maybe HoneycombTarget))
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)
  => NominalDiffTime
  -- ^ Timeout for the operation before assuming Honeycomb is inaccessible
  -> m (Maybe HoneycombTarget)
getOrInitializeHoneycombTargetInContext :: forall (m :: * -> *).
MonadIO m =>
NominalDiffTime -> m (Maybe HoneycombTarget)
getOrInitializeHoneycombTargetInContext NominalDiffTime
theTimeout = do
  Maybe (Maybe HoneycombTarget)
mmTarget <- m (Maybe (Maybe HoneycombTarget))
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 -> Maybe HoneycombTarget -> m (Maybe HoneycombTarget)
forall a. a -> m a
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 <- Maybe (Maybe HoneycombTarget) -> Maybe HoneycombTarget
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe HoneycombTarget) -> Maybe HoneycombTarget)
-> m (Maybe (Maybe HoneycombTarget)) -> m (Maybe HoneycombTarget)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Maybe (Maybe HoneycombTarget))
-> m (Maybe (Maybe HoneycombTarget))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (NominalDiffTime
-> IO (Maybe HoneycombTarget) -> IO (Maybe (Maybe HoneycombTarget))
forall a. NominalDiffTime -> IO a -> IO (Maybe a)
timeoutMicroseconds NominalDiffTime
theTimeout IO (Maybe HoneycombTarget)
getTarget)
      (Context -> Context) -> m ()
forall (m :: * -> *). MonadIO m => (Context -> Context) -> m ()
TLContext.adjustContext (Key (Maybe HoneycombTarget)
-> Maybe HoneycombTarget -> Context -> Context
forall a. Key a -> a -> Context -> Context
Context.insert Key (Maybe HoneycombTarget)
honeycombTargetKey Maybe HoneycombTarget
mTarget)
      Maybe HoneycombTarget -> m (Maybe HoneycombTarget)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe HoneycombTarget
mTarget
  where
    microsecondsPerSecond :: Pico
microsecondsPerSecond = Pico
1000 Pico -> Pico -> Pico
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 = Int -> IO a -> IO (Maybe a)
forall a. Int -> IO a -> IO (Maybe a)
timeout (Pico -> Int
forall b. Integral b => Pico -> b
forall a b. (RealFrac a, Integral b) => a -> b
truncate (Pico -> Int) -> Pico -> Int
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> Pico
nominalDiffTimeToSeconds NominalDiffTime
limit Pico -> Pico -> Pico
forall a. Num a => a -> a -> a
* Pico
microsecondsPerSecond)

    getTarget :: IO (Maybe HoneycombTarget)
    getTarget :: IO (Maybe HoneycombTarget)
getTarget = MaybeT IO HoneycombTarget -> IO (Maybe HoneycombTarget)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT IO HoneycombTarget -> IO (Maybe HoneycombTarget))
-> MaybeT IO HoneycombTarget -> IO (Maybe HoneycombTarget)
forall a b. (a -> b) -> a -> b
$ do
      TracerProvider
tracer <- IO TracerProvider -> MaybeT IO TracerProvider
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift IO TracerProvider
forall (m :: * -> *). MonadIO m => m TracerProvider
getGlobalTracerProvider
      Config
theConfig <- (Text -> DatasetName -> Config) -> (Text, DatasetName) -> Config
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Text -> DatasetName -> Config
config ((Text, DatasetName) -> Config)
-> MaybeT IO (Text, DatasetName) -> MaybeT IO Config
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Maybe (Text, DatasetName)) -> MaybeT IO (Text, DatasetName)
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (TracerProvider -> IO (Maybe (Text, DatasetName))
forall (m :: * -> *).
MonadIO m =>
TracerProvider -> m (Maybe (Text, DatasetName))
getConfigPartsFromEnv TracerProvider
tracer)
      IO (Maybe HoneycombTarget) -> MaybeT IO HoneycombTarget
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe HoneycombTarget) -> MaybeT IO HoneycombTarget)
-> IO (Maybe HoneycombTarget) -> MaybeT IO HoneycombTarget
forall a b. (a -> b) -> a -> b
$ TracerProvider -> Config -> IO (Maybe HoneycombTarget)
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
  Maybe (Maybe HoneycombTarget) -> Maybe HoneycombTarget
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe HoneycombTarget) -> Maybe HoneycombTarget)
-> m (Maybe (Maybe HoneycombTarget)) -> m (Maybe HoneycombTarget)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Maybe (Maybe HoneycombTarget))
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
  Key (Maybe HoneycombTarget)
-> Context -> Maybe (Maybe HoneycombTarget)
forall a. Key a -> Context -> Maybe a
Context.lookup Key (Maybe HoneycombTarget)
honeycombTargetKey (Context -> Maybe (Maybe HoneycombTarget))
-> m Context -> m (Maybe (Maybe HoneycombTarget))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Context
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 <- m (Maybe HoneycombTarget)
forall (m :: * -> *). MonadIO m => m (Maybe HoneycombTarget)
getHoneycombTargetInContext
  case Maybe HoneycombTarget
mTarget of
    Just HoneycombTarget
target -> HoneycombTarget -> m (Maybe ByteString)
forall (m :: * -> *).
MonadIO m =>
HoneycombTarget -> m (Maybe ByteString)
getHoneycombLink' HoneycombTarget
target
    Maybe HoneycombTarget
Nothing -> Maybe ByteString -> m (Maybe ByteString)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ByteString
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 (Context -> Maybe Span) -> m Context -> m (Maybe Span)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Context
forall (m :: * -> *). MonadIO m => m Context
TLContext.getContext
  Maybe TraceId
inTraceId <- Maybe Span -> m (Maybe TraceId)
traceIdForSpan Maybe Span
theSpan
  UTCTime
time <- IO UTCTime -> m UTCTime
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime

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