packages feed

lightstep-haskell 0.5.2 → 0.6.0

raw patch · 9 files changed

+169/−74 lines, 9 filesdep +case-insensitivedep +deepseqdep +hashabledep ~base

Dependencies added: case-insensitive, deepseq, hashable, tasty, tasty-discover, tasty-hunit, tasty-quickcheck

Dependency ranges changed: base

Files

examples/req/Main.hs view
@@ -1,8 +1,9 @@ {-# LANGUAGE OverloadedStrings #-}  import Control.Concurrent+import Data.CaseInsensitive (original) import LightStep.HighLevel.IO-import LightStep.Propagation (b3headersForSpanContext)+import LightStep.Propagation (b3Propagator, inject) import Network.HTTP.Req  clientMain :: IO ()@@ -11,7 +12,7 @@     setTag "span.kind" "client"     setTag "component" "http"     Just ctx <- currentSpanContext-    let opts = port 8736 <> foldMap (\(k, v) -> header k v) (b3headersForSpanContext ctx)+    let opts = port 8736 <> foldMap (\(k, v) -> header (original k) v) (inject b3Propagator ctx)         url = http "127.0.0.1" /: "test"     _ <- runReq defaultHttpConfig $ req GET url NoReqBody ignoreResponse opts     pure ()
examples/wai/Main.hs view
@@ -3,7 +3,7 @@ import qualified Data.ByteString.Lazy.Char8 as LBS import GHC.Stats import LightStep.Diagnostics-import LightStep.HighLevel.IO (getEnvConfig, withSingletonLightStep)+import LightStep.HighLevel.IO (getEnvConfig, withSingletonLightStep, withSpan) import Network.HTTP.Types import Network.Wai import Network.Wai.Handler.Warp (run)@@ -11,7 +11,7 @@  robustScalableProductionReadyMicroservice :: Application robustScalableProductionReadyMicroservice = \_req respond -> do-  rtsStats <- getRTSStats+  rtsStats <- withSpan "getRTSStats" getRTSStats   diagnostics <- getDiagnostics   respond $     responseLBS
lightstep-haskell.cabal view
@@ -1,7 +1,7 @@ cabal-version: 2.4  name:           lightstep-haskell-version:        0.5.2+version:        0.6.0 synopsis:       LightStep OpenTracing client library description:    LightStep OpenTracing client library. Uses GRPC transport via proto-lens. category:       Tools@@ -74,6 +74,7 @@     , bytestring     , chronos     , containers+    , hashable     , http-types     , http2-client >= 0.9.0.0     , http2-client-grpc >= 0.8.0.0@@ -147,9 +148,11 @@   build-depends:       base >=4.9 && <5     , lightstep-haskell+    , case-insensitive     , http-types     , text     , req >= 3.0.0+    , unordered-containers  executable lightstep-haskell-stress-test   import: options@@ -165,3 +168,24 @@     , lightstep-haskell     , text     , async++test-suite unit+  import: options+  type:       exitcode-stdio-1.0+  main-is:    Main.hs+  other-modules:+    TestPropagation+  hs-source-dirs:+    unit-test+  build-depends:+    base,+    deepseq,+    lens,+    tasty,+    tasty-quickcheck,+    tasty-hunit,+    tasty-discover,+    lightstep-haskell,+    proto-lens >= 0.5.1.0,+    proto-lens-protobuf-types >= 0.5.0.0,+    proto-lens-runtime >= 0.5.0.0
src/LightStep/HighLevel/IO.hs view
@@ -4,6 +4,7 @@   ( module LightStep.HighLevel.IO,     module LightStep.LowLevel,     module LightStep.Config,+    SpanContext,   ) where @@ -18,26 +19,26 @@ import Data.ProtoLens.Message (defMessage) import qualified Data.Text as T import GHC.Conc-import LightStep.Internal.Debug+import LightStep.Config import LightStep.Diagnostics+import LightStep.Internal.Debug import LightStep.LowLevel import Proto.Collector import Proto.Collector_Fields import System.IO.Unsafe import System.Timeout-import LightStep.Config  {-# NOINLINE globalSharedMutableSpanStacks #-} globalSharedMutableSpanStacks :: MVar (HM.HashMap ThreadId [Span]) globalSharedMutableSpanStacks = unsafePerformIO (newMVar mempty) -data LogEntryKey =  ErrorKind | Event | Message | Stack | Custom T.Text+data LogEntryKey = ErrorKind | Event | Message | Stack | Custom T.Text  showLogEntryKey :: LogEntryKey -> T.Text-showLogEntryKey ErrorKind  = T.pack "error.kind"-showLogEntryKey Event      = T.pack "event"-showLogEntryKey Message    = T.pack "message"-showLogEntryKey Stack      = T.pack "stack"+showLogEntryKey ErrorKind = T.pack "error.kind"+showLogEntryKey Event = T.pack "event"+showLogEntryKey Message = T.pack "message"+showLogEntryKey Stack = T.pack "stack" showLogEntryKey (Custom x) = x  withSpan :: forall m a. MonadIO m => MonadMask m => T.Text -> m a -> m a@@ -46,10 +47,10 @@       onExc ex = do         setTag "error" "true"         setTag "error.message" (T.pack $ displayException ex)-  in bracket-    (pushSpan opName)-    popSpan-    (const (withException action onExc))+   in bracket+        (pushSpan opName)+        popSpan+        (const (withException action onExc))  pushSpan :: MonadIO m => T.Text -> m () pushSpan opName = liftIO $ do@@ -58,8 +59,9 @@   modifyMVar_ globalSharedMutableSpanStacks $ \stacks ->     case fromMaybe [] (HM.lookup tId stacks) of       [] -> do-        let !sp' = sp-              & tags %~ (<> [defMessage & key .~ "thread" & stringValue .~ T.pack (show tId)])+        let !sp' =+              sp+                & tags %~ (<> [defMessage & key .~ "thread" & stringValue .~ T.pack (show tId)])         pure $! HM.insert tId [sp'] stacks       (psp : _) ->         let !sp' =@@ -103,7 +105,6 @@           Just (sp : _) -> Just $ sp ^. spanContext           _ -> Nothing   pure ctx-      setTag :: MonadIO m => T.Text -> T.Text -> m () setTag k v =@@ -114,9 +115,10 @@   modifyCurrentSpan (logs %~ (<> [defMessage & fields .~ [defMessage & key .~ showLogEntryKey k & stringValue .~ v]]))  setParentSpanContext :: MonadIO m => SpanContext -> m ()-setParentSpanContext ctx = modifyCurrentSpan $ \sp -> sp-  & references .~ [defMessage & relationship .~ Reference'CHILD_OF & spanContext .~ ctx]-  & spanContext . traceId .~ (ctx ^. traceId)+setParentSpanContext ctx = modifyCurrentSpan $ \sp ->+  sp+    & references .~ [defMessage & relationship .~ Reference'CHILD_OF & spanContext .~ ctx]+    & spanContext . traceId .~ (ctx ^. traceId)  {-# NOINLINE globalSharedMutableSingletonState #-} globalSharedMutableSingletonState :: TBQueue Span
src/LightStep/LowLevel.hs view
@@ -37,6 +37,7 @@  reportSpans :: LightStepClient -> [Span] -> IO () reportSpans client@LightStepClient {..} sps = do+  print sps   let tryOnce = do         grpc <- readMVar lscGrpcVar         let req =
src/LightStep/Propagation.hs view
@@ -1,71 +1,101 @@ {-# LANGUAGE OverloadedStrings #-} -module LightStep.Propagation where+module LightStep.Propagation+  ( module P,+    module LightStep.Propagation,+  )+where  import Control.Lens-import Data.Bits import qualified Data.ByteString as BS-import Data.List (foldl')+import qualified Data.ByteString.Char8 as BS8 import Data.ProtoLens.Message (defMessage)+import Data.String import GHC.Word-import Network.HTTP.Types+import Network.HTTP.Types.Header (HeaderName) import Network.Wai-import Proto.Collector-import Proto.Collector_Fields+import Proto.Collector as P+import Proto.Collector_Fields as P+import Text.Printf -extractSpanContextFromRequest :: Request -> Maybe SpanContext-extractSpanContextFromRequest = extractSpanContextFromRequestHeaders . requestHeaders+type TextMap = [(BS.ByteString, BS.ByteString)] -extractSpanContextFromRequestHeaders :: RequestHeaders -> Maybe SpanContext-extractSpanContextFromRequestHeaders hdrs =-  case foldl' go (Nothing, Nothing) hdrs of-    (Just tid, Just sid) ->-      defMessage-        & traceId .~ tid-        & spanId .~ sid-        & Just-    _ -> Nothing-  where-    -- TODO: 128-bit x-b3-traceid-    go (_, sid) ("x-b3-traceid", decode_u64 -> Just tid) = (Just tid, sid)-    go (tid, _) ("x-b3-spanid", decode_u64 -> Just sid) = (tid, Just sid)-    go (_, sid) ("ot-tracer-traceid", decode_u64 -> Just tid) = (Just tid, sid)-    go (tid, _) ("ot-tracer-spanid", decode_u64 -> Just sid) = (tid, Just sid)-    -- TODO: Propagation of the whole span context in a single header-    -- go _ ("x-ot-span-context", parse128 -> Just (tid, sid)) = (Just tid, Just sid)+type HttpHeaders = [(HeaderName, BS.ByteString)] -    go acc _ = acc+-- TODO: Binary format. Both go and python basictracers use TracerState+-- protobuf https://github.com/opentracing/basictracer-go/blob/master/wire/wire.proto --- parse128 :: BS.ByteString -> Maybe (Word64, Word64)--- parse128 _ = Nothing -- TODO+data Propagator a+  = Propagator+      { inject :: SpanContext -> a,+        extract :: a -> Maybe SpanContext+      } -headersForSpanContext :: SpanContext -> [(BS.ByteString, BS.ByteString)]-headersForSpanContext ctx =-  [ ("ot-tracer-traceid", encode_u64 $ ctx ^. traceId),-    ("ot-tracer-spanid", encode_u64 $ ctx ^. spanId)-  ]+textPropagator :: Propagator TextMap+textPropagator =+  let prefix = "Ot-Tracer-"+   in Propagator+        { inject = injectSpanContext prefix,+          extract = extractSpanContext prefix+        } -b3headersForSpanContext :: SpanContext -> [(BS.ByteString, BS.ByteString)]-b3headersForSpanContext ctx =-  [ ("x-b3-traceid", encode_u64 $ ctx ^. traceId),-    ("x-b3-spanid", encode_u64 $ ctx ^. spanId),-    ("x-b3-sampled", "true")+httpHeadersPropagator :: Propagator HttpHeaders+httpHeadersPropagator =+  let prefix = "Ot-Tracer-"+   in Propagator+        { inject = injectSpanContext prefix,+          extract = extractSpanContext prefix+        }++b3Propagator :: Propagator HttpHeaders+b3Propagator =+  let prefix = "X-B3-"+   in Propagator+        { inject = injectSpanContext prefix,+          extract = extractSpanContext prefix+        }++injectSpanContext ::+  (IsString key, Semigroup key) =>+  key ->+  SpanContext ->+  [(key, BS.ByteString)]+injectSpanContext prefix ctx =+  [ (prefix <> "Traceid", encode_u64 $ ctx ^. traceId),+    (prefix <> "Spanid", encode_u64 $ ctx ^. spanId),+    (prefix <> "Sampled", "true")   ] +extractSpanContext ::+  (IsString key, Eq key, Semigroup key) =>+  key ->+  [(key, BS.ByteString)] ->+  Maybe SpanContext+extractSpanContext prefix format =+  (\(tid, sid) -> defMessage & traceId .~ tid & spanId .~ sid)+    <$> go format (Nothing, Nothing)+  where+    traceidKey = prefix <> "Traceid"+    spanidKey = prefix <> "Spanid"+    go _ (Just tid, Just sid) = Just (tid, sid)+    go [] _ = Nothing+    go ((k, v) : xs) (tid, sid)+      | k == traceidKey = go xs (decode_u64 v, sid)+      | k == spanidKey = go xs (tid, decode_u64 v)+      | otherwise = go xs (tid, sid)++extractSpanContextFromRequest :: Request -> Maybe SpanContext+extractSpanContextFromRequest =+  extract httpHeadersPropagator . requestHeaders++-- parse128 :: BS.ByteString -> Maybe (Word64, Word64)+-- parse128 _ = Nothing -- TODO+ encode_u64 :: Word64 -> BS.ByteString--- TODO: a better way to encode base16-encode_u64 x =-  let encodeChar :: Word8 -> Word8-      encodeChar c | c < 10 = 48 + c-      encodeChar c = 87 + c-      hexDigits = go 16 [] x-      go :: Int -> [Word8] -> Word64 -> [Word8]-      go 0 acc _ = acc-      go n acc v = go (n - 1) (encodeChar (fromIntegral v .&. 0x0f) : acc) (v `div` 16)-   in BS.pack hexDigits+encode_u64 x = BS8.pack (printf "%016x" x)  decode_u64 :: BS.ByteString -> Maybe Word64-decode_u64 bytes | BS.length bytes /= 16 = Nothing+decode_u64 bytes | BS.length bytes > 16 = Nothing decode_u64 bytes = BS.foldl' go (Just 0) bytes   where     go Nothing _ = Nothing
src/Network/Wai/Middleware/LightStep.hs view
@@ -3,11 +3,12 @@ module Network.Wai.Middleware.LightStep where  import qualified Data.Text as T-import LightStep.HighLevel.IO import qualified Data.Text.Encoding as T+import LightStep.HighLevel.IO+import LightStep.Internal.Debug import LightStep.Propagation-import Network.Wai import Network.HTTP.Types+import Network.Wai  -- Semantic conventions for HTTP spans: -- https://github.com/open-telemetry/opentelemetry-specification/blob/master/specification/data-http.md@@ -17,8 +18,10 @@   withSpan "WAI handler" $ do     case extractSpanContextFromRequest req of       Just ctx -> do+        d_ $ "Extracted context: " <> show ctx         setParentSpanContext ctx-      _ -> pure ()+      _ -> do+        d_ $ "Failed to extract context from headers " <> show (requestHeaders req)     setTag "span.kind" "server"     setTag "component" "http"     setTag "http.method" $ T.decodeUtf8 (requestMethod req)
+ unit-test/Main.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF tasty-discover #-}
+ unit-test/TestPropagation.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE OverloadedStrings #-}++module TestPropagation where++import Control.Lens+import Data.Function+import Data.ProtoLens.Message (defMessage)+import Data.Word+import LightStep.Propagation+import Test.Tasty.HUnit+import Text.Printf++prop_u64_roundtrip :: Word64 -> Bool+prop_u64_roundtrip x =+  Just x == decode_u64 (encode_u64 x)++prop_text_propagator_roundtrip :: Word64 -> Word64 -> Bool+prop_text_propagator_roundtrip tid sid =+  let c =+        defMessage+          & traceId .~ tid+          & spanId .~ sid+      p = textPropagator+   in Just c == extract p (inject p c)++prop_b3_propagator_roundtrip :: Word64 -> Word64 -> Bool+prop_b3_propagator_roundtrip tid sid =+  let c =+        defMessage+          & traceId .~ tid+          & spanId .~ sid+      p = b3Propagator+   in Just c == extract p (inject p c)