lightstep-haskell 0.1.5 → 0.1.6

raw patch · 3 files changed

+47/−42 lines, 3 files

Files

• lightstep-haskell.cabal +1/−1
• src/LightStep/HighLevel/IO.hs +44/−40
• src/LightStep/LowLevel.hs +2/−1

@@ -1,7 +1,7 @@ cabal-version: 2.4  name:           lightstep-haskell-version:        0.1.5+version:        0.1.6 synopsis:       LightStep OpenTracing client library description:    LightStep OpenTracing client library. Uses GRPC transport via proto-lens. category:       Tools

@@ -77,43 +77,46 @@  withSingletonLightStep :: LightStepConfig -> IO () -> IO () withSingletonLightStep cfg action = do-  doneVar <- newEmptyMVar-  race_ (action >> waitUntilDone (lsGracefulShutdownTimeoutSeconds cfg) doneVar) $ do-    tid <- myThreadId-    labelThread tid "LightStep reporter"-    let work client = do-          d_ "Getting more spans"-          spans <- liftIO $ atomically $ do-            x <- readTBQueue globalSharedMutableSingletonState-            xs <- flushTBQueue globalSharedMutableSingletonState-            pure (x : xs)-          d_ $ "Got " <> show (length spans) <> " spans"-          reportSpansRes <- tryAny (reportSpans client spans)-          case reportSpansRes of-            Right () ->-              d_ $ "Reported " <> show (length spans) <> " spans"-            Left err ->-              d_ $ "Error while reporting spans: " <> show err-        shutdown client = do-          d_ "Getting the last spans before shutdown"-          spans <- liftIO $ atomically $ flushTBQueue globalSharedMutableSingletonState-          when (not $ null spans) $ do-            d_ $ "Got " <> show (length spans) <> " spans"-            reportSpans client spans-            d_ $ "Reported " <> show (length spans) <> " spans"-          d_ "No more spans"-          closeClient client-          d_ "Client closed"-          liftIO $ putMVar doneVar ()-    runExceptT-      $ bracket-        (mkClient cfg)-        shutdown-      $ \client -> do-        let loop = do-              work client-              loop-        loop+  runExceptT (mkClient cfg) >>= \case+    Left err -> do+      d_ $ "Failed to start LightStep client: " <> show err+      action+    Right client -> do+      d_ $ "Connected to LightStep " <> lsHostName cfg <> ":" <> show (lsPort cfg)+      doneVar <- newEmptyMVar+      let work = do+            d_ "Getting more spans"+            sps <- liftIO $ atomically $ do+              x <- readTBQueue globalSharedMutableSingletonState+              xs <- flushTBQueue globalSharedMutableSingletonState+              pure (x : xs)+            d_ $ "Got " <> show (length sps) <> " spans"+            reportSpansRes <- tryAny (reportSpans client sps)+            case reportSpansRes of+              Right () ->+                d_ $ "Reported " <> show (length sps) <> " spans"+              Left err ->+                d_ $ "Error while reporting spans: " <> show err+          shutdown = do+            d_ "Getting the last spans before shutdown"+            sps <- liftIO $ atomically $ flushTBQueue globalSharedMutableSingletonState+            when (not $ null sps) $ do+              d_ $ "Got " <> show (length sps) <> " spans"+              reportSpans client sps+              d_ $ "Reported " <> show (length sps) <> " spans"+            d_ "No more spans"+            closeClient client+            d_ "Client closed"+            liftIO $ putMVar doneVar ()+      race_ action $ do+        tid <- myThreadId+        labelThread tid "LightStep reporter"+        runExceptT . fix $ \loop -> do+          work+          loop+      race_+        (runExceptT shutdown)+        (waitUntilDone (lsGracefulShutdownTimeoutSeconds cfg) doneVar)  submitSpan :: Span -> IO () submitSpan sp = do@@ -128,12 +131,12 @@     writeTBQueue q a     pure True --- TODO: handle span batches larger that queue size submitSpans :: Foldable f => f Span -> IO ()-submitSpans = atomically . mapM_ (writeTBQueue globalSharedMutableSingletonState)+submitSpans = atomically . mapM_ (tryWriteTBQueue globalSharedMutableSingletonState)  waitUntilDone :: Int -> MVar () -> IO ()-waitUntilDone timeoutSeconds doneVar =+waitUntilDone timeoutSeconds doneVar = do+  d_ "waitUntilDone begin"   race_     ( do         threadDelay $ 1_000_000 * timeoutSeconds@@ -143,3 +146,4 @@         takeMVar doneVar         d_ "waitUntilDone: done"     )+  d_ "waitUntilDone end"

@@ -7,6 +7,7 @@ where  import Chronos+import Control.Exception.Safe import Control.Lens hiding (op) import Data.ProtoLens.Message (defMessage) import qualified Data.Text as T@@ -31,7 +32,6 @@  reportSpans :: LightStepClient -> [Span] -> ExceptT ClientError IO () reportSpans (LightStepClient grpc token rep) sps = do-  d_ $ show ("RPC timeout", (\(Timeout t) -> t) $ _grpcClientTimeout grpc)   ret <-     rawUnary       (RPC :: RPC CollectorService "report")@@ -41,6 +41,7 @@           & spans .~ sps           & reporter .~ rep       )+      `withException` (\err -> d_ $ "reportSpans failed: " <> show (err :: SomeException))   d_ $ show ret   -- FIXME: handle errors   pure ()