{-# LANGUAGE OverloadedStrings #-}

module OpenTelemetry.ChromeExporter where

import Control.Monad
import qualified Data.ByteString as BS
import Data.Coerce
import Data.Function
import Data.HashMap.Strict as HM
import Data.List (sortOn)
import qualified Data.Text.Encoding as TE
import Data.Word
import qualified Jsonifier as J
import OpenTelemetry.Common
import OpenTelemetry.EventlogStreaming_Internal
import System.IO

newtype ChromeBeginSpan = ChromeBegin Span

newtype ChromeEndSpan = ChromeEnd Span

data ChromeEvent = ChromeEvent Word32 SpanEvent

jTagValue :: TagValue -> J.Json
jTagValue :: TagValue -> Json
jTagValue (StringTagValue (TagVal Text
i)) = Text -> Json
J.textString Text
i
jTagValue (IntTagValue Int
i) = Int -> Json
J.intNumber Int
i
jTagValue (BoolTagValue Bool
b) = Bool -> Json
J.bool Bool
b
jTagValue (DoubleTagValue Double
d) = Double -> Json
J.doubleNumber Double
d

jChromeEvent :: ChromeEvent -> Json
jChromeEvent (ChromeEvent Word32
threadId SpanEvent {Timestamp
EventVal
EventName
$sel:spanEventValue:SpanEvent :: SpanEvent -> EventVal
$sel:spanEventKey:SpanEvent :: SpanEvent -> EventName
$sel:spanEventTimestamp:SpanEvent :: SpanEvent -> Timestamp
spanEventValue :: EventVal
spanEventKey :: EventName
spanEventTimestamp :: Timestamp
..}) =
  [(Text, Json)] -> Json
forall (f :: * -> *). Foldable f => f (Text, Json) -> Json
J.object
    [ (Text
"ph", Text -> Json
J.textString Text
"i"),
      (Text
"name", Text -> Json
J.textString (Text -> Json) -> Text -> Json
forall a b. (a -> b) -> a -> b
$ EventVal -> Text
coerce EventVal
spanEventValue),
      (Text
"pid", Int -> Json
J.intNumber Int
1),
      (Text
"tid", Word -> Json
J.wordNumber (Word -> Json) -> Word -> Json
forall a b. (a -> b) -> a -> b
$ Word32 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
threadId),
      (Text
"ts", Int -> Json
J.intNumber (Int -> Json) -> (Timestamp -> Int) -> Timestamp -> Json
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Timestamp -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Timestamp -> Json) -> Timestamp -> Json
forall a b. (a -> b) -> a -> b
$ Timestamp -> Timestamp -> Timestamp
forall a. Integral a => a -> a -> a
div Timestamp
spanEventTimestamp Timestamp
1000)
    ]

jChromeBeginSpan :: Span -> Json
jChromeBeginSpan Span {[SpanEvent]
Maybe SpanId
Word32
Timestamp
Text
SpanContext
HashMap TagName TagValue
SpanStatus
$sel:spanNanosecondsSpentInGC:Span :: Span -> Timestamp
$sel:spanParentId:Span :: Span -> Maybe SpanId
$sel:spanStatus:Span :: Span -> SpanStatus
$sel:spanEvents:Span :: Span -> [SpanEvent]
$sel:spanTags:Span :: Span -> HashMap TagName TagValue
$sel:spanFinishedAt:Span :: Span -> Timestamp
$sel:spanStartedAt:Span :: Span -> Timestamp
$sel:spanDisplayThreadId:Span :: Span -> Word32
$sel:spanThreadId:Span :: Span -> Word32
$sel:spanOperation:Span :: Span -> Text
$sel:spanContext:Span :: Span -> SpanContext
spanNanosecondsSpentInGC :: Timestamp
spanParentId :: Maybe SpanId
spanStatus :: SpanStatus
spanEvents :: [SpanEvent]
spanTags :: HashMap TagName TagValue
spanFinishedAt :: Timestamp
spanStartedAt :: Timestamp
spanDisplayThreadId :: Word32
spanThreadId :: Word32
spanOperation :: Text
spanContext :: SpanContext
..} =
  [(Text, Json)] -> Json
forall (f :: * -> *). Foldable f => f (Text, Json) -> Json
J.object
    [ (Text
"ph", Text -> Json
J.textString Text
"B"),
      (Text
"name", Text -> Json
J.textString Text
spanOperation),
      (Text
"pid", Int -> Json
J.intNumber Int
1),
      (Text
"tid", Int -> Json
J.intNumber (Int -> Json) -> Int -> Json
forall a b. (a -> b) -> a -> b
$ Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
spanDisplayThreadId),
      (Text
"ts", Word -> Json
J.wordNumber (Word -> Json) -> (Timestamp -> Word) -> Timestamp -> Json
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Timestamp -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Timestamp -> Json) -> Timestamp -> Json
forall a b. (a -> b) -> a -> b
$ Timestamp -> Timestamp -> Timestamp
forall a. Integral a => a -> a -> a
div Timestamp
spanStartedAt Timestamp
1000),
      ( Text
"args",
        [(Text, Json)] -> Json
forall (f :: * -> *). Foldable f => f (Text, Json) -> Json
J.object
          ( HashMap TagName TagValue
spanTags
              HashMap TagName TagValue
-> (HashMap TagName TagValue -> HashMap TagName TagValue)
-> HashMap TagName TagValue
forall a b. a -> (a -> b) -> b
& TagName
-> TagValue -> HashMap TagName TagValue -> HashMap TagName TagValue
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert TagName
"gc_us" (Int -> TagValue
IntTagValue (Int -> TagValue) -> (Timestamp -> Int) -> Timestamp -> TagValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Timestamp -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Timestamp -> TagValue) -> Timestamp -> TagValue
forall a b. (a -> b) -> a -> b
$ Timestamp
spanNanosecondsSpentInGC Timestamp -> Timestamp -> Timestamp
forall a. Integral a => a -> a -> a
`div` Timestamp
1000)
              HashMap TagName TagValue
-> (HashMap TagName TagValue -> HashMap TagName TagValue)
-> HashMap TagName TagValue
forall a b. a -> (a -> b) -> b
& TagName
-> TagValue -> HashMap TagName TagValue -> HashMap TagName TagValue
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert TagName
"original_tid" (Int -> TagValue
IntTagValue (Int -> TagValue) -> (Word32 -> Int) -> Word32 -> TagValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> TagValue) -> Word32 -> TagValue
forall a b. (a -> b) -> a -> b
$ Word32
spanThreadId)
              HashMap TagName TagValue
-> (HashMap TagName TagValue -> HashMap TagName TagValue)
-> HashMap TagName TagValue
forall a b. a -> (a -> b) -> b
& ( if Timestamp
spanNanosecondsSpentInGC Timestamp -> Timestamp -> Bool
forall a. Eq a => a -> a -> Bool
== Timestamp
0
                    then HashMap TagName TagValue -> HashMap TagName TagValue
forall a. a -> a
id
                    else TagName
-> TagValue -> HashMap TagName TagValue -> HashMap TagName TagValue
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert TagName
"gc_fraction" (Double -> TagValue
DoubleTagValue (Timestamp -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Timestamp
spanNanosecondsSpentInGC Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Timestamp -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Timestamp
spanFinishedAt Timestamp -> Timestamp -> Timestamp
forall a. Num a => a -> a -> a
- Timestamp
spanStartedAt)))
                )
              HashMap TagName TagValue
-> (HashMap TagName TagValue -> [(TagName, TagValue)])
-> [(TagName, TagValue)]
forall a b. a -> (a -> b) -> b
& HashMap TagName TagValue -> [(TagName, TagValue)]
forall k v. HashMap k v -> [(k, v)]
HM.toList
              [(TagName, TagValue)]
-> ([(TagName, TagValue)] -> [(Text, Json)]) -> [(Text, Json)]
forall a b. a -> (a -> b) -> b
& ((TagName, TagValue) -> (Text, Json))
-> [(TagName, TagValue)] -> [(Text, Json)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(TagName Text
n, TagValue
v) -> (Text
n, TagValue -> Json
jTagValue TagValue
v))
          )
      )
    ]

jChromeEndSpan :: Span -> Json
jChromeEndSpan Span {[SpanEvent]
Maybe SpanId
Word32
Timestamp
Text
SpanContext
HashMap TagName TagValue
SpanStatus
spanNanosecondsSpentInGC :: Timestamp
spanParentId :: Maybe SpanId
spanStatus :: SpanStatus
spanEvents :: [SpanEvent]
spanTags :: HashMap TagName TagValue
spanFinishedAt :: Timestamp
spanStartedAt :: Timestamp
spanDisplayThreadId :: Word32
spanThreadId :: Word32
spanOperation :: Text
spanContext :: SpanContext
$sel:spanNanosecondsSpentInGC:Span :: Span -> Timestamp
$sel:spanParentId:Span :: Span -> Maybe SpanId
$sel:spanStatus:Span :: Span -> SpanStatus
$sel:spanEvents:Span :: Span -> [SpanEvent]
$sel:spanTags:Span :: Span -> HashMap TagName TagValue
$sel:spanFinishedAt:Span :: Span -> Timestamp
$sel:spanStartedAt:Span :: Span -> Timestamp
$sel:spanDisplayThreadId:Span :: Span -> Word32
$sel:spanThreadId:Span :: Span -> Word32
$sel:spanOperation:Span :: Span -> Text
$sel:spanContext:Span :: Span -> SpanContext
..} =
  [(Text, Json)] -> Json
forall (f :: * -> *). Foldable f => f (Text, Json) -> Json
J.object
    [ (Text
"ph", Text -> Json
J.textString Text
"E"),
      (Text
"name", Text -> Json
J.textString Text
spanOperation),
      (Text
"pid", Int -> Json
J.intNumber Int
1),
      (Text
"tid", Int -> Json
J.intNumber (Int -> Json) -> Int -> Json
forall a b. (a -> b) -> a -> b
$ Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
spanDisplayThreadId),
      (Text
"ts", Word -> Json
J.wordNumber (Word -> Json) -> (Timestamp -> Word) -> Timestamp -> Json
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Timestamp -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Timestamp -> Json) -> Timestamp -> Json
forall a b. (a -> b) -> a -> b
$ Timestamp -> Timestamp -> Timestamp
forall a. Integral a => a -> a -> a
div Timestamp
spanFinishedAt Timestamp
1000)
    ]

createChromeExporter :: FilePath -> IO (Exporter Span, Exporter Metric)
createChromeExporter :: FilePath -> IO (Exporter Span, Exporter Metric)
createChromeExporter FilePath
path = FilePath
-> ThreadPresentation -> IO (Exporter Span, Exporter Metric)
createChromeExporter' FilePath
path ThreadPresentation
SplitThreads

createChromeExporter' :: FilePath -> ThreadPresentation -> IO (Exporter Span, Exporter Metric)
createChromeExporter' :: FilePath
-> ThreadPresentation -> IO (Exporter Span, Exporter Metric)
createChromeExporter' FilePath
path ThreadPresentation
threadPresentation = do
  Handle
f <- FilePath -> IOMode -> IO Handle
openFile FilePath
path IOMode
WriteMode
  Handle -> FilePath -> IO ()
hPutStrLn Handle
f FilePath
"[ "
  let modifyThreadId :: Word32 -> IO Word32
modifyThreadId = case ThreadPresentation
threadPresentation of
        ThreadPresentation
CollapseThreads -> Word32 -> IO Word32
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word32 -> IO Word32) -> (Word32 -> Word32) -> Word32 -> IO Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Word32 -> Word32
forall a b. a -> b -> a
const Word32
1
        ThreadPresentation
SplitThreads -> Word32 -> IO Word32
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      span_exporter :: Exporter Span
span_exporter =
        ([Span] -> IO ExportResult) -> IO () -> Exporter Span
forall thing.
([thing] -> IO ExportResult) -> IO () -> Exporter thing
Exporter
          ( \[Span]
sps -> do
              (Span -> IO ()) -> [Span] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
                ( \sp :: Span
sp@(Span {[SpanEvent]
spanEvents :: [SpanEvent]
$sel:spanEvents:Span :: Span -> [SpanEvent]
spanEvents}) -> do
                    Word32
tid' <- Word32 -> IO Word32
modifyThreadId (Span -> Word32
spanDisplayThreadId Span
sp)
                    let sp' :: Span
sp' = Span
sp {$sel:spanDisplayThreadId:Span :: Word32
spanDisplayThreadId = Word32
tid'}
                    Handle -> ByteString -> IO ()
BS.hPutStr Handle
f (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Json -> ByteString
J.toByteString (Json -> ByteString) -> Json -> ByteString
forall a b. (a -> b) -> a -> b
$ Span -> Json
jChromeBeginSpan Span
sp'
                    Handle -> ByteString -> IO ()
BS.hPutStr Handle
f ByteString
",\n"
                    [SpanEvent] -> (SpanEvent -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ((SpanEvent -> Timestamp) -> [SpanEvent] -> [SpanEvent]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn SpanEvent -> Timestamp
spanEventTimestamp [SpanEvent]
spanEvents) ((SpanEvent -> IO ()) -> IO ()) -> (SpanEvent -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \SpanEvent
ev -> do
                      Handle -> ByteString -> IO ()
BS.hPutStr Handle
f (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Json -> ByteString
J.toByteString (Json -> ByteString) -> Json -> ByteString
forall a b. (a -> b) -> a -> b
$ ChromeEvent -> Json
jChromeEvent (ChromeEvent -> Json) -> ChromeEvent -> Json
forall a b. (a -> b) -> a -> b
$ Word32 -> SpanEvent -> ChromeEvent
ChromeEvent Word32
tid' SpanEvent
ev
                      Handle -> ByteString -> IO ()
BS.hPutStr Handle
f ByteString
",\n"
                    Handle -> ByteString -> IO ()
BS.hPutStr Handle
f (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Json -> ByteString
J.toByteString (Json -> ByteString) -> Json -> ByteString
forall a b. (a -> b) -> a -> b
$ Span -> Json
jChromeEndSpan Span
sp'
                    Handle -> ByteString -> IO ()
BS.hPutStr Handle
f ByteString
",\n"
                )
                [Span]
sps
              ExportResult -> IO ExportResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure ExportResult
ExportSuccess
          )
          ( do
              Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
f SeekMode
RelativeSeek (-Integer
2) -- overwrite the last comma
              Handle -> FilePath -> IO ()
hPutStrLn Handle
f FilePath
"\n]"
              Handle -> IO ()
hClose Handle
f
          )
  Exporter Metric
metric_exporter <-
    Exporter AggregatedMetric -> IO (Exporter Metric)
aggregated (Exporter AggregatedMetric -> IO (Exporter Metric))
-> Exporter AggregatedMetric -> IO (Exporter Metric)
forall a b. (a -> b) -> a -> b
$
      ([AggregatedMetric] -> IO ExportResult)
-> IO () -> Exporter AggregatedMetric
forall thing.
([thing] -> IO ExportResult) -> IO () -> Exporter thing
Exporter
        ( \[AggregatedMetric]
metrics -> do
            -- forM_ metrics $ \(AggregatedMetric (SomeInstrument (TE.decodeUtf8 . instrumentName -> name)) (MetricDatapoint ts value)) -> do
            [AggregatedMetric] -> (AggregatedMetric -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [AggregatedMetric]
metrics ((AggregatedMetric -> IO ()) -> IO ())
-> (AggregatedMetric -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(AggregatedMetric (CaptureInstrument InstrumentType
_ (ByteString -> Text
TE.decodeUtf8 -> Text
name)) (MetricDatapoint Timestamp
ts Int
value)) -> do
              Handle -> ByteString -> IO ()
BS.hPutStr Handle
f (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$
                Json -> ByteString
J.toByteString (Json -> ByteString) -> Json -> ByteString
forall a b. (a -> b) -> a -> b
$
                  [(Text, Json)] -> Json
forall (f :: * -> *). Foldable f => f (Text, Json) -> Json
J.object
                    [ (Text
"ph", Text -> Json
J.textString Text
"C"),
                      (Text
"pid", Int -> Json
J.intNumber Int
1),
                      (Text
"name", Text -> Json
J.textString Text
name),
                      (Text
"ts", Word -> Json
J.wordNumber (Word -> Json) -> Word -> Json
forall a b. (a -> b) -> a -> b
$ Timestamp -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Timestamp -> Word) -> Timestamp -> Word
forall a b. (a -> b) -> a -> b
$ Timestamp -> Timestamp -> Timestamp
forall a. Integral a => a -> a -> a
div Timestamp
ts Timestamp
1000),
                      (Text
"args", [(Text, Json)] -> Json
forall (f :: * -> *). Foldable f => f (Text, Json) -> Json
J.object [(Text
name, Int -> Json
J.intNumber Int
value)])
                    ]
              Handle -> ByteString -> IO ()
BS.hPutStr Handle
f ByteString
",\n"
            ExportResult -> IO ExportResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure ExportResult
ExportSuccess
        )
        (() -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
  (Exporter Span, Exporter Metric)
-> IO (Exporter Span, Exporter Metric)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exporter Span
span_exporter, Exporter Metric
metric_exporter)

data ThreadPresentation = CollapseThreads | SplitThreads

eventlogToChrome :: FilePath -> FilePath -> ThreadPresentation -> IO ()
eventlogToChrome :: FilePath -> FilePath -> ThreadPresentation -> IO ()
eventlogToChrome FilePath
eventlogFile FilePath
chromeFile ThreadPresentation
doWeCollapseThreads = do
  (Exporter Span
span_exporter, Exporter Metric
metric_exporter) <- FilePath
-> ThreadPresentation -> IO (Exporter Span, Exporter Metric)
createChromeExporter' FilePath
chromeFile ThreadPresentation
doWeCollapseThreads
  Exporter Span -> Exporter Metric -> FilePath -> IO ()
exportEventlog Exporter Span
span_exporter Exporter Metric
metric_exporter FilePath
eventlogFile
  Exporter Span -> IO ()
forall thing. Exporter thing -> IO ()
shutdown Exporter Span
span_exporter
  Exporter Metric -> IO ()
forall thing. Exporter thing -> IO ()
shutdown Exporter Metric
metric_exporter