1{-# LANGUAGE CPP #-}
2{-# LANGUAGE GADTs #-}
3{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4{-# LANGUAGE OverloadedStrings #-}
5{-# LANGUAGE PatternSynonyms #-}
6
7module OpenTelemetry.Eventlog
8  ( -- * Spans
9    beginSpan,
10    endSpan,
11    withSpan,
12    withSpan_,
13    setSpanId,
14    setTraceId,
15    setTag,
16    addEvent,
17    setParentSpanContext,
18    SpanInFlight (..),
19
20    -- * Metrics
21    mkCounter,
22    mkUpDownCounter,
23    mkValueRecorder,
24    mkSumObserver,
25    mkUpDownSumObserver,
26    mkValueObserver,
27    add,
28    record,
29    observe,
30    MI.Instrument,
31    MI.SomeInstrument (..),
32    MI.Counter,
33    MI.UpDownCounter,
34    MI.ValueRecorder,
35    MI.SumObserver,
36    MI.UpDownSumObserver,
37    MI.ValueObserver,
38    MI.Synchronicity (..),
39    MI.Additivity (..),
40    MI.Monotonicity (..),
41    MI.InstrumentName,
42    MI.InstrumentId,
43    MI.instrumentName,
44    MI.instrumentId,
45  )
46where
47
48import Control.Monad.Catch
49import Control.Monad.IO.Class
50import qualified Data.ByteString as BS
51import qualified Data.ByteString.Char8 as BS8
52import OpenTelemetry.Eventlog_Internal (SpanInFlight (..))
53import qualified OpenTelemetry.Eventlog_Internal as I
54import qualified OpenTelemetry.Metrics_Internal as MI
55import OpenTelemetry.SpanContext
56import Prelude hiding (span)
57
58#if __GLASGOW_HASKELL__ < 808
59
60import Data.Unique
61import Debug.Trace
62import OpenTelemetry.Metrics_Internal
63
64beginSpan :: MonadIO m => String -> m SpanInFlight
65beginSpan operation = do
66  u64 <- fromIntegral . hashUnique <$> liftIO newUnique
67  liftIO $ traceEventIO (I.beginSpan' (SpanInFlight u64) operation)
68  pure $ SpanInFlight u64
69
70endSpan :: MonadIO m => SpanInFlight -> m ()
71endSpan = liftIO . traceEventIO . I.endSpan'
72
73setTag :: MonadIO m => SpanInFlight -> String -> BS.ByteString -> m ()
74setTag sp k v = liftIO . traceEventIO $ I.setTag' sp k v
75
76addEvent :: MonadIO m => SpanInFlight -> String -> BS.ByteString -> m ()
77addEvent sp k v = liftIO . traceEventIO $ I.addEvent' sp k v
78
79setParentSpanContext :: MonadIO m => SpanInFlight -> SpanContext -> m ()
80setParentSpanContext sp ctx = liftIO . traceEventIO $ I.setParentSpanContext' sp ctx
81
82setTraceId :: MonadIO m => SpanInFlight -> TraceId -> m ()
83setTraceId sp tid = liftIO . traceEventIO $ I.setTraceId' sp tid
84
85setSpanId :: MonadIO m => SpanInFlight -> SpanId -> m ()
86setSpanId sp sid = liftIO . traceEventIO $ I.setSpanId' sp sid
87
88createInstrument :: MonadIO io => MI.Instrument s a m -> io ()
89createInstrument = liftIO . traceEventIO . I.createInstrument'
90
91writeMetric :: MonadIO io => MI.Instrument s a m -> Int -> io ()
92writeMetric i v = liftIO $ traceEventIO $ I.writeMetric' (instrumentId i) v
93
94mkCounter :: MonadIO m => MI.InstrumentName -> m MI.Counter
95mkCounter name = do
96  inst <- MI.Counter name <$> I.nextInstrumentId
97  createInstrument inst
98  return inst
99
100mkUpDownCounter :: MonadIO m => MI.InstrumentName -> m MI.UpDownCounter
101mkUpDownCounter name = do
102  inst <- MI.UpDownCounter name <$> I.nextInstrumentId
103  createInstrument inst
104  return inst
105
106mkValueRecorder :: MonadIO m => MI.InstrumentName -> m MI.ValueRecorder
107mkValueRecorder name = do
108  inst <- MI.ValueRecorder name <$> I.nextInstrumentId
109  createInstrument inst
110  return inst
111
112mkSumObserver :: MonadIO m => MI.InstrumentName -> m MI.SumObserver
113mkSumObserver name = do
114  inst <- MI.SumObserver name <$> I.nextInstrumentId
115  createInstrument inst
116  return inst
117
118mkUpDownSumObserver :: MonadIO m => MI.InstrumentName -> m MI.UpDownSumObserver
119mkUpDownSumObserver name = do
120  inst <- MI.UpDownSumObserver name <$> I.nextInstrumentId
121  createInstrument inst
122  return inst
123
124mkValueObserver :: MonadIO m => MI.InstrumentName -> m MI.ValueObserver
125mkValueObserver name = do
126  inst <- MI.ValueObserver name <$> I.nextInstrumentId
127  createInstrument inst
128  return inst
129
130-- | Take a measurement for a synchronous, additive instrument ('Counter', 'UpDowncounter')
131add :: MonadIO io => MI.Instrument 'MI.Synchronous 'MI.Additive m' -> Int -> io ()
132add = writeMetric
133
134-- | Take a measurement for a synchronous, non-additive instrument ('ValueRecorder')
135record :: MonadIO io => MI.Instrument 'MI.Synchronous 'MI.NonAdditive m' -> Int -> io ()
136record = writeMetric
137
138-- | Take a measurement for an asynchronous instrument ('SumObserver', 'UpDownSumObserver', 'ValueObserver')
139observe :: MonadIO io => MI.Instrument 'MI.Asynchronous a m' -> Int -> io ()
140observe = writeMetric
141
142withSpan :: forall m a. (MonadIO m, MonadMask m) => String -> (SpanInFlight -> m a) -> m a
143withSpan operation action =
144  fst
145    <$> generalBracket
146      (liftIO $ beginSpan operation)
147      ( \span exitcase -> liftIO $ do
148          case exitcase of
149            ExitCaseSuccess _ -> pure ()
150            ExitCaseException e -> do
151              setTag span "error" "true"
152              setTag span "error.message" (BS8.pack $ show e)
153            ExitCaseAbort -> do
154              setTag span "error" "true"
155              setTag span "error.message" "abort"
156          liftIO $ endSpan span
157      )
158      action
159
160withSpan_ :: (MonadIO m, MonadMask m) => String -> m a -> m a
161withSpan_ operation action = withSpan operation (const action)
162
163#else
164
165{-# INLINE withSpan #-}
166withSpan ::
167  forall m a.
168  (MonadIO m, MonadMask m) =>
169  BS.ByteString ->
170  (SpanInFlight -> m a) ->
171  m a
172withSpan operation action =
173  fst
174    <$> generalBracket
175      (liftIO $ beginSpan operation)
176      ( \sp exitcase -> liftIO $ do
177          case exitcase of
178            ExitCaseSuccess _ -> pure ()
179            ExitCaseException e -> do
180              setTag sp "error" "true"
181              setTag sp "error.message" (BS8.pack $ take I.maxMsgLen $ show e)
182            ExitCaseAbort -> do
183              setTag sp "error" "true"
184              setTag sp "error.message" "abort"
185          liftIO $ endSpan sp
186      )
187      action
188
189{-# INLINE withSpan_ #-}
190withSpan_ :: (MonadIO m, MonadMask m) => BS.ByteString -> m a -> m a
191withSpan_ operation action = withSpan operation (const action)
192
193{-# INLINE setSpanId #-}
194setSpanId :: MonadIO m => SpanInFlight -> SpanId -> m ()
195setSpanId sp sid = I.traceBuilder $ I.builder_setSpanId sp sid
196
197{-# INLINE setTraceId #-}
198setTraceId :: MonadIO m => SpanInFlight -> TraceId -> m ()
199setTraceId sp tid = I.traceBuilder $ I.builder_setTraceId sp tid
200
201{-# INLINE beginSpan #-}
202beginSpan :: MonadIO m => BS.ByteString -> m SpanInFlight
203beginSpan operation = do
204  u <- I.nextLocalSpan
205  I.traceBuilder $ I.builder_beginSpan u operation
206  pure u
207
208{-# INLINE endSpan #-}
209endSpan :: MonadIO m => SpanInFlight -> m ()
210endSpan sp = I.traceBuilder $ I.builder_endSpan sp
211
212{-# INLINE setTag #-}
213setTag :: MonadIO m => SpanInFlight -> BS.ByteString -> BS.ByteString -> m ()
214setTag sp k v = I.traceBuilder $ I.builder_setTag sp k v
215
216{-# INLINE addEvent #-}
217addEvent :: MonadIO m => SpanInFlight -> BS.ByteString -> BS.ByteString -> m ()
218addEvent sp k v = I.traceBuilder $ I.builder_addEvent sp k v
219
220{-# INLINE setParentSpanContext #-}
221setParentSpanContext :: MonadIO m => SpanInFlight -> SpanContext -> m ()
222setParentSpanContext sp ctx = I.traceBuilder $ I.builder_setParentSpanContext sp ctx
223
224{-# INLINE mkCounter #-}
225mkCounter :: MonadIO m => MI.InstrumentName -> m MI.Counter
226mkCounter name = do
227  inst <- MI.Counter name <$> I.nextInstrumentId
228  I.traceBuilder $ I.builder_declareInstrument inst
229  return inst
230
231{-# INLINE mkUpDownCounter #-}
232mkUpDownCounter :: MonadIO m => MI.InstrumentName -> m MI.UpDownCounter
233mkUpDownCounter name = do
234  inst <- MI.UpDownCounter name <$> I.nextInstrumentId
235  I.traceBuilder $ I.builder_declareInstrument inst
236  return inst
237
238{-# INLINE mkValueRecorder #-}
239mkValueRecorder :: MonadIO m => MI.InstrumentName -> m MI.ValueRecorder
240mkValueRecorder name = do
241  inst <- MI.ValueRecorder name <$> I.nextInstrumentId
242  I.traceBuilder $ I.builder_declareInstrument inst
243  return inst
244
245{-# INLINE mkSumObserver #-}
246mkSumObserver :: MonadIO m => MI.InstrumentName -> m MI.SumObserver
247mkSumObserver name = do
248  inst <- MI.SumObserver name <$> I.nextInstrumentId
249  I.traceBuilder $ I.builder_declareInstrument inst
250  return inst
251
252{-# INLINE mkUpDownSumObserver #-}
253mkUpDownSumObserver :: MonadIO m => MI.InstrumentName -> m MI.UpDownSumObserver
254mkUpDownSumObserver name = do
255  inst <- MI.UpDownSumObserver name <$> I.nextInstrumentId
256  I.traceBuilder $ I.builder_declareInstrument inst
257  return inst
258
259{-# INLINE mkValueObserver #-}
260mkValueObserver :: MonadIO m => MI.InstrumentName -> m MI.ValueObserver
261mkValueObserver name = do
262  inst <- MI.ValueObserver name <$> I.nextInstrumentId
263  I.traceBuilder $ I.builder_declareInstrument inst
264  return inst
265
266-- | Take a measurement for a synchronous, additive instrument ('Counter', 'UpDownCounter')
267{-# INLINE add #-}
268add :: MonadIO m => MI.Instrument 'MI.Synchronous 'MI.Additive m' -> Int -> m ()
269add i v = I.traceBuilder $ I.builder_captureMetric (MI.instrumentId i) v
270
271-- | Take a measurement for a synchronous, non-additive instrument ('ValueRecorder')
272{-# INLINE record #-}
273record :: MonadIO m => MI.Instrument 'MI.Synchronous 'MI.NonAdditive m' -> Int -> m ()
274record i v = I.traceBuilder $ I.builder_captureMetric (MI.instrumentId i) v
275
276-- | Take a measurement for an asynchronous instrument ('SumObserver', 'UpDownSumObserver', 'ValueObserver')
277{-# INLINE observe #-}
278observe :: MonadIO m => MI.Instrument 'MI.Asynchronous a m' -> Int -> m ()
279observe i v = I.traceBuilder $ I.builder_captureMetric (MI.instrumentId i) v
280
281#endif
282