{-# LANGUAGE OverloadedStrings #-}
module OpenTelemetry.Eventlog where
import Control.Monad.Catch
import Control.Monad.IO.Class
import qualified Data.ByteString.Char8 as BS8
import Data.Unique
import Data.Word
import Debug.Trace
import OpenTelemetry.SpanContext
import Text.Printf
import Prelude hiding (span)
type ProcessLocalSpanSerialNumber = Word64
newtype SpanInFlight = SpanInFlight ProcessLocalSpanSerialNumber
beginSpan :: MonadIO m => String -> m SpanInFlight
beginSpan operation = do
u64 <- fromIntegral . hashUnique <$> liftIO newUnique
liftIO $ traceEventIO (printf "ot2 begin span %d %s" u64 operation)
pure $ SpanInFlight u64
endSpan :: MonadIO m => SpanInFlight -> m ()
endSpan (SpanInFlight u64) = liftIO $ traceEventIO (printf "ot2 end span %d" u64)
setTag :: MonadIO m => SpanInFlight -> String -> BS8.ByteString -> m ()
setTag (SpanInFlight u64) k v = liftIO $ traceEventIO (printf "ot2 set tag %d %s %s" u64 k (BS8.unpack v))
addEvent :: MonadIO m => SpanInFlight -> String -> BS8.ByteString -> m ()
addEvent (SpanInFlight u64) k v = liftIO $ traceEventIO (printf "ot2 add event %d %s %s" u64 k (BS8.unpack v))
setParentSpanContext :: MonadIO m => SpanInFlight -> SpanContext -> m ()
setParentSpanContext (SpanInFlight u64) (SpanContext (SId sid) (TId tid)) =
liftIO $ traceEventIO (printf "ot2 set parent %d %016x %016x" u64 tid sid)
setTraceId :: MonadIO m => SpanInFlight -> TraceId -> m ()
setTraceId (SpanInFlight u64) (TId tid) =
liftIO $ traceEventIO (printf "ot2 set traceid %d %016x" u64 tid)
setSpanId :: MonadIO m => SpanInFlight -> SpanId -> m ()
setSpanId (SpanInFlight u64) (SId sid) =
liftIO $ traceEventIO (printf "ot2 set spanid %d %016x" u64 sid)
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)