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