Add tracing-effectful package (#11)

* [CORE-6093] Add abstract implementation for MonadTrace * [CORE-6093] Add effectful package * PoC for monomorphic traceWith and addSpanEntryWith * [CORE-6093] Clean up implementation and cabal file * [CORE-6093] Use monomorphized version of traceWith and addSpanEntryWith * [CORE-6093] Add CI to additional package * [CORE-6093] Satisfy CI by adding bounds Also apply cabal-fmt to our cabal files while we're at it --------- Co-authored-by: Andrzej Rybczak <[email protected]>
scrive · Apr 4, 2024 · 78ce72a · 78ce72a
1 parent 726b5dd
commit 78ce72a
Show file tree

Hide file tree

Showing 11 changed files with 293 additions and 105 deletions.
diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml
@@ -154,6 +154,7 @@ jobs:
         run: |
           touch cabal.project
           echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project
+          echo "packages: $GITHUB_WORKSPACE/source/tracing-effectful" >> cabal.project
           cat cabal.project
       - name: sdist
         run: |
@@ -167,15 +168,20 @@ jobs:
         run: |
           PKGDIR_tracing="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/tracing-[0-9.]*')"
           echo "PKGDIR_tracing=${PKGDIR_tracing}" >> "$GITHUB_ENV"
+          PKGDIR_tracing_effectful="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/tracing-effectful-[0-9.]*')"
+          echo "PKGDIR_tracing_effectful=${PKGDIR_tracing_effectful}" >> "$GITHUB_ENV"
           rm -f cabal.project cabal.project.local
           touch cabal.project
           touch cabal.project.local
           echo "packages: ${PKGDIR_tracing}" >> cabal.project
+          echo "packages: ${PKGDIR_tracing_effectful}" >> cabal.project
           echo "package tracing" >> cabal.project
           echo "    ghc-options: -Werror=missing-methods" >> cabal.project
+          echo "package tracing-effectful" >> cabal.project
+          echo "    ghc-options: -Werror=missing-methods" >> cabal.project
           cat >> cabal.project <<EOF
           EOF
-          $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: $_ installed\n" unless /^(tracing)$/; }' >> cabal.project.local
+          $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: $_ installed\n" unless /^(tracing|tracing-effectful)$/; }' >> cabal.project.local
           cat cabal.project
           cat cabal.project.local
       - name: dump install plan
@@ -205,6 +211,8 @@ jobs:
         run: |
           cd ${PKGDIR_tracing} || false
           ${CABAL} -vnormal check
+          cd ${PKGDIR_tracing_effectful} || false
+          ${CABAL} -vnormal check
       - name: haddock
         run: |
           $CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all

diff --git a/cabal.project b/cabal.project
@@ -1 +1,3 @@
-packages: .
+packages: 
+  .
+  tracing-effectful
diff --git a/src/Control/Monad/Trace.hs b/src/Control/Monad/Trace.hs
@@ -5,6 +5,7 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE UndecidableInstances #-} -- For the MonadReader instance.
 {-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE TypeFamilies #-}
 
 -- | This module is useful mostly for tracing backend implementors. If you are only interested in
@@ -25,14 +26,19 @@ module Control.Monad.Trace (
   -- ** Pending spans
   pendingSpanCount,
 
+  -- ** Scope
+  Scope(..),
+
   -- ** SBQueue
   SBQueue,
   defaultQueueCapacity,
   newSBQueueIO,
   isEmptySBQueue,
   readSBQueue,
   readSBQueueOnce,
-  writeSBQueue
+  writeSBQueue,
+  traceWith,
+  addSpanEntryWith
 ) where
 
 import Prelude hiding (span)
@@ -42,7 +48,8 @@ import Control.Monad.Trace.Internal
 
 import Control.Applicative ((<|>))
 import Control.Concurrent.STM (STM, TVar, retry, atomically, readTVar, writeTVar, modifyTVar, modifyTVar', newTVarIO)
-import Control.Exception.Lifted
+import Control.Exception.Lifted hiding (finally)
+import Control.Monad.Catch (finally)
 import Control.Monad (when)
 import Control.Monad.IO.Class (MonadIO, liftIO)
 import Control.Monad.Reader (ReaderT(ReaderT), ask, asks, local, runReaderT)
@@ -186,59 +193,66 @@ instance MonadTransControl TraceT where
   liftWith = defaultLiftWith TraceT traceTReader
   restoreT = defaultRestoreT TraceT
 
-instance (MonadBaseControl IO m, MonadIO m) => MonadTrace (TraceT m) where
+traceWith :: Builder -> Scope -> (Scope -> IO a) -> IO a
+traceWith bldr parentScope f = do
+  let mbParentSpn = scopeSpan parentScope
+      mbParentCtx = spanContext <$> mbParentSpn
+      mbTraceID = contextTraceID <$> mbParentCtx
+  spanID <- maybe randomSpanID pure $ builderSpanID bldr
+  traceID <- maybe randomTraceID pure $ builderTraceID bldr <|> mbTraceID
+  sampling <- case builderSamplingPolicy bldr of
+    Just policy -> 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 scope = Scope tracer (Just spn) (Just tagsTV) (Just logsTV)
+          run = do
+            start <- getPOSIXTime
+            atomically $ do
+              writeTVar startTV (Just start)
+              modifyTVar' (tracerPendingCount tracer) (+1)
+            f scope
+          cleanup = do
+             end <- 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
+                 writeSBQueue (tracerQueue tracer) (Sample spn tags logs start (end - start))
+      run `finally` cleanup
+    else f $ Scope tracer (Just spn) Nothing Nothing
+
+addSpanEntryWith :: Maybe Scope -> Key -> Value -> IO ()
+addSpanEntryWith scopes key (TagValue val) = do
+  let mbTV = scopes >>= scopeTags
+  for_ mbTV $ \tv -> atomically . modifyTVar' tv $ Map.insert key val
+addSpanEntryWith scopes key (LogValue val mbTime) = do
+  let mbTV = scopes >>= scopeLogs
+  for_ mbTV $ \tv -> do
+      time <- maybe getPOSIXTime pure mbTime
+      atomically $ modifyTVar' tv ((time, key, val) :)
+
+instance (MonadMask m, MonadBaseControl IO m) => MonadTrace (TraceT m) where
   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 -> liftBase 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 <- liftBase . newTVarIO $ builderTags bldr
-          logsTV <- liftBase $ newTVarIO []
-          startTV <- liftBase $ newTVarIO Nothing -- To detect whether an exception happened during span setup.
-          let
-            scope = Scope tracer (Just spn) (Just tagsTV) (Just logsTV)
-            run = do
-              start <- liftBase getPOSIXTime
-              liftBase . atomically $ do
-                writeTVar startTV (Just start)
-                modifyTVar' (tracerPendingCount tracer) (+1)
-              local (const $ Just scope) reader
-            cleanup = do
-              end <- liftBase getPOSIXTime
-              liftBase . 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
-                  writeSBQueue (tracerQueue tracer) (Sample spn tags logs start (end - start))
-          run `finally` cleanup
-        else local (const $ Just $ Scope tracer (Just spn) Nothing Nothing) reader
+    Just scope -> control $ \unlift -> do
+      traceWith bldr scope $ \childScope -> do
+        unlift $ local (const $ Just childScope) reader
 
   activeSpan = TraceT $ asks (>>= scopeSpan)
 
-  addSpanEntry key (TagValue val) = TraceT $ do
-    mbTV <- asks (>>= scopeTags)
-    ReaderT $ \_ -> for_ mbTV $ \tv -> liftBase . atomically $ modifyTVar' tv $ Map.insert key val
-  addSpanEntry key (LogValue val mbTime)  = TraceT $ do
-    mbTV <- asks (>>= scopeLogs)
-    ReaderT $ \_ -> for_ mbTV $ \tv -> do
-      time <- maybe (liftBase getPOSIXTime) pure mbTime
-      liftBase . atomically $ modifyTVar' tv ((time, key, val) :)
+  addSpanEntry key value = TraceT $ do
+    scope <- ask
+    liftBase $ addSpanEntryWith scope key value
 
 -- | Trace an action, sampling its generated spans. This method is thread-safe and can be used to
 -- trace multiple actions concurrently.

diff --git a/src/Monitor/Tracing/Zipkin.hs b/src/Monitor/Tracing/Zipkin.hs
@@ -21,7 +21,7 @@ module Monitor.Tracing.Zipkin (
   Endpoint(..), defaultEndpoint,
 
   -- * Publishing traces
-  Zipkin,
+  Zipkin(..),
   new, run, publish, with,
 
   -- * Cross-process spans

diff --git a/tracing-effectful/CHANGELOG.md b/tracing-effectful/CHANGELOG.md
diff --git a/tracing-effectful/LICENSE b/tracing-effectful/LICENSE
@@ -0,0 +1,30 @@
+Copyright (c) 2024, Adrien Duclos
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Adrien Duclos nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/tracing-effectful/cabal.project b/tracing-effectful/cabal.project
@@ -0,0 +1,3 @@
+packages:
+  .
+  ../
diff --git a/tracing-effectful/src/Effectful/Tracing.hs b/tracing-effectful/src/Effectful/Tracing.hs
@@ -0,0 +1,79 @@
+{-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+module Effectful.Tracing
+    (
+        -- * Effect
+        Trace
+
+        -- * Handler
+    ,   runTracing
+    ,   runTracingMaybe
+
+        -- * Zipkin utilities
+    ,   runZipkinTracing
+    ,   withZipkin
+
+        -- * Reexport
+    ,  module Monitor.Tracing
+    ) where
+
+import Effectful
+import Effectful.Dispatch.Static
+import Control.Monad.Trace
+import Control.Monad.Trace.Class
+import Control.Monad.Catch (finally)
+import Monitor.Tracing
+import Monitor.Tracing.Zipkin (Zipkin(zipkinTracer), Settings, new, publish)
+
+-- | Provides the ability to send traces to a backend
+data Trace :: Effect
+
+type instance DispatchOf Trace = Static WithSideEffects
+newtype instance StaticRep Trace = Trace (Maybe Scope)
+
+-- | Run the 'Tracing' effect.
+--
+-- /Note:/ this is the @effectful@ version of 'runTracingT'.
+runTracing
+  :: IOE :> es
+  => Eff (Trace : es) a
+  -> Tracer
+  -> Eff es a
+runTracing actn = runTracingMaybe  actn . pure
+
+runTracingMaybe
+  :: IOE :> es
+  => Eff (Trace : es) a
+  -> Maybe Tracer
+  -> Eff es a
+runTracingMaybe actn mbTracer = 
+  let scope = fmap (\tracer -> Scope tracer Nothing Nothing Nothing) mbTracer
+  in evalStaticRep (Trace scope) actn
+
+-- | Convenience method to start a 'Zipkin', run an action, and publish all spans before returning.
+withZipkin :: (IOE :> es) => Settings -> (Zipkin -> Eff es a) -> Eff es a
+withZipkin settings f = do
+  zipkin <- unsafeEff_ $ new settings
+  f zipkin `finally` publish zipkin
+
+-- | Runs a 'TraceT' action, sampling spans appropriately. Note that this method does not publish
+-- spans on its own; to do so, either call 'publish' manually or specify a positive
+-- 'settingsPublishPeriod' to publish in the background.
+runZipkinTracing :: (IOE :> es) => Eff (Trace : es) a -> Zipkin -> Eff es a
+runZipkinTracing actn zipkin = runTracing actn (zipkinTracer zipkin)
+
+-- | Orphan, canonical instance.
+instance Trace :> es => MonadTrace (Eff es) where
+  trace bldr f = getStaticRep >>= \case
+    Trace Nothing -> f
+    Trace (Just scope) -> unsafeSeqUnliftIO $ \unlift -> do
+      traceWith bldr scope $ \childScope -> do
+        unlift $ localStaticRep (const . Trace $ Just childScope) f
+
+  activeSpan = do
+    Trace scope <- getStaticRep
+    pure (scope >>= scopeSpan)
+
+  addSpanEntry key value = do
+    Trace scope <- getStaticRep
+    unsafeEff_ $ addSpanEntryWith scope key value
diff --git a/tracing-effectful/test/Main.hs b/tracing-effectful/test/Main.hs
@@ -0,0 +1,4 @@
+module Main (main) where
+
+main :: IO ()
+main = putStrLn "Test suite not yet implemented."
diff --git a/tracing-effectful/tracing-effectful.cabal b/tracing-effectful/tracing-effectful.cabal
@@ -0,0 +1,48 @@
+cabal-version:   3.0
+name:            tracing-effectful
+version:         0.1.0.0
+license:         BSD-3-Clause
+license-file:    LICENSE
+author:          Adrien Duclos
+maintainer:      [email protected]
+category:        Development
+synopsis:        Distributed tracing in Eff
+description:
+  Adaptation of the tracing library for the Effectful ecosystem
+
+build-type:      Simple
+extra-doc-files: CHANGELOG.md
+tested-with:
+  GHC ==8.10.7 || ==9.0.2 || ==9.2.8 || ==9.4.8 || ==9.6.4 || ==9.8.2
+
+common language
+  ghc-options:        -Wall -Wcompat -Wno-unticked-promoted-constructors
+  default-language:   Haskell2010
+  default-extensions:
+    DataKinds
+    FlexibleContexts
+    KindSignatures
+    LambdaCase
+    TypeFamilies
+    TypeOperators
+
+library
+  import:          language
+  exposed-modules: Effectful.Tracing
+  build-depends:
+    , base            <5
+    , effectful-core  >=1.0.0.0 && <3.0.0.0
+    , exceptions      <0.11
+    , tracing         >=0.0.7   && <1.0.0.0
+
+  hs-source-dirs:  src
+
+test-suite tracing-effectful-test
+  import:           language
+  default-language: Haskell2010
+  type:             exitcode-stdio-1.0
+  hs-source-dirs:   test
+  main-is:          Main.hs
+  build-depends:
+    , base               <5
+    , tracing-effectful