diff --git a/lightstep-haskell.cabal b/lightstep-haskell.cabal --- a/lightstep-haskell.cabal +++ b/lightstep-haskell.cabal @@ -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 diff --git a/src/LightStep/HighLevel/IO.hs b/src/LightStep/HighLevel/IO.hs --- a/src/LightStep/HighLevel/IO.hs +++ b/src/LightStep/HighLevel/IO.hs @@ -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" diff --git a/src/LightStep/LowLevel.hs b/src/LightStep/LowLevel.hs --- a/src/LightStep/LowLevel.hs +++ b/src/LightStep/LowLevel.hs @@ -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 diff --git a/src/Network/Wai/Middleware/LightStep.hs b/src/Network/Wai/Middleware/LightStep.hs --- a/src/Network/Wai/Middleware/LightStep.hs +++ b/src/Network/Wai/Middleware/LightStep.hs @@ -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 diff --git a/stress-test/Main.hs b/stress-test/Main.hs --- a/stress-test/Main.hs +++ b/stress-test/Main.hs @@ -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