eventlogs to opentelemetry converter

.gitmodules

@@ -0,0 +1,3 @@
+[submodule "proto"]
+	path = opentelemetry-proto/proto
+	url = https://github.com/open-telemetry/opentelemetry-proto.git

opentelemetry-extra/exe/eventlog-to-opentelemetry/Main.hs

@@ -0,0 +1,59 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Main where
+
+import Data.Aeson as A
+import Data.ProtoLens (defMessage)
+import Data.ProtoLens.Encoding (encodeMessage)
+
+import Data.ByteString as BS
+import Data.ByteString.Lazy as LBS
+import Data.Maybe
+import Lens.Micro
+
+import OpenTelemetry.Common as OC
+import OpenTelemetry.EventlogStreaming_Internal
+import OpenTelemetry.Exporter
+
+import qualified Proto.Opentelemetry.Proto.Resource.V1.Resource as R
+import qualified Proto.Opentelemetry.Proto.Trace.V1.Trace as T
+import qualified Proto.Opentelemetry.Proto.Trace.V1.Trace_Fields as T
+import OpenTelemetry.Console
+import OpenTelemetry.Resource
+import OpenTelemetry.Spans
+import System.Clock
+import System.FilePath.Posix
+import System.IO
+
+createExporter :: R.Resource -> FilePath -> IO (Exporter OC.Span)
+createExporter resource path = do
+  f <- openFile path WriteMode
+  pure
+    $! Exporter
+      ( \sps -> do
+          let msg :: T.ResourceSpans = defMessage
+                    & T.resource .~ resource
+                    & T.instrumentationLibrarySpans .~ [spansToLibSpans sps]
+          BS.hPut f (encodeMessage msg)
+          pure ExportSuccess
+      )
+      (hClose f)
+
+main :: IO ()
+main = do
+  cmd <- parseConsoleOptions
+  case cmd^.coCmd of
+    TraceCommand {..} -> do
+      let defaultDst = (-<.> "ot") . takeFileName $ cmd^.coCmd.trCmdSrc
+      let dstPath = fromMaybe defaultDst (cmd^.coCmd.trCmdDst)
+      let emptyHeaderErr = error $ "empty json header file: "
+                           ++ cmd^.coCmd.trJsonHeader
+      header :: ResourceHeader <- (fromMaybe emptyHeaderErr . A.decode)
+                <$> LBS.readFile (cmd^.coCmd.trJsonHeader)
+      exporter <- createExporter (convertTo header) dstPath
+      origin_timestamp <- fromIntegral . toNanoSecs <$> getTime Realtime
+      work origin_timestamp exporter $ EventLogFilename dstPath
+      shutdown exporter

opentelemetry-extra/exe/eventlog-to-opentelemetry/OpenTelemetry/Attribute.hs

@@ -0,0 +1,28 @@
+{-# LANGUAGE FlexibleContexts #-}
+module OpenTelemetry.Attribute where
+
+import Data.ProtoLens (defMessage)
+import Data.Text
+import Lens.Micro
+import OpenTelemetry.Common
+import qualified Proto.Opentelemetry.Proto.Common.V1.Common as C
+import qualified Proto.Opentelemetry.Proto.Common.V1.Common_Fields as C
+
+
+strAttr :: Text -> Text -> C.AttributeKeyValue
+strAttr attrName attrVal = defMessage
+                   & C.key .~ attrName
+                   & C.type' .~ C.AttributeKeyValue'STRING
+                   & C.stringValue .~ attrVal
+
+tagToAttribute :: Text -> TagValue -> C.AttributeKeyValue
+tagToAttribute name val = defMessage & C.key .~ name & (setVal val)
+    where
+      setVal (StringTagValue (TagVal v)) =
+          (C.type' .~ C.AttributeKeyValue'STRING) . (C.stringValue .~ v)
+      setVal (BoolTagValue v) =
+          (C.type' .~ C.AttributeKeyValue'BOOL) . (C.boolValue .~ v)
+      setVal (IntTagValue v) =
+          (C.type' .~ C.AttributeKeyValue'INT) . (C.intValue .~ fromIntegral v)
+      setVal (DoubleTagValue v) =
+          (C.type' .~ C.AttributeKeyValue'DOUBLE) . (C.doubleValue .~ v)

opentelemetry-extra/exe/eventlog-to-opentelemetry/OpenTelemetry/Console.hs

@@ -0,0 +1,56 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module OpenTelemetry.Console
+    ( parseConsoleOptions
+    , Command (..)
+    , ConsoleOptions (..)
+    , trCmdDst
+    , trCmdSrc
+    , coCmd
+    , trJsonHeader
+    ) where
+
+
+import Lens.Micro.TH
+
+import Options.Applicative as OA
+
+data Command = TraceCommand
+    { _trCmdSrc :: FilePath
+    , _trCmdDst :: Maybe FilePath
+    , _trJsonHeader :: FilePath
+    } deriving (Show)
+
+makeLenses ''Command
+
+data ConsoleOptions = ConsoleOptions
+    { _coCmd :: Command
+    } deriving (Show)
+
+makeLenses ''ConsoleOptions
+
+extractTraceFromEventlogFileCmd :: Parser Command
+extractTraceFromEventlogFileCmd
+    = TraceCommand <$> argument str (metavar "SRCFILE")
+                   <*> optional (strOption
+                        (  long "out"
+                        <> help (  "Path to out OpenTelemetry trace file."
+                                ++ " By default current directory and extension .ot" )
+                        ))
+                   <*> option auto
+                        (  long "header"
+                        <> help "Path to json file with OpenTelemetry header info."
+                        <> showDefault
+                        <> OA.value "ot-header.json")
+
+consoleOptionParser :: Parser ConsoleOptions
+consoleOptionParser
+    = ConsoleOptions
+      <$> hsubparser
+              (command "trace"
+               (info extractTraceFromEventlogFileCmd
+                         (progDesc "converts Eventlog tracing into OpenTelemtry one")))
+
+parseConsoleOptions :: IO ConsoleOptions
+parseConsoleOptions
+    = execParser $ info (consoleOptionParser <**> helper) fullDesc

opentelemetry-extra/exe/eventlog-to-opentelemetry/OpenTelemetry/Json.hs

@@ -0,0 +1,12 @@
+module OpenTelemetry.Json (jsonOpts) where
+
+import Data.Aeson
+import Data.Char
+
+-- extra file due TH constraint
+jsonOpts :: Int -> Options
+jsonOpts toDrop = defaultOptions
+                 { fieldLabelModifier = drop toDrop
+                 , omitNothingFields = True
+                 , constructorTagModifier = map toLower
+                 }

opentelemetry-extra/exe/eventlog-to-opentelemetry/OpenTelemetry/Resource.hs

@@ -0,0 +1,92 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+module OpenTelemetry.Resource where
+
+import Data.Aeson.TH
+import Data.List as L
+import Data.Maybe
+import Data.ProtoLens (defMessage)
+import Data.Text
+import Lens.Micro
+import OpenTelemetry.Attribute
+import OpenTelemetry.Json
+import Proto.Opentelemetry.Proto.Common.V1.Common as C
+import Proto.Opentelemetry.Proto.Resource.V1.Resource as R
+import Proto.Opentelemetry.Proto.Resource.V1.Resource_Fields as R
+
+-- header structures to list of KeyValueAttribute
+class ConversionTo src dst where
+    convertTo :: src -> dst
+
+data ServiceHeader = ServiceHeader
+    { _sName       :: Text
+    , _sNameSpace  :: Maybe Text
+    , _sInstanceId :: Text
+    , _sVersion    :: Maybe Text
+    } deriving (Eq, Show)
+
+$(deriveJSON (jsonOpts 2) ''ServiceHeader)
+
+instance ConversionTo ServiceHeader [C.AttributeKeyValue] where
+    convertTo ServiceHeader{..} = mandatory ++ extras
+        where
+          sa k = strAttr (("service."::Text) <> k)
+          mandatory = [ sa "name" _sName, sa "instance.id" _sInstanceId ]
+          extras = catMaybes [
+                    fmap (sa "namespace") _sNameSpace,
+                    fmap (sa "version") _sVersion
+                   ]
+
+data ExtraResourceHeader
+    = TelemetrySdk
+      { _tlsSdkName :: Text
+      , _tlsSdkLanguage :: Text
+      }
+    | ComputeUnitContainer
+      { _cucName :: Text
+      , _cucImageName :: Text
+      }
+    | ComputeInstanceHost
+      { _cihHost :: Text
+      , _cihId   :: Text
+      }
+    deriving (Eq, Show)
+
+$(deriveJSON (jsonOpts 4) ''ExtraResourceHeader)
+
+instance ConversionTo ExtraResourceHeader [C.AttributeKeyValue] where
+    convertTo TelemetrySdk{..} =
+        [ strAttr "telemetry.sdk.name" _tlsSdkName
+        , strAttr "telemetry.sdk.language" "haskell"
+        ]
+    convertTo ComputeUnitContainer{..} =
+        [ strAttr "container.name" _cucName
+        , strAttr "container.image.name" _cucImageName
+        ]
+    convertTo ComputeInstanceHost{..} =
+        [ strAttr "host.name" _cihHost
+        , strAttr "host.hostname" _cihHost
+        , strAttr "host.id" _cihId
+        ]
+
+
+data ResourceHeader = ResourceHeader
+    { _rServiceHeader :: ServiceHeader
+    , _rExtraHeaders :: [ ExtraResourceHeader ]
+    } deriving (Eq, Show)
+
+$(deriveJSON (jsonOpts 2) ''ResourceHeader)
+
+instance ConversionTo ResourceHeader R.Resource where
+    convertTo ResourceHeader{..} =
+        defMessage
+          & R.attributes  .~ attrs
+          & R.droppedAttributesCount .~ 0
+              where
+                c a = (convertTo a) :: [C.AttributeKeyValue]
+                attrs = c _rServiceHeader ++ (L.concat $ fmap c _rExtraHeaders)

opentelemetry-extra/exe/eventlog-to-opentelemetry/OpenTelemetry/Spans.hs

@@ -0,0 +1,84 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+module OpenTelemetry.Spans where
+
+import Data.ByteString as BS
+import Data.ByteString.Builder as BSB
+import Data.ByteString.Lazy as LBS
+import Data.Coerce
+import qualified Data.HashMap.Strict as HM
+
+import Data.ProtoLens (defMessage)
+import Data.Word
+import Lens.Micro
+import OpenTelemetry.Attribute
+import OpenTelemetry.Common as OTC
+import OpenTelemetry.SpanContext
+import OpenTelemetry.Resource
+import Proto.Opentelemetry.Proto.Common.V1.Common as C
+import Proto.Opentelemetry.Proto.Common.V1.Common_Fields as C
+import Proto.Opentelemetry.Proto.Trace.V1.Trace as T
+import Proto.Opentelemetry.Proto.Trace.V1.Trace_Fields as T
+
+
+instrLib :: C.InstrumentationLibrary
+instrLib = defMessage
+            & C.name .~ "OpenTelemetry-haskell"
+            & C.version .~ "0.4.0"
+
+
+spansToLibSpans :: [OTC.Span] -> T.InstrumentationLibrarySpans
+spansToLibSpans sps =
+    defMessage
+      & T.instrumentationLibrary .~ instrLib
+      & T.spans .~ (fmap span2Span sps)
+
+
+w8 :: Word64 -> BSB.Builder
+w8 = word64LE
+
+sbs :: BSB.Builder -> BS.ByteString
+sbs = toStrict . toLazyByteString
+
+maybeSpanToBytes :: Maybe SpanId -> BS.ByteString
+maybeSpanToBytes Nothing = mempty
+maybeSpanToBytes (Just (SId parentSid)) = sbs $ w8 parentSid
+
+newtype AttributeTags = AttributeTags (HM.HashMap TagName TagValue)
+
+instance ConversionTo AttributeTags [C.AttributeKeyValue]  where
+    convertTo (AttributeTags m) = fmap tuple2Attr $ HM.toList m
+            where tuple2Attr (TagName k, v) = tagToAttribute k v
+newtype AttributeSpanEvent = AttributeSpanEvent SpanEvent
+
+instance ConversionTo AttributeSpanEvent T.Span'Event where
+    convertTo (AttributeSpanEvent SpanEvent{..}) =
+        defMessage
+        & T.name .~ (coerce spanEventKey)
+        & T.droppedAttributesCount .~ 0
+        & T.timeUnixNano .~ spanEventTimestamp
+        & T.attributes .~ [strAttr "text" $ coerce spanEventValue]
+
+span2Span :: OTC.Span -> T.Span
+span2Span Span{..} =
+    case spanContext of
+      SpanContext (SId sid) (TId tid) ->
+          defMessage
+           & T.traceId .~ (sbs $ w8 sid <> w8 sid)
+           & T.spanId .~ (sbs $ w8 tid)
+           -- & T.traceState .~
+           & T.parentSpanId .~ (maybeSpanToBytes spanParentId)
+           & T.name .~ spanOperation
+           -- & T.kind .~ not enough info
+           & T.startTimeUnixNano .~ spanStartedAt
+           & T.endTimeUnixNano .~ spanFinishedAt
+           & T.attributes .~ (convertTo $ AttributeTags spanTags)
+           & T.events .~ (fmap (convertTo . AttributeSpanEvent) spanEvents)
+           & T.droppedAttributesCount .~ 0
+           & T.links .~ []
+           & T.droppedLinksCount .~ 0
+           & T.status .~ (defMessage & T.code .~ T.Status'Ok)

opentelemetry-extra/opentelemetry-extra.cabal

@@ -164,3 +164,30 @@ executable eventlog-to-tracy
     opentelemetry >= 0.4.0,
     opentelemetry-extra,
     process,
+
+executable eventlog-to-opentelemetry
+  import: options
+  main-is:    Main.hs
+  hs-source-dirs: exe/eventlog-to-opentelemetry
+  other-modules:
+    OpenTelemetry.Console,
+    OpenTelemetry.Json,
+    OpenTelemetry.Resource,
+    OpenTelemetry.Attribute,
+    OpenTelemetry.Spans
+  build-depends:
+    aeson,
+    base,
+    bytestring,
+    clock,
+    filepath,
+    microlens,
+    microlens-th,
+    opentelemetry >= 0.4.0,
+    opentelemetry-extra,
+    opentelemetry-proto,
+    optparse-applicative,
+    proto-lens,
+    text,
+    unordered-containers,
+  default-language: Haskell2010

opentelemetry-proto/LICENSE

@@ -0,0 +1,7 @@
+Copyright 2020-present Dmitry Ivanov
+
+Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at
+
+http://www.apache.org/licenses/LICENSE-2.0
+
+Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the License for the specific language governing permissions and limitations under the License.

opentelemetry-proto/Setup.hs

@@ -0,0 +1,3 @@
+import Data.ProtoLens.Setup
+
+main = defaultMainGeneratingProtos "proto"