lightstep-haskell 0.8.0 → 0.9.0
raw patch · 5 files changed
+54/−43 lines, 5 filesdep +exceptionsdep +text-showdep −safe-exceptions
Dependencies added: exceptions, text-show
Dependencies removed: safe-exceptions
Files
- lightstep-haskell.cabal +3/−2
- src/LightStep/HighLevel/IO.hs +33/−16
- src/LightStep/LowLevel.hs +3/−3
- src/Network/Wai/Middleware/LightStep.hs +8/−9
- stress-test/Main.hs +7/−13
lightstep-haskell.cabal view
@@ -1,7 +1,7 @@ cabal-version: 2.4 name: lightstep-haskell-version: 0.8.0+version: 0.9.0 synopsis: LightStep OpenTracing client library description: LightStep OpenTracing client library. Uses GRPC transport via proto-lens. category: Tools@@ -85,9 +85,10 @@ , proto-lens-protobuf-types >= 0.5.0.0 , proto-lens-runtime >= 0.5.0.0 , random- , safe-exceptions+ , exceptions , stm , text+ , text-show , transformers , unordered-containers , wai
src/LightStep/HighLevel/IO.hs view
@@ -11,7 +11,7 @@ import Control.Concurrent import Control.Concurrent.Async import Control.Concurrent.STM-import Control.Exception.Safe+import Control.Monad.Catch import Control.Lens import Control.Monad.Except import qualified Data.HashMap.Strict as HM@@ -42,18 +42,28 @@ showLogEntryKey (Custom x) = x withSpan :: forall m a. MonadIO m => MonadMask m => T.Text -> m a -> m a-withSpan opName action =- let onExc :: SomeException -> m ()- onExc ex = do- setTag "error" "true"- setTag "error.message" (T.pack $ displayException ex)- in bracket- (pushSpan opName)- popSpan- (const (withException action onExc))+withSpan opName action = withSpanAndSomeInitialTags opName [] action -pushSpan :: MonadIO m => T.Text -> m ()-pushSpan opName = liftIO $ do+withSpanAndSomeInitialTags :: forall m a. MonadIO m => MonadMask m => T.Text -> [(T.Text, T.Text)] -> m a -> m a+withSpanAndSomeInitialTags opName initialTags action =+ fst <$> generalBracket+ (pushSpan opName initialTags)+ (\sp exitcase -> do+ case exitcase of+ ExitCaseSuccess _ -> pure ()+ ExitCaseException ex -> do+ setTags [+ ("error", "true"),+ ("error.message", (T.pack $ displayException ex))]+ ExitCaseAbort -> do+ setTags [+ ("error", "true"),+ ("error.message", "abort")]+ popSpan sp)+ (\_ -> action)++pushSpan :: MonadIO m => T.Text -> [(T.Text, T.Text)] -> m ()+pushSpan opName initialTags = liftIO $ do sp <- startSpan opName tId <- myThreadId modifyMVar_ globalSharedMutableSpanStacks $ \stacks ->@@ -61,7 +71,10 @@ [] -> do let !sp' = sp- & tags %~ (<> [defMessage & key .~ "thread" & stringValue .~ T.pack (show tId)])+ & tags .~+ ( (defMessage & key .~ "thread" & stringValue .~ T.pack (show tId))+ : [(defMessage & key .~ k & stringValue .~ v) | (k, v) <- initialTags]+ ) pure $! HM.insert tId [sp'] stacks (psp : _) -> let !sp' =@@ -108,8 +121,12 @@ setTag :: MonadIO m => T.Text -> T.Text -> m () setTag k v =- modifyCurrentSpan (tags %~ (<> [defMessage & key .~ k & stringValue .~ v]))+ modifyCurrentSpan (tags %~ ((defMessage & key .~ k & stringValue .~ v) :)) +setTags :: MonadIO m => [(T.Text, T.Text)] -> m ()+setTags kvs =+ modifyCurrentSpan (tags %~ ([defMessage & key .~ k & stringValue .~ v | (k, v) <- kvs] <>))+ addLog :: LogEntryKey -> T.Text -> IO () addLog k v = modifyCurrentSpan (logs %~ (<> [defMessage & fields .~ [defMessage & key .~ showLogEntryKey k & stringValue .~ v]]))@@ -137,11 +154,11 @@ pure (some_spans <> some_more_spans) d_ $ "Got " <> show (length sps) <> " spans" inc 1 sentBatchesCountVar- reportSpansRes <- tryAny (reportSpans client sps)+ reportSpansRes <- try (reportSpans client sps) case reportSpansRes of Right () -> d_ $ "Reported " <> show (length sps) <> " spans"- Left err ->+ Left (err :: SomeException) -> d_ $ "Error while reporting spans: " <> show err shutdown = do d_ "Getting the last spans before shutdown"
src/LightStep/LowLevel.hs view
@@ -8,7 +8,7 @@ import Chronos import Control.Concurrent-import Control.Exception.Safe+import Control.Monad.Catch import Control.Lens hiding (op) import Data.ProtoLens.Message (defMessage) import qualified Data.Text as T@@ -49,7 +49,7 @@ & spans .~ sps & reporter .~ lscReporter )- req `withException` (\err -> d_ $ "reportSpans failed: " <> show (err :: SomeException))+ req inc (length sps) reportedSpanCountVar ret <- tryOnce ret2 <- case ret of@@ -104,7 +104,7 @@ ) case newGrpcOrError of Right newGrpc -> pure newGrpc- Left err -> throwIO err+ Left err -> throwM err reconnectClient :: LightStepClient -> IO () reconnectClient client@LightStepClient {lscGrpcVar} = do
src/Network/Wai/Middleware/LightStep.hs view
@@ -2,7 +2,7 @@ module Network.Wai.Middleware.LightStep where -import qualified Data.Text as T+import TextShow import qualified Data.Text.Encoding as T import LightStep.HighLevel.IO import LightStep.Internal.Debug@@ -22,14 +22,13 @@ setParentSpanContext ctx _ -> 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)- setTag "http.target" $ T.decodeUtf8 (rawPathInfo req)- setTag "http.flavor" $ showT (httpVersion req)+ setTags+ [ ("span.kind", "server")+ , ("http.method", T.decodeUtf8 (requestMethod req))+ , ("http.target", T.decodeUtf8 (rawPathInfo req))+ , ("http.flavor", showt (httpMajor $ httpVersion req))+ ] app req $ \resp -> do- setTag "http.status_code" $ showT (statusCode $ responseStatus resp)+ setTag "http.status_code" $ showt (statusCode $ responseStatus resp) sendResp resp -showT :: Show a => a -> T.Text-showT = T.pack . show
stress-test/Main.hs view
@@ -5,7 +5,7 @@ import Control.Monad import GHC.Stats import LightStep.Diagnostics-import LightStep.HighLevel.IO (LogEntryKey (..), addLog, getEnvConfig, setTag, withSingletonLightStep, withSpan)+import LightStep.HighLevel.IO import System.Exit import Text.Printf @@ -13,21 +13,17 @@ seriousBusinessMain = concurrently_ frontend backend where frontend =- withSpan "RESTful API" $ do+ withSpanAndSomeInitialTags "RESTful API" [("foo", "bar")] $ do threadDelay 10000- setTag "foo" "bar"- withSpan "Kafka" $ do+ withSpanAndSomeInitialTags "Kafka" [("foo", "baz")] $ do threadDelay 20000- setTag "foo" "baz" threadDelay 30000- withSpan "GraphQL" $ do+ withSpanAndSomeInitialTags "GraphQL" [("foo", "quux"), ("lorem", "ipsum")] $ do threadDelay 40000- setTag "foo" "quux" addLog Event "monkey-job" addLog (Custom "foo") "bar" withSpan "Mongodb" $ do threadDelay 50000- setTag "lorem" "ipsum" threadDelay 60000 withSpan "data->json" $ pure () withSpan "json->yaml" $ pure ()@@ -39,15 +35,13 @@ backend = withSpan "Background Data Science" $ do threadDelay 10000- withSpan "Tensorflow" $ do+ withSpanAndSomeInitialTags "Tensorflow" [("learning", "deep")] $ do threadDelay 100000 setTag "learning" "deep"- withSpan "Torch" $ do+ withSpanAndSomeInitialTags "Torch" [("learning", "very_deep")] $ do threadDelay 100000- setTag "learning" "very_deep"- withSpan "Hadoop" $ do+ withSpanAndSomeInitialTags "Hadoop" [("learning", "super_deep")]$ do threadDelay 100000- setTag "learning" "super_deep" reportMemoryUsage :: IO () reportMemoryUsage = do