Fixes for merge

mtth · Nov 18, 2021 · 9fb1d26 · 9fb1d26
1 parent 174fc92
commit 9fb1d26
Show file tree

Hide file tree

Showing 4 changed files with 49 additions and 49 deletions.
diff --git a/src/Control/Monad/Trace.hs b/src/Control/Monad/Trace.hs
@@ -125,55 +125,56 @@ instance MonadBaseControl b m => MonadBaseControl b (TraceT m) where
   type StM (TraceT m) a = StM (ReaderT Scope m) a
   liftBaseWith :: forall a. (RunInBase (TraceT m) b -> b a) -> TraceT m a
   liftBaseWith
-    = coerce @((RunInBase (ReaderT Scope m) b -> b a) -> ReaderT Scope m a)
+    = coerce @((RunInBase (ReaderT (Maybe Scope) m) b -> b a) -> ReaderT (Maybe Scope) m a)
              liftBaseWith
   restoreM :: forall a. StM (TraceT m) a -> TraceT m a
   restoreM
-    = coerce @(StM (ReaderT Scope m) a -> ReaderT Scope m a)
+    = coerce @(StM (ReaderT (Maybe Scope) m) a -> ReaderT (Maybe Scope) m a)
              restoreM
 
 instance (MonadIO m, MonadBaseControl IO m) => MonadTrace (TraceT m) where
-  trace bldr (TraceT reader) = TraceT $ do
-    parentScope <- ask
-    let
-      mbParentSpn = scopeSpan parentScope
-      mbParentCtx = spanContext <$> mbParentSpn
-      mbTraceID = contextTraceID <$> mbParentCtx
-    spanID <- maybe (liftBase randomSpanID) pure $ builderSpanID bldr
-    traceID <- maybe (liftBase randomTraceID) pure $ builderTraceID bldr <|> mbTraceID
-    sampling <- case builderSamplingPolicy bldr of
-      Just policy -> liftIO policy
-      Nothing -> pure $ fromMaybe Never (spanSamplingDecision <$> mbParentSpn)
-    let
-      baggages = fromMaybe Map.empty $ contextBaggages <$> mbParentCtx
-      ctx = Context traceID spanID (builderBaggages bldr `Map.union` baggages)
-      spn = Span (builderName bldr) ctx (builderReferences bldr) sampling
-      tracer = scopeTracer parentScope
-    if spanIsSampled spn
-      then do
-        tagsTV <- newTVarIO $ builderTags bldr
-        logsTV <- newTVarIO []
-        startTV <- newTVarIO Nothing -- To detect whether an exception happened during span setup.
-        let
-          run = do
-            start <- liftIO $ getPOSIXTime
-            atomically $ do
-              writeTVar startTV (Just start)
-              modifyTVar' (tracerPendingCount tracer) (+1)
-            local (const $ Scope tracer (Just spn) (Just tagsTV) (Just logsTV)) reader
-          cleanup = do
-            end <- liftIO $ getPOSIXTime
-            atomically $ readTVar startTV >>= \case
-              Nothing -> pure () -- The action was interrupted before the span was pending.
-              Just start -> do
-                modifyTVar' (tracerPendingCount tracer) (\n -> n - 1)
-                tags <- readTVar tagsTV
-                logs <- sortOn (\(t, k, _) -> (t, k)) <$> readTVar logsTV
-                writeTChan (tracerChannel tracer) (Sample spn tags logs start (end - start))
-        run `finally` cleanup
-      else local (const $ Scope tracer (Just spn) Nothing Nothing) reader
-
-  activeSpan = TraceT $ asks scopeSpan
+  trace bldr (TraceT reader) = TraceT $ ask >>= \case
+    Nothing -> reader
+    Just parentScope -> do
+      let
+        mbParentSpn = scopeSpan parentScope
+        mbParentCtx = spanContext <$> mbParentSpn
+        mbTraceID = contextTraceID <$> mbParentCtx
+      spanID <- maybe (liftBase randomSpanID) pure $ builderSpanID bldr
+      traceID <- maybe (liftBase randomTraceID) pure $ builderTraceID bldr <|> mbTraceID
+      sampling <- case builderSamplingPolicy bldr of
+        Just policy -> liftIO policy
+        Nothing -> pure $ fromMaybe Never (spanSamplingDecision <$> mbParentSpn)
+      let
+        baggages = fromMaybe Map.empty $ contextBaggages <$> mbParentCtx
+        ctx = Context traceID spanID (builderBaggages bldr `Map.union` baggages)
+        spn = Span (builderName bldr) ctx (builderReferences bldr) sampling
+        tracer = scopeTracer parentScope
+      if spanIsSampled spn
+        then do
+          tagsTV <- newTVarIO $ builderTags bldr
+          logsTV <- newTVarIO []
+          startTV <- newTVarIO Nothing -- To detect whether an exception happened during span setup.
+          let
+            run = do
+              start <- liftIO $ getPOSIXTime
+              atomically $ do
+                writeTVar startTV (Just start)
+                modifyTVar' (tracerPendingCount tracer) (+1)
+              local (const $ Just $ Scope tracer (Just spn) (Just tagsTV) (Just logsTV)) reader
+            cleanup = do
+              end <- liftIO $ getPOSIXTime
+              atomically $ readTVar startTV >>= \case
+                Nothing -> pure () -- The action was interrupted before the span was pending.
+                Just start -> do
+                  modifyTVar' (tracerPendingCount tracer) (\n -> n - 1)
+                  tags <- readTVar tagsTV
+                  logs <- sortOn (\(t, k, _) -> (t, k)) <$> readTVar logsTV
+                  writeTChan (tracerChannel tracer) (Sample spn tags logs start (end - start))
+          run `finally` cleanup
+        else local (const $ Just $ Scope tracer (Just spn) Nothing Nothing) reader
+
+  activeSpan = TraceT $ asks (>>= scopeSpan)
 
   addSpanEntry key (TagValue val) = TraceT $ do
     mbTV <- asks (>>= scopeTags)

diff --git a/src/Monitor/Tracing/Zipkin.hs b/src/Monitor/Tracing/Zipkin.hs
@@ -132,7 +132,6 @@ new (Settings mbHostname mbPort mbEpt mbMgr mbPrd) = liftIO $ do
     req = HTTP.defaultRequest
       { HTTP.method = "POST"
       , HTTP.host = BS.pack (fromMaybe "localhost" mbHostname)
-      , HTTP.requestHeaders = [("Content-Type", "application/json")]
       , HTTP.path = "/api/v2/spans"
       , HTTP.port = maybe 9411 fromIntegral mbPort
       , HTTP.requestHeaders = [("content-type", "application/json")]

diff --git a/stack.yaml.lock b/stack.yaml.lock
@@ -6,7 +6,7 @@
 packages: []
 snapshots:
 - completed:
-    size: 576534
-    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2021/4/2.yaml
-    sha256: 76ba2ea759dfc59a1b2a9ea92ea2c8d418812bc57612522ce17955e19d817faa
-  original: nightly-2021-04-02
+    size: 586292
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/17.yaml
+    sha256: e66e70a7f998036025e8f40abc89b8eeb79c88f57727020cba1b54f375aa7ca0
+  original: lts-18.17
diff --git a/tracing-control.cabal b/tracing-control.cabal
@@ -1,7 +1,7 @@
 cabal-version: 2.0
 
 name: tracing-control
-version: 0.0.7
+version: 0.0.7.2
 synopsis: Distributed tracing
 description:
   An OpenTracing-compliant, simple, and extensible distributed tracing library.