diff --git a/.gitmodules b/.gitmodules new file mode 100644 index 0000000..bb41324 --- /dev/null +++ b/.gitmodules @@ -0,0 +1,3 @@ +[submodule "proto"] + path = opentelemetry-proto/proto + url = https://github.com/open-telemetry/opentelemetry-proto.git diff --git a/opentelemetry-extra/exe/eventlog-to-opentelemetry/Main.hs b/opentelemetry-extra/exe/eventlog-to-opentelemetry/Main.hs new file mode 100644 index 0000000..7844907 --- /dev/null +++ b/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 diff --git a/opentelemetry-extra/exe/eventlog-to-opentelemetry/OpenTelemetry/Attribute.hs b/opentelemetry-extra/exe/eventlog-to-opentelemetry/OpenTelemetry/Attribute.hs new file mode 100644 index 0000000..eb1b8bf --- /dev/null +++ b/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) diff --git a/opentelemetry-extra/exe/eventlog-to-opentelemetry/OpenTelemetry/Console.hs b/opentelemetry-extra/exe/eventlog-to-opentelemetry/OpenTelemetry/Console.hs new file mode 100644 index 0000000..ce29502 --- /dev/null +++ b/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 diff --git a/opentelemetry-extra/exe/eventlog-to-opentelemetry/OpenTelemetry/Json.hs b/opentelemetry-extra/exe/eventlog-to-opentelemetry/OpenTelemetry/Json.hs new file mode 100644 index 0000000..b6d6cee --- /dev/null +++ b/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 + } diff --git a/opentelemetry-extra/exe/eventlog-to-opentelemetry/OpenTelemetry/Resource.hs b/opentelemetry-extra/exe/eventlog-to-opentelemetry/OpenTelemetry/Resource.hs new file mode 100644 index 0000000..aff7640 --- /dev/null +++ b/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) diff --git a/opentelemetry-extra/exe/eventlog-to-opentelemetry/OpenTelemetry/Spans.hs b/opentelemetry-extra/exe/eventlog-to-opentelemetry/OpenTelemetry/Spans.hs new file mode 100644 index 0000000..5019155 --- /dev/null +++ b/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) diff --git a/opentelemetry-extra/opentelemetry-extra.cabal b/opentelemetry-extra/opentelemetry-extra.cabal index 5f48ccb..9336c37 100644 --- a/opentelemetry-extra/opentelemetry-extra.cabal +++ b/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 diff --git a/opentelemetry-proto/LICENSE b/opentelemetry-proto/LICENSE new file mode 100644 index 0000000..e2277b5 --- /dev/null +++ b/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. diff --git a/opentelemetry-proto/Setup.hs b/opentelemetry-proto/Setup.hs new file mode 100644 index 0000000..0498b1c --- /dev/null +++ b/opentelemetry-proto/Setup.hs @@ -0,0 +1,3 @@ +import Data.ProtoLens.Setup + +main = defaultMainGeneratingProtos "proto" diff --git a/opentelemetry-proto/opentelemetry-proto.cabal b/opentelemetry-proto/opentelemetry-proto.cabal new file mode 100644 index 0000000..776ec7e --- /dev/null +++ b/opentelemetry-proto/opentelemetry-proto.cabal @@ -0,0 +1,55 @@ +cabal-version: 2.4 +name: opentelemetry-proto +description: OpenTelemetry Protobuf Data types +category: OpenTelemetry +version: 0.4.2 +license-file: LICENSE +license: Apache-2.0 +author: Dmitry Ivanov +maintainer: ethercrow@gmail.com +build-type: Custom +extra-source-files: + proto/opentelemetry/proto/common/v1/common.proto + proto/opentelemetry/proto/resource/v1/resource.proto, + proto/opentelemetry/proto/trace/v1/trace.proto + +source-repository head + type: git + location: https://github.com/ethercrow/opentelemetry-haskell + +common options + default-language: Haskell2010 + ghc-options: + -Wall + -Wcompat + -Widentities + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wpartial-fields + -fhide-source-paths + -ferror-spans + -freverse-errors + + + +custom-setup + setup-depends: + Cabal + , base + , proto-lens-setup + + +library + import: options + build-depends: + base >= 4.12 && < 5, + proto-lens-runtime + exposed-modules: + Proto.Opentelemetry.Proto.Common.V1.Common, + Proto.Opentelemetry.Proto.Common.V1.Common_Fields, + Proto.Opentelemetry.Proto.Resource.V1.Resource, + Proto.Opentelemetry.Proto.Resource.V1.Resource_Fields, + Proto.Opentelemetry.Proto.Trace.V1.Trace, + Proto.Opentelemetry.Proto.Trace.V1.Trace_Fields + other-modules: + Paths_opentelemetry_proto diff --git a/opentelemetry-proto/proto b/opentelemetry-proto/proto new file mode 160000 index 0000000..28e2774 --- /dev/null +++ b/opentelemetry-proto/proto @@ -0,0 +1 @@ +Subproject commit 28e2774262a651c4c2e701c3a05820c3e43ead71 diff --git a/ot-header.json b/ot-header.json new file mode 100644 index 0000000..5b4e8d7 --- /dev/null +++ b/ot-header.json @@ -0,0 +1,9 @@ +{ + "ServiceHeader": { + "Name": "service1", + "NameSpace": "*", + "InstanceId": "74036208-6af7-4f12-b260-23bb2f1334d3", + "Version": "version:0.0.1" + }, + "ExtraHeaders": [] +} diff --git a/stack-8.10.1.yaml b/stack-8.10.1.yaml index b03fe0f..6ed3fa2 100644 --- a/stack-8.10.1.yaml +++ b/stack-8.10.1.yaml @@ -1,10 +1,11 @@ -resolver: lts-15.13 +resolver: lts-15.15 compiler: ghc-8.10.1 packages: - megaexample - opentelemetry - opentelemetry-extra - opentelemetry-lightstep +- opentelemetry-proto - opentelemetry-wai allow-newer: true @@ -12,3 +13,5 @@ allow-newer: true extra-deps: - ghc-events-0.13.0 - ghc-trace-events-0.1.0.1 +- ghc-source-gen-0.4.0.0 +- proto-lens-0.7.0.0 diff --git a/stack.yaml b/stack.yaml index e6ce014..fbca5e4 100644 --- a/stack.yaml +++ b/stack.yaml @@ -5,6 +5,7 @@ packages: - opentelemetry - opentelemetry-extra - opentelemetry-lightstep +- opentelemetry-proto - opentelemetry-wai extra-deps: