{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}

module OpenTelemetry.Eventlog
  ( -- * Spans
    beginSpan,
    endSpan,
    withSpan,
    withSpan_,
    setSpanId,
    setTraceId,
    setTag,
    addEvent,
    setParentSpanContext,
    SpanInFlight (..),

    -- * Metrics
    mkCounter,
    mkUpDownCounter,
    mkValueRecorder,
    mkSumObserver,
    mkUpDownSumObserver,
    mkValueObserver,
    add,
    record,
    observe,
    MI.Instrument,
    MI.SomeInstrument (..),
    MI.Counter,
    MI.UpDownCounter,
    MI.ValueRecorder,
    MI.SumObserver,
    MI.UpDownSumObserver,
    MI.ValueObserver,
    MI.Synchronicity (..),
    MI.Additivity (..),
    MI.Monotonicity (..),
    MI.InstrumentName,
    MI.InstrumentId,
    MI.instrumentName,
    MI.instrumentId,
  )
where

import Control.Monad.Catch
import Control.Monad.IO.Class
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS8
import OpenTelemetry.Eventlog_Internal (SpanInFlight (..))
import qualified OpenTelemetry.Eventlog_Internal as I
import qualified OpenTelemetry.Metrics_Internal as MI
import OpenTelemetry.SpanContext
import Prelude hiding (span)

#if __GLASGOW_HASKELL__ < 808

import Data.Unique
import Debug.Trace
import OpenTelemetry.Metrics_Internal

beginSpan :: MonadIO m => String -> m SpanInFlight
beginSpan operation = do
  u64 <- fromIntegral . hashUnique <$> liftIO newUnique
  liftIO $ traceEventIO (I.beginSpan' (SpanInFlight u64) operation)
  pure $ SpanInFlight u64

endSpan :: MonadIO m => SpanInFlight -> m ()
endSpan = liftIO . traceEventIO . I.endSpan'

setTag :: MonadIO m => SpanInFlight -> String -> BS.ByteString -> m ()
setTag sp k v = liftIO . traceEventIO $ I.setTag' sp k v

addEvent :: MonadIO m => SpanInFlight -> String -> BS.ByteString -> m ()
addEvent sp k v = liftIO . traceEventIO $ I.addEvent' sp k v

setParentSpanContext :: MonadIO m => SpanInFlight -> SpanContext -> m ()
setParentSpanContext sp ctx = liftIO . traceEventIO $ I.setParentSpanContext' sp ctx

setTraceId :: MonadIO m => SpanInFlight -> TraceId -> m ()
setTraceId sp tid = liftIO . traceEventIO $ I.setTraceId' sp tid

setSpanId :: MonadIO m => SpanInFlight -> SpanId -> m ()
setSpanId sp sid = liftIO . traceEventIO $ I.setSpanId' sp sid

createInstrument :: MonadIO io => MI.Instrument s a m -> io ()
createInstrument = liftIO . traceEventIO . I.createInstrument'

writeMetric :: MonadIO io => MI.Instrument s a m -> Int -> io ()
writeMetric i v = liftIO $ traceEventIO $ I.writeMetric' (instrumentId i) v

mkCounter :: MonadIO m => MI.InstrumentName -> m MI.Counter
mkCounter name = do
  inst <- MI.Counter name <$> I.nextInstrumentId
  createInstrument inst
  return inst

mkUpDownCounter :: MonadIO m => MI.InstrumentName -> m MI.UpDownCounter
mkUpDownCounter name = do
  inst <- MI.UpDownCounter name <$> I.nextInstrumentId
  createInstrument inst
  return inst

mkValueRecorder :: MonadIO m => MI.InstrumentName -> m MI.ValueRecorder
mkValueRecorder name = do
  inst <- MI.ValueRecorder name <$> I.nextInstrumentId
  createInstrument inst
  return inst

mkSumObserver :: MonadIO m => MI.InstrumentName -> m MI.SumObserver
mkSumObserver name = do
  inst <- MI.SumObserver name <$> I.nextInstrumentId
  createInstrument inst
  return inst

mkUpDownSumObserver :: MonadIO m => MI.InstrumentName -> m MI.UpDownSumObserver
mkUpDownSumObserver name = do
  inst <- MI.UpDownSumObserver name <$> I.nextInstrumentId
  createInstrument inst
  return inst

mkValueObserver :: MonadIO m => MI.InstrumentName -> m MI.ValueObserver
mkValueObserver name = do
  inst <- MI.ValueObserver name <$> I.nextInstrumentId
  createInstrument inst
  return inst

-- | Take a measurement for a synchronous, additive instrument ('Counter', 'UpDowncounter')
add :: MonadIO io => MI.Instrument 'MI.Synchronous 'MI.Additive m' -> Int -> io ()
add = writeMetric

-- | Take a measurement for a synchronous, non-additive instrument ('ValueRecorder')
record :: MonadIO io => MI.Instrument 'MI.Synchronous 'MI.NonAdditive m' -> Int -> io ()
record = writeMetric

-- | Take a measurement for an asynchronous instrument ('SumObserver', 'UpDownSumObserver', 'ValueObserver')
observe :: MonadIO io => MI.Instrument 'MI.Asynchronous a m' -> Int -> io ()
observe = writeMetric

withSpan :: forall m a. (MonadIO m, MonadMask m) => String -> (SpanInFlight -> m a) -> m a
withSpan operation action =
  fst
    <$> generalBracket
      (liftIO $ beginSpan operation)
      ( \span exitcase -> liftIO $ do
          case exitcase of
            ExitCaseSuccess _ -> pure ()
            ExitCaseException e -> do
              setTag span "error" "true"
              setTag span "error.message" (BS8.pack $ show e)
            ExitCaseAbort -> do
              setTag span "error" "true"
              setTag span "error.message" "abort"
          liftIO $ endSpan span
      )
      action

withSpan_ :: (MonadIO m, MonadMask m) => String -> m a -> m a
withSpan_ operation action = withSpan operation (const action)

#else

{-# INLINE withSpan #-}
withSpan ::
  forall m a.
  (MonadIO m, MonadMask m) =>
  BS.ByteString ->
  (SpanInFlight -> m a) ->
  m a
withSpan :: ByteString -> (SpanInFlight -> m a) -> m a
withSpan ByteString
operation SpanInFlight -> m a
action =
  (a, ()) -> a
forall a b. (a, b) -> a
fst
    ((a, ()) -> a) -> m (a, ()) -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m SpanInFlight
-> (SpanInFlight -> ExitCase a -> m ())
-> (SpanInFlight -> m a)
-> m (a, ())
forall (m :: * -> *) a b c.
MonadMask m =>
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c)
generalBracket
      (IO SpanInFlight -> m SpanInFlight
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO SpanInFlight -> m SpanInFlight)
-> IO SpanInFlight -> m SpanInFlight
forall a b. (a -> b) -> a -> b
$ ByteString -> IO SpanInFlight
forall (m :: * -> *). MonadIO m => ByteString -> m SpanInFlight
beginSpan ByteString
operation)
      ( \SpanInFlight
sp ExitCase a
exitcase -> IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
          case ExitCase a
exitcase of
            ExitCaseSuccess a
_ -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            ExitCaseException SomeException
e -> do
              SpanInFlight -> ByteString -> ByteString -> IO ()
forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
setTag SpanInFlight
sp ByteString
"error" ByteString
"true"
              SpanInFlight -> ByteString -> ByteString -> IO ()
forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
setTag SpanInFlight
sp ByteString
"error.message" (String -> ByteString
BS8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
I.maxMsgLen (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall a. Show a => a -> String
show SomeException
e)
            ExitCase a
ExitCaseAbort -> do
              SpanInFlight -> ByteString -> ByteString -> IO ()
forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
setTag SpanInFlight
sp ByteString
"error" ByteString
"true"
              SpanInFlight -> ByteString -> ByteString -> IO ()
forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
setTag SpanInFlight
sp ByteString
"error.message" ByteString
"abort"
          IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ SpanInFlight -> IO ()
forall (m :: * -> *). MonadIO m => SpanInFlight -> m ()
endSpan SpanInFlight
sp
      )
      SpanInFlight -> m a
action

{-# INLINE withSpan_ #-}
withSpan_ :: (MonadIO m, MonadMask m) => BS.ByteString -> m a -> m a
withSpan_ :: ByteString -> m a -> m a
withSpan_ ByteString
operation m a
action = ByteString -> (SpanInFlight -> m a) -> m a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
ByteString -> (SpanInFlight -> m a) -> m a
withSpan ByteString
operation (m a -> SpanInFlight -> m a
forall a b. a -> b -> a
const m a
action)

{-# INLINE setSpanId #-}
setSpanId :: MonadIO m => SpanInFlight -> SpanId -> m ()
setSpanId :: SpanInFlight -> SpanId -> m ()
setSpanId SpanInFlight
sp SpanId
sid = Builder -> m ()
forall (m :: * -> *). MonadIO m => Builder -> m ()
I.traceBuilder (Builder -> m ()) -> Builder -> m ()
forall a b. (a -> b) -> a -> b
$ SpanInFlight -> SpanId -> Builder
I.builder_setSpanId SpanInFlight
sp SpanId
sid

{-# INLINE setTraceId #-}
setTraceId :: MonadIO m => SpanInFlight -> TraceId -> m ()
setTraceId :: SpanInFlight -> TraceId -> m ()
setTraceId SpanInFlight
sp TraceId
tid = Builder -> m ()
forall (m :: * -> *). MonadIO m => Builder -> m ()
I.traceBuilder (Builder -> m ()) -> Builder -> m ()
forall a b. (a -> b) -> a -> b
$ SpanInFlight -> TraceId -> Builder
I.builder_setTraceId SpanInFlight
sp TraceId
tid

{-# INLINE beginSpan #-}
beginSpan :: MonadIO m => BS.ByteString -> m SpanInFlight
beginSpan :: ByteString -> m SpanInFlight
beginSpan ByteString
operation = do
  SpanInFlight
u <- m SpanInFlight
forall (m :: * -> *). MonadIO m => m SpanInFlight
I.nextLocalSpan
  Builder -> m ()
forall (m :: * -> *). MonadIO m => Builder -> m ()
I.traceBuilder (Builder -> m ()) -> Builder -> m ()
forall a b. (a -> b) -> a -> b
$ SpanInFlight -> ByteString -> Builder
I.builder_beginSpan SpanInFlight
u ByteString
operation
  SpanInFlight -> m SpanInFlight
forall (f :: * -> *) a. Applicative f => a -> f a
pure SpanInFlight
u

{-# INLINE endSpan #-}
endSpan :: MonadIO m => SpanInFlight -> m ()
endSpan :: SpanInFlight -> m ()
endSpan SpanInFlight
sp = Builder -> m ()
forall (m :: * -> *). MonadIO m => Builder -> m ()
I.traceBuilder (Builder -> m ()) -> Builder -> m ()
forall a b. (a -> b) -> a -> b
$ SpanInFlight -> Builder
I.builder_endSpan SpanInFlight
sp

{-# INLINE setTag #-}
setTag :: MonadIO m => SpanInFlight -> BS.ByteString -> BS.ByteString -> m ()
setTag :: SpanInFlight -> ByteString -> ByteString -> m ()
setTag SpanInFlight
sp ByteString
k ByteString
v = Builder -> m ()
forall (m :: * -> *). MonadIO m => Builder -> m ()
I.traceBuilder (Builder -> m ()) -> Builder -> m ()
forall a b. (a -> b) -> a -> b
$ SpanInFlight -> ByteString -> ByteString -> Builder
I.builder_setTag SpanInFlight
sp ByteString
k ByteString
v

{-# INLINE addEvent #-}
addEvent :: MonadIO m => SpanInFlight -> BS.ByteString -> BS.ByteString -> m ()
addEvent :: SpanInFlight -> ByteString -> ByteString -> m ()
addEvent SpanInFlight
sp ByteString
k ByteString
v = Builder -> m ()
forall (m :: * -> *). MonadIO m => Builder -> m ()
I.traceBuilder (Builder -> m ()) -> Builder -> m ()
forall a b. (a -> b) -> a -> b
$ SpanInFlight -> ByteString -> ByteString -> Builder
I.builder_addEvent SpanInFlight
sp ByteString
k ByteString
v

{-# INLINE setParentSpanContext #-}
setParentSpanContext :: MonadIO m => SpanInFlight -> SpanContext -> m ()
setParentSpanContext :: SpanInFlight -> SpanContext -> m ()
setParentSpanContext SpanInFlight
sp SpanContext
ctx = Builder -> m ()
forall (m :: * -> *). MonadIO m => Builder -> m ()
I.traceBuilder (Builder -> m ()) -> Builder -> m ()
forall a b. (a -> b) -> a -> b
$ SpanInFlight -> SpanContext -> Builder
I.builder_setParentSpanContext SpanInFlight
sp SpanContext
ctx

{-# INLINE mkCounter #-}
mkCounter :: MonadIO m => MI.InstrumentName -> m MI.Counter
mkCounter :: ByteString -> m Counter
mkCounter ByteString
name = do
  Counter
inst <- ByteString -> InstrumentId -> Counter
MI.Counter ByteString
name (InstrumentId -> Counter) -> m InstrumentId -> m Counter
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m InstrumentId
forall (m :: * -> *). MonadIO m => m InstrumentId
I.nextInstrumentId
  Builder -> m ()
forall (m :: * -> *). MonadIO m => Builder -> m ()
I.traceBuilder (Builder -> m ()) -> Builder -> m ()
forall a b. (a -> b) -> a -> b
$ Counter -> Builder
forall (s :: Synchronicity) (a :: Additivity) (m :: Monotonicity).
Instrument s a m -> Builder
I.builder_declareInstrument Counter
inst
  Counter -> m Counter
forall (m :: * -> *) a. Monad m => a -> m a
return Counter
inst

{-# INLINE mkUpDownCounter #-}
mkUpDownCounter :: MonadIO m => MI.InstrumentName -> m MI.UpDownCounter
mkUpDownCounter :: ByteString -> m UpDownCounter
mkUpDownCounter ByteString
name = do
  UpDownCounter
inst <- ByteString -> InstrumentId -> UpDownCounter
MI.UpDownCounter ByteString
name (InstrumentId -> UpDownCounter)
-> m InstrumentId -> m UpDownCounter
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m InstrumentId
forall (m :: * -> *). MonadIO m => m InstrumentId
I.nextInstrumentId
  Builder -> m ()
forall (m :: * -> *). MonadIO m => Builder -> m ()
I.traceBuilder (Builder -> m ()) -> Builder -> m ()
forall a b. (a -> b) -> a -> b
$ UpDownCounter -> Builder
forall (s :: Synchronicity) (a :: Additivity) (m :: Monotonicity).
Instrument s a m -> Builder
I.builder_declareInstrument UpDownCounter
inst
  UpDownCounter -> m UpDownCounter
forall (m :: * -> *) a. Monad m => a -> m a
return UpDownCounter
inst

{-# INLINE mkValueRecorder #-}
mkValueRecorder :: MonadIO m => MI.InstrumentName -> m MI.ValueRecorder
mkValueRecorder :: ByteString -> m ValueRecorder
mkValueRecorder ByteString
name = do
  ValueRecorder
inst <- ByteString -> InstrumentId -> ValueRecorder
MI.ValueRecorder ByteString
name (InstrumentId -> ValueRecorder)
-> m InstrumentId -> m ValueRecorder
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m InstrumentId
forall (m :: * -> *). MonadIO m => m InstrumentId
I.nextInstrumentId
  Builder -> m ()
forall (m :: * -> *). MonadIO m => Builder -> m ()
I.traceBuilder (Builder -> m ()) -> Builder -> m ()
forall a b. (a -> b) -> a -> b
$ ValueRecorder -> Builder
forall (s :: Synchronicity) (a :: Additivity) (m :: Monotonicity).
Instrument s a m -> Builder
I.builder_declareInstrument ValueRecorder
inst
  ValueRecorder -> m ValueRecorder
forall (m :: * -> *) a. Monad m => a -> m a
return ValueRecorder
inst

{-# INLINE mkSumObserver #-}
mkSumObserver :: MonadIO m => MI.InstrumentName -> m MI.SumObserver
mkSumObserver :: ByteString -> m SumObserver
mkSumObserver ByteString
name = do
  SumObserver
inst <- ByteString -> InstrumentId -> SumObserver
MI.SumObserver ByteString
name (InstrumentId -> SumObserver) -> m InstrumentId -> m SumObserver
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m InstrumentId
forall (m :: * -> *). MonadIO m => m InstrumentId
I.nextInstrumentId
  Builder -> m ()
forall (m :: * -> *). MonadIO m => Builder -> m ()
I.traceBuilder (Builder -> m ()) -> Builder -> m ()
forall a b. (a -> b) -> a -> b
$ SumObserver -> Builder
forall (s :: Synchronicity) (a :: Additivity) (m :: Monotonicity).
Instrument s a m -> Builder
I.builder_declareInstrument SumObserver
inst
  SumObserver -> m SumObserver
forall (m :: * -> *) a. Monad m => a -> m a
return SumObserver
inst

{-# INLINE mkUpDownSumObserver #-}
mkUpDownSumObserver :: MonadIO m => MI.InstrumentName -> m MI.UpDownSumObserver
mkUpDownSumObserver :: ByteString -> m UpDownSumObserver
mkUpDownSumObserver ByteString
name = do
  UpDownSumObserver
inst <- ByteString -> InstrumentId -> UpDownSumObserver
MI.UpDownSumObserver ByteString
name (InstrumentId -> UpDownSumObserver)
-> m InstrumentId -> m UpDownSumObserver
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m InstrumentId
forall (m :: * -> *). MonadIO m => m InstrumentId
I.nextInstrumentId
  Builder -> m ()
forall (m :: * -> *). MonadIO m => Builder -> m ()
I.traceBuilder (Builder -> m ()) -> Builder -> m ()
forall a b. (a -> b) -> a -> b
$ UpDownSumObserver -> Builder
forall (s :: Synchronicity) (a :: Additivity) (m :: Monotonicity).
Instrument s a m -> Builder
I.builder_declareInstrument UpDownSumObserver
inst
  UpDownSumObserver -> m UpDownSumObserver
forall (m :: * -> *) a. Monad m => a -> m a
return UpDownSumObserver
inst

{-# INLINE mkValueObserver #-}
mkValueObserver :: MonadIO m => MI.InstrumentName -> m MI.ValueObserver
mkValueObserver :: ByteString -> m ValueObserver
mkValueObserver ByteString
name = do
  ValueObserver
inst <- ByteString -> InstrumentId -> ValueObserver
MI.ValueObserver ByteString
name (InstrumentId -> ValueObserver)
-> m InstrumentId -> m ValueObserver
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m InstrumentId
forall (m :: * -> *). MonadIO m => m InstrumentId
I.nextInstrumentId
  Builder -> m ()
forall (m :: * -> *). MonadIO m => Builder -> m ()
I.traceBuilder (Builder -> m ()) -> Builder -> m ()
forall a b. (a -> b) -> a -> b
$ ValueObserver -> Builder
forall (s :: Synchronicity) (a :: Additivity) (m :: Monotonicity).
Instrument s a m -> Builder
I.builder_declareInstrument ValueObserver
inst
  ValueObserver -> m ValueObserver
forall (m :: * -> *) a. Monad m => a -> m a
return ValueObserver
inst

-- | Take a measurement for a synchronous, additive instrument ('Counter', 'UpDownCounter')
{-# INLINE add #-}
add :: MonadIO m => MI.Instrument 'MI.Synchronous 'MI.Additive m' -> Int -> m ()
add :: Instrument 'Synchronous 'Additive m' -> Int -> m ()
add Instrument 'Synchronous 'Additive m'
i Int
v = Builder -> m ()
forall (m :: * -> *). MonadIO m => Builder -> m ()
I.traceBuilder (Builder -> m ()) -> Builder -> m ()
forall a b. (a -> b) -> a -> b
$ InstrumentId -> Int -> Builder
I.builder_captureMetric (Instrument 'Synchronous 'Additive m' -> InstrumentId
forall (s :: Synchronicity) (a :: Additivity) (m :: Monotonicity).
Instrument s a m -> InstrumentId
MI.instrumentId Instrument 'Synchronous 'Additive m'
i) Int
v

-- | Take a measurement for a synchronous, non-additive instrument ('ValueRecorder')
{-# INLINE record #-}
record :: MonadIO m => MI.Instrument 'MI.Synchronous 'MI.NonAdditive m' -> Int -> m ()
record :: Instrument 'Synchronous 'NonAdditive m' -> Int -> m ()
record Instrument 'Synchronous 'NonAdditive m'
i Int
v = Builder -> m ()
forall (m :: * -> *). MonadIO m => Builder -> m ()
I.traceBuilder (Builder -> m ()) -> Builder -> m ()
forall a b. (a -> b) -> a -> b
$ InstrumentId -> Int -> Builder
I.builder_captureMetric (Instrument 'Synchronous 'NonAdditive m' -> InstrumentId
forall (s :: Synchronicity) (a :: Additivity) (m :: Monotonicity).
Instrument s a m -> InstrumentId
MI.instrumentId Instrument 'Synchronous 'NonAdditive m'
i) Int
v

-- | Take a measurement for an asynchronous instrument ('SumObserver', 'UpDownSumObserver', 'ValueObserver')
{-# INLINE observe #-}
observe :: MonadIO m => MI.Instrument 'MI.Asynchronous a m' -> Int -> m ()
observe :: Instrument 'Asynchronous a m' -> Int -> m ()
observe Instrument 'Asynchronous a m'
i Int
v = Builder -> m ()
forall (m :: * -> *). MonadIO m => Builder -> m ()
I.traceBuilder (Builder -> m ()) -> Builder -> m ()
forall a b. (a -> b) -> a -> b
$ InstrumentId -> Int -> Builder
I.builder_captureMetric (Instrument 'Asynchronous a m' -> InstrumentId
forall (s :: Synchronicity) (a :: Additivity) (m :: Monotonicity).
Instrument s a m -> InstrumentId
MI.instrumentId Instrument 'Asynchronous a m'
i) Int
v

#endif