packages feed

opentelemetry (empty) → 0.0.0.0

raw patch · 12 files changed

+558/−0 lines, 12 filesdep +asyncdep +basedep +clocksetup-changed

Dependencies added: async, base, clock, exceptions, hashable, opentelemetry, random, tasty, tasty-discover, tasty-quickcheck, text, unordered-containers

Files

+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ just-some-usage-code-that-must-compile/Main.hs view
@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "All done"
+ just-some-usage-code-that-must-compile/SomeUsageOfExplicitApi.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE OverloadedStrings #-}++module SomeUsageOfExplicitApi where++import Control.Concurrent+import OpenTelemetry.Explicit+import OpenTelemetry.FileExporter++main :: IO ()+main = do+  exporter <- createFileSpanExporter "helloworld.trace"+  ot <- createOpenTelemetryClient exporter+  --+  mainSpan <- startRootSpan ot "main"+  threadDelay 10000+  warmUpSpan <- startChildSpan ot mainSpan "warm up the cache"+  threadDelay 5000+  addEvent ot warmUpSpan "still cold"+  threadDelay 10000+  addEvent ot warmUpSpan "warm now"+  setTag ot warmUpSpan "size" 9001+  endSpan ot warmUpSpan+  dataScienceSpan <- startChildSpan ot mainSpan "perform data science"+  threadDelay 100000+  setTag ot dataScienceSpan "reviews" 0+  endSpan ot dataScienceSpan+  threadDelay 10000+  endSpan ot mainSpan
+ just-some-usage-code-that-must-compile/SomeUsageOfImplicitApi.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++module SomeUsageOfImplicitApi where++import Control.Concurrent+import Control.Concurrent.Async+import Control.Monad+import OpenTelemetry.Common+import OpenTelemetry.FileExporter+import OpenTelemetry.Implicit++main :: IO ()+main = do+  exporter <- createFileSpanExporter "helloworld.trace"+  let otConfig =+        OpenTelemetryConfig+          { otcSpanExporter = exporter+          }+  withOpenTelemetry otConfig $ do+    result <- pieceOfSeriousBusinessLogic 42+    print result++pieceOfSeriousBusinessLogic :: Int -> IO Int+pieceOfSeriousBusinessLogic input = withSpan "serious business" $ do+  let result = 2 * input+  -- setTag is value-polymorphic++  -- setTag "input" input -- Int (inferred)+  -- setTag @Int "result" result -- Int (explicit)+  -- setTag @String "seriousness" "serious" -- literals are polymorphic under OverloadedStrings so we need to annotate+  -- setTag @Double "profit" 99 -- numeric literals are also polymorphic+  -- setTag "error" False -- Bool literals are not polymorphic+  -- setTag @Int "largest integer below 100" 99 -- Int (inferred)++  -- TODO: JSON values++  addEvent "rpc roundtrip begin"+  withSpan "leveraging synergies" $ do+    threadDelay 10000+    addEvent "enough synergies leveraged"+  addEvent "All your base are belong to us"+  addEvent "rpc roundtrip end"+  withSpan "project" $ do+    -- Connecting spans across threads requires some manual plumbing+    sp <- getCurrentActiveSpan+    asyncWork <- async $ withChildSpanOf sp "data science" $ do+      threadDelay 1000000+      pure 42+    -- Doing a withSpan inside a loop is fine+    forM_ [input .. input + 10] $ \i -> withSpan "sprint" $ do+      -- setTag "week" i+      threadDelay 10000+    wait asyncWork+  pure result
+ opentelemetry.cabal view
@@ -0,0 +1,87 @@+cabal-version:       2.4+name:                opentelemetry+description:         The OpenTelemetry Haskell Client https://opentelemetry.io+category:            OpenTelemetry+version:             0.0.0.0+license-file:        LICENSE+license:             Apache-2.0+author:              Dmitry Ivanov+maintainer:          ethercrow@gmail.com+build-type:          Simple++source-repository head+  type: git+  location: https://github.com/ethercrow/opentelemetry-haskell++common options+  default-language: Haskell2010+  default-extensions:+    BangPatterns+    BlockArguments+    DataKinds+    FlexibleInstances+    LambdaCase+    MultiParamTypeClasses+    MultiWayIf+    NamedFieldPuns+    NumericUnderscores+    RecordWildCards+    ScopedTypeVariables+    TupleSections+    TypeApplications+    ViewPatterns+  ghc-options:+    -Wall+    -Wcompat+    -Widentities+    -Wincomplete-record-updates+    -Wincomplete-uni-patterns+    -Wpartial-fields+    -Wredundant-constraints+    -fhide-source-paths+    -ferror-spans+    -freverse-errors++library+  import: options+  build-depends:+    base >= 4.12 && < 5,+    clock >= 0.8,+    exceptions,+    hashable,+    random >= 1.1,+    text,+    unordered-containers+  hs-source-dirs: src+  exposed-modules:+    OpenTelemetry.Common+    OpenTelemetry.Explicit+    OpenTelemetry.Implicit+    OpenTelemetry.FileExporter++test-suite just-some-usage-code-that-must-compile+  import: options+  type:       exitcode-stdio-1.0+  main-is:    Main.hs+  other-modules:+    SomeUsageOfImplicitApi+    SomeUsageOfExplicitApi+  hs-source-dirs: just-some-usage-code-that-must-compile+  build-depends:+    base,+    async,+    opentelemetry++test-suite unit-tests+  import: options+  type:       exitcode-stdio-1.0+  main-is:    Main.hs+  other-modules:+    TestCommon+  hs-source-dirs: unit-tests+  build-depends:+    base,+    tasty,+    tasty-quickcheck,+    tasty-discover,+    opentelemetry
+ src/OpenTelemetry/Common.hs view
@@ -0,0 +1,133 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE OverloadedStrings #-}++module OpenTelemetry.Common where++import qualified Data.HashMap.Strict as HM+import Data.Hashable+import qualified Data.List.NonEmpty as NE+import Data.List.NonEmpty (NonEmpty ((:|)), (<|))+import qualified Data.Text as T+import Data.Word+import System.Clock++newtype TraceId = TId Word64+  deriving (Show, Eq)+  deriving (Hashable) via Word64++newtype SpanId = SId Word64+  deriving (Show, Eq)+  deriving (Hashable) via Word64++type Timestamp = Word64++data Tracer threadId+  = Tracer+      { tracerSpanStacks :: !(HM.HashMap threadId (NE.NonEmpty Span)),+        trace2thread :: !(HM.HashMap TraceId threadId)+      }+      deriving (Eq, Show)++tracerPushSpan :: (Eq tid, Hashable tid) => Tracer tid -> tid -> Span -> Tracer tid+tracerPushSpan t@(Tracer {..}) tid sp =+  case HM.lookup tid tracerSpanStacks of+    Nothing ->+      let !stacks = HM.insert tid (sp :| []) tracerSpanStacks+          !t2t = HM.insert (spanTraceId sp) tid trace2thread+      in Tracer stacks t2t+    Just sps ->+      let !stacks = HM.insert tid (sp <| sps) tracerSpanStacks+      in t { tracerSpanStacks = stacks }++tracerPopSpan :: (Eq tid, Hashable tid) => Tracer tid -> tid -> (Maybe Span, Tracer tid)+tracerPopSpan t@(Tracer {..}) tid =+  case HM.lookup tid tracerSpanStacks of+    Nothing -> (Nothing, t)+    Just (sp :| sps) ->+      let (stacks, t2t) =+            case NE.nonEmpty sps of+              Nothing -> (HM.delete tid tracerSpanStacks, HM.delete (spanTraceId sp) trace2thread)+              Just sps' -> (HM.insert tid sps' tracerSpanStacks, trace2thread)+       in (Just sp, Tracer stacks t2t)++tracerGetCurrentActiveSpan :: (Hashable tid, Eq tid) => Tracer tid -> tid -> Maybe Span+tracerGetCurrentActiveSpan (Tracer stacks _) tid =+  case HM.lookup tid stacks of+    Nothing -> Nothing+    Just (sp NE.:| _) -> Just sp++createTracer :: (Hashable tid, Eq tid) => IO (Tracer tid)+createTracer = pure $ Tracer mempty mempty++data SpanContext = SpanContext !SpanId !TraceId+  deriving (Show, Eq)++data TagValue+  = StringTagValue !T.Text+  | BoolTagValue !Bool+  | IntTagValue !Int+  | DoubleTagValue !Double+  deriving (Eq, Show)++class ToTagValue a where+  toTagValue :: a -> TagValue++instance ToTagValue String where+  toTagValue = StringTagValue . T.pack++data Span+  = Span+      { spanContext :: {-# UNPACK #-} !SpanContext,+        spanOperation :: T.Text,+        spanStartedAt :: !Timestamp,+        spanFinishedAt :: !Timestamp,+        spanTags :: !(HM.HashMap T.Text TagValue),+        spanStatus :: !SpanStatus+      }+  deriving (Show, Eq)++emptySpan :: Span+emptySpan = Span (SpanContext (SId 0) (TId 0)) "" 0 0 mempty OK++spanTraceId :: Span -> TraceId+spanTraceId Span {spanContext = SpanContext _ tid} = tid++spanId :: Span -> SpanId+spanId Span {spanContext = SpanContext sid _} = sid++data SpanStatus = OK+  deriving (Show, Eq)++data Event+  = Event T.Text Timestamp+  deriving (Show, Eq)++data SpanProcessor+  = SpanProcessor+      { onStart :: Span -> IO (),+        onEnd :: Span -> IO ()+      }++data ExportResult+  = ExportSuccess+  | ExportFailedRetryable+  | ExportFailedNotRetryable+  deriving (Show, Eq)++data Exporter thing+  = Exporter+      { export :: [thing] -> IO ExportResult,+        shutdown :: IO ()+      }++data OpenTelemetryConfig+  = OpenTelemetryConfig+      { otcSpanExporter :: Exporter Span+      }++now64 :: IO Timestamp+now64 = do+  TimeSpec secs nsecs <- getTime Monotonic+  pure $! fromIntegral secs * 1_000_000_000 + fromIntegral nsecs
+ src/OpenTelemetry/Explicit.hs view
@@ -0,0 +1,50 @@+module OpenTelemetry.Explicit+  ( startRootSpan,+    startChildSpan,+    endSpan,+    setTag,+    addEvent,+    createOpenTelemetryClient,+  )+where++import qualified Data.Text as T+import GHC.Conc+import OpenTelemetry.Common+import System.Clock+import System.Random++data Client+  = Client+      { cTracer :: Tracer ThreadId,+        cSpanExporter :: Exporter Span+      }++startRootSpan :: Client -> T.Text -> IO Span+startRootSpan _tracer name = do+  timestamp <- now64+  sid <- randomIO+  pure $! Span (SpanContext (SId sid) (TId sid)) name timestamp 0 mempty OK++startChildSpan :: Client -> Span -> T.Text -> IO Span+startChildSpan _tracer parent name = do+  timestamp <- now64+  sid <- randomIO+  pure $! Span (SpanContext (SId sid) (spanTraceId parent)) name timestamp 0 mempty OK++endSpan :: Client -> Span -> IO ()+endSpan _tracer sp = do+  timestamp <- now64+  pure $! sp {spanFinishedAt = timestamp}+  pure ()++setTag :: Monad m => Client -> Span -> T.Text -> value -> m ()+setTag _tracer _span _key _value = pure ()++addEvent :: Monad m => Client -> Span -> T.Text -> m ()+addEvent _tracer _span _name = pure ()++createOpenTelemetryClient :: Exporter Span -> IO Client+createOpenTelemetryClient e = do+  t <- createTracer+  pure $ Client t e
+ src/OpenTelemetry/FileExporter.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE OverloadedStrings #-}++module OpenTelemetry.FileExporter where++import Data.Function+import qualified Data.HashMap.Strict as HM+import Data.List+import qualified Data.Text as T+import OpenTelemetry.Common+import System.IO+import Text.Printf+import Text.Read++showValue :: TagValue -> String+showValue (StringTagValue s) = show s+showValue (IntTagValue i) = show i++showSpan :: Span -> String+showSpan s@(Span {..}) =+  let (TId tid) = spanTraceId s+      threadId = case HM.lookup "thread_id" spanTags of+        Just (StringTagValue (T.stripPrefix "ThreadId " -> Just (readMaybe . T.unpack -> Just t))) -> t+        Just (IntTagValue t) -> t+        _ -> fromIntegral tid+      meta :: String+      meta =+        spanTags+          & HM.toList+          & map (\(k, v) -> ["\"", T.unpack k, "\":", showValue v])+          & intersperse [","]+          & concat+          & concat+   in printf+        "{\"ph\":\"B\",\"name\":\"%s\",\"pid\":1,\"ts\":%d,\"tid\":%d,\"meta\":{%s}},{\"ph\":\"E\",\"name\":\"%s\",\"pid\":1,\"ts\":%d,\"tid\":%d},"+        spanOperation+        (div spanStartedAt 1000)+        threadId+        meta+        spanOperation+        (div spanFinishedAt 1000)+        threadId++createFileSpanExporter :: FilePath -> IO (Exporter Span)+createFileSpanExporter path = do+  f <- openFile path WriteMode+  hPutStrLn f "["+  pure+    $! Exporter+      ( \sps -> do+          mapM_ (hPutStrLn f . showSpan) sps+          pure ExportSuccess+      )+      ( do+          hSeek f RelativeSeek (-2) -- overwrite the last comma+          hPutStrLn f "\n]"+          hClose f+      )
+ src/OpenTelemetry/Implicit.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}++module OpenTelemetry.Implicit where++import Control.Concurrent+import Control.Monad.Catch+import Control.Monad.IO.Class+import qualified Data.HashMap.Strict as HM+import qualified Data.List.NonEmpty as NE+import Data.List.NonEmpty (NonEmpty ((:|)))+import Data.Maybe+import qualified Data.Text as T+import GHC.Conc+import OpenTelemetry.Common+import System.IO+import System.IO.Unsafe+import System.Random++withSpan :: (MonadIO m, MonadMask m) => String -> m a -> m a+withSpan operation action = do+  threadId <- liftIO myThreadId+  sid <- liftIO randomIO+  startedAt <- liftIO now64+  bracket+    ( liftIO $ modifyMVar_ globalSharedMutableState $ \GlobalSharedMutableState {..} -> do+        let !ctx = case HM.lookup threadId (tracerSpanStacks gTracer) of+              Nothing -> SpanContext (SId sid) (TId sid)+              Just ((spanContext -> SpanContext _ tid) :| _) -> SpanContext (SId sid) tid+            !sp = Span ctx (T.pack operation) startedAt 0 (HM.singleton "thread_id" (StringTagValue $ T.pack $ show threadId)) OK+            !tracer = tracerPushSpan gTracer threadId sp+        pure $! GlobalSharedMutableState gSpanExporter tracer+    )+    ( \_ -> do+        liftIO $ modifyMVar_ globalSharedMutableState $ \GlobalSharedMutableState {..} -> do+          let (mspan, tracer) = tracerPopSpan gTracer threadId+          case mspan of+            Nothing -> pure ()+            Just sp -> do+              finishedAt <- liftIO now64+              res <- export gSpanExporter [sp {spanFinishedAt = finishedAt}]+              case res of+                ExportSuccess -> pure ()+                _ -> error $ "exporting span failed: " <> show sp+          pure $! GlobalSharedMutableState gSpanExporter tracer+    )+    (\_ -> action) -- TODO(divanov): set error=true on exception++setTag :: forall value m. (MonadIO m, ToTagValue value) => T.Text -> value -> m ()+setTag k v =+  modifyCurrentSpan+    ( \sp ->+        sp {spanTags = HM.insert k (toTagValue v) (spanTags sp)}+    )++addEvent :: forall m. MonadIO m => T.Text -> m ()+addEvent name = do+  tid <- liftIO myThreadId+  error "addEvent: not implemented"++withOpenTelemetry :: (MonadIO m, MonadMask m) => OpenTelemetryConfig -> m a -> m a+withOpenTelemetry OpenTelemetryConfig {..} action = do+  bracket+    ( liftIO $ do+        tracer <- createTracer+        putMVar globalSharedMutableState (GlobalSharedMutableState otcSpanExporter tracer)+        pure ()+    )+    (\_ -> liftIO $ shutdown otcSpanExporter)+    (\_ -> action)++data GlobalSharedMutableState+  = GlobalSharedMutableState+      { gSpanExporter :: !(Exporter Span),+        gTracer :: !(Tracer ThreadId)+      }++getCurrentActiveSpan :: MonadIO m => m Span+getCurrentActiveSpan = do+  tid <- liftIO myThreadId+  GlobalSharedMutableState {..} <- liftIO $ readMVar globalSharedMutableState+  pure $ fromMaybe emptySpan $ tracerGetCurrentActiveSpan gTracer tid++modifyCurrentSpan :: MonadIO m => (Span -> Span) -> m ()+modifyCurrentSpan f = liftIO $ do+  tid <- myThreadId+  modifyMVar_+    globalSharedMutableState+    ( \g@(GlobalSharedMutableState {..}) ->+        case HM.lookup tid (tracerSpanStacks gTracer) of+          Nothing -> pure g+          Just (sp :| sps) ->+            let !stacks = HM.insert tid (f sp :| sps) (tracerSpanStacks gTracer)+             in pure $! g {gTracer = gTracer {tracerSpanStacks = stacks}}+    )++withChildSpanOf :: (MonadIO m, MonadMask m) => Span -> String -> m a -> m a+withChildSpanOf parent operation action = do+  threadId <- liftIO myThreadId+  sid <- liftIO randomIO+  timestamp <- liftIO now64+  bracket+    ( liftIO $ modifyMVar_ globalSharedMutableState $ \GlobalSharedMutableState {..} -> do+        let threadId' = fromMaybe threadId $ HM.lookup (spanTraceId parent) (trace2thread gTracer)+        let !ctx = case HM.lookup threadId' (tracerSpanStacks gTracer) of+              Nothing -> SpanContext (SId sid) (TId sid)+              Just ((spanContext -> SpanContext _ tid) NE.:| _) -> SpanContext (SId sid) tid+            !sp = Span ctx (T.pack operation) timestamp 0 mempty OK+            !tracer = tracerPushSpan gTracer threadId sp+        pure $! GlobalSharedMutableState gSpanExporter tracer+    )+    (\_ -> pure ())+    (\_ -> action)++globalSharedMutableState :: MVar GlobalSharedMutableState+globalSharedMutableState = unsafePerformIO newEmptyMVar+{-# NOINLINE globalSharedMutableState #-}
+ unit-tests/Main.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF tasty-discover #-}
+ unit-tests/TestCommon.hs view
@@ -0,0 +1,19 @@+module TestCommon where++import OpenTelemetry.Common+import Data.Word++prop_tracer_push_does_something :: Word64 -> Word64 -> Int -> Bool+prop_tracer_push_does_something sid tid threadid =+  let tracer0 = Tracer mempty mempty+      sp0 = emptySpan { spanContext = SpanContext (SId sid) (TId tid) }+      tracer1 = tracerPushSpan tracer0 threadid sp0+  in tracer0 /= tracer1++prop_tracer_push_pop :: Word64 -> Word64 -> Int -> Bool+prop_tracer_push_pop sid tid threadid =+  let tracer0 = Tracer mempty mempty+      sp0 = emptySpan { spanContext = SpanContext (SId sid) (TId tid) }+      tracer1 = tracerPushSpan tracer0 threadid sp0+      (Just sp1, tracer2) = tracerPopSpan tracer1 threadid+  in tracer0 == tracer2 && sp0 == sp1