packages feed

hs-opentelemetry-instrumentation-tasty (empty) → 0.1

raw patch · 7 files changed

+455/−0 lines, 7 filesdep +asyncdep +basedep +containers

Dependencies added: async, base, containers, hs-opentelemetry-api, hs-opentelemetry-instrumentation-tasty, hs-opentelemetry-sdk, tagged, tasty, tasty-hunit, text

Files

+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Changelog for hs-opentelemetry-instrumentation-tasty++## 0.0.1.0++- Initial release
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Ian Duncan (c) 2021++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 Ian Duncan 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.
+ README.md view
@@ -0,0 +1,19 @@+# hs-opentelemetry-instrumentation-tasty++OpenTelemetry instrumentation library for Tasty.+It creates spans for:++1. Individual test cases+2. Test groups+3. Resource setup and teardown++The library should be robust to tests running in parallel.++## Usage++Usage requires:++1. Setting and tearing down a trace provider as normal in your test executable.+2. Calling `instrumentTestTree` on your `TestTree`.++See the test suite for examples of how to use the library.
+ hs-opentelemetry-instrumentation-tasty.cabal view
@@ -0,0 +1,51 @@+cabal-version: 2.0+name:          hs-opentelemetry-instrumentation-tasty+version:       0.1++description:        Please see the README on GitHub at <https://github.com/iand675/hs-opentelemetry/tree/main/instrumentation/tasty#readme>+homepage:           https://github.com/iand675/hs-opentelemetry#readme+bug-reports:        https://github.com/iand675/hs-opentelemetry/issues+author:             Michael Peyton Jones+maintainer:         me@michaelpj.com+copyright:          2024 Ian Duncan, Mercury Technologies+license:            BSD3+license-file:       LICENSE+build-type:         Simple+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+  type: git+  location: https://github.com/iand675/hs-opentelemetry++library+  default-language: Haskell2010+  build-depends:+    base >=4.7 && <5+    , hs-opentelemetry-api ^>=0.2+    , tagged ^>= 0.8+    , tasty ^>= 1.5+    , text++  exposed-modules: OpenTelemetry.Instrumentation.Tasty+  hs-source-dirs:  src++test-suite tests+  default-language: Haskell2010+  type:           exitcode-stdio-1.0+  main-is:        Main.hs+  build-depends:+    async+    , base+    , containers+    , hs-opentelemetry-api+    , hs-opentelemetry-instrumentation-tasty+    , hs-opentelemetry-sdk+    , tasty+    , tasty-hunit+    , text++  other-modules:  OpenTelemetry.Instrumentation.Tasty.Tests+  ghc-options:    -threaded -rtsopts -with-rtsopts=-N+  hs-source-dirs: tests
+ src/OpenTelemetry/Instrumentation/Tasty.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}++module OpenTelemetry.Instrumentation.Tasty (instrumentTestTree, instrumentTestTreeWithTracer) where++import Control.Exception (bracket)+import Data.Tagged (Tagged, retag)+import Data.Text qualified as T+import OpenTelemetry.Context (insertSpan, lookupSpan, removeSpan)+import OpenTelemetry.Context.ThreadLocal (adjustContext, getContext)+import OpenTelemetry.Trace.Core (Span, SpanStatus (Error, Ok), Tracer, addAttribute, createSpan, defaultSpanArguments, detectInstrumentationLibrary, endSpan, getGlobalTracerProvider, inSpan, makeTracer, setStatus, tracerOptions)+import Test.Tasty (TestTree, withResource)+import Test.Tasty.Options (OptionDescription)+import Test.Tasty.Providers (IsTest (run, testOptions))+import Test.Tasty.Runners (Outcome (Failure, Success), ResourceSpec (ResourceSpec), Result (Result, resultDescription, resultOutcome), TestTree (After, AskOptions, PlusTestOptions, SingleTest, TestGroup, WithResource))+++{- | A test case with a wrapper function that can do some IO around the+test. We use the wrapper to set up spans appropriately.+-}+data WrappedTest t = WrappedTest+  {wrapper :: forall a. IO a -> IO a, innerTest :: t}+++instance IsTest t => IsTest (WrappedTest t) where+  run opts (WrappedTest {wrapper, innerTest}) progress =+    wrapper $ do+      ctx <- getContext+      let mspan = lookupSpan ctx+      res@Result {resultOutcome, resultDescription} <- run opts innerTest progress+      case mspan of+        Just s -> do+          addAttribute s "result.description" (T.pack resultDescription)+          case resultOutcome of+            Success -> do+              setStatus s $ Ok+            Failure reason -> do+              setStatus s $ Error $ T.pack $ show reason+        Nothing -> pure ()++      pure res+  testOptions = retag (testOptions :: Tagged t [OptionDescription])+++-- | Transform a 'TestTree' into one that emits spans around tests and test groups.+instrumentTestTree :: TestTree -> IO TestTree+instrumentTestTree t = do+  provider <- getGlobalTracerProvider+  let tracer = makeTracer provider $detectInstrumentationLibrary tracerOptions+  pure $ instrumentTestTreeWithTracer tracer t+++-- | See 'instrumentTestTree'.+instrumentTestTreeWithTracer :: Tracer -> TestTree -> TestTree+instrumentTestTreeWithTracer tracer = instrumentTestTree' tracer (pure Nothing)+++instrumentTestTree'+  :: Tracer+  -> IO (Maybe Span)+  -> TestTree+  -> TestTree+instrumentTestTree' tracer = go+  where+    -- See Note [Test parallelism] for why we pass around 'getParentSpan'+    go :: IO (Maybe Span) -> TestTree -> TestTree+    go getParentSpan = \case+      TestGroup name tests ->+        -- We use 'withResource' to associate the creation and destruction of the+        -- group span with the beginning and end of the group itself. This way+        -- 'tasty' manages the lifetime of the span for us.+        withResource+          (mkSpan (T.pack name))+          (\s -> endSpan s Nothing)+          $ \getGroupSpan ->+            let getParentSpan' = Just <$> getGroupSpan+            in TestGroup name (fmap (go getParentSpan') tests)+      SingleTest name t ->+        SingleTest name $+          WrappedTest {wrapper = withNamedSpan name, innerTest = t}+      WithResource (ResourceSpec acquire release) f ->+        -- Add spans for resource acquisition and release+        -- Nit: currently we don't create a span for the top-level itself, so+        -- if you acquire outside a test group then the spans will be detached.+        -- We could add a span for the top level, although it's maybe a little odd.+        let newResourceSpec = ResourceSpec (withNamedSpan "acquire" acquire) (fmap (withNamedSpan "release") release)+        in WithResource newResourceSpec (go' . f)+      PlusTestOptions modifier t -> PlusTestOptions modifier (go' t)+      AskOptions f -> AskOptions (go' . f)+      After d e t -> After d e $ go' t+      where+        go' = go getParentSpan+        mkSpan name = do+          ctx <- getContext+          -- See Note [Test parallelism]+          parentSpan <- getParentSpan+          -- This does not modify the thread-local context, just locally+          ctx' <- case parentSpan of+            Just s -> pure $ insertSpan s ctx+            Nothing -> pure ctx+          createSpan tracer ctx' name defaultSpanArguments+        withNamedSpan :: String -> (forall a. IO a -> IO a)+        withNamedSpan name act = do+          -- See Note [Test parallelism]+          parentSpan <- getParentSpan+          let wrapper = case parentSpan of+                Just ps -> withParentSpan ps+                Nothing -> id+          wrapper $ inSpan tracer (T.pack name) defaultSpanArguments act+++-- Possibly should upstream this to the SDK?++{- | Given a span, produces a wrapper function that sets the given span+as the installed span in the context.+-}+withParentSpan :: Span -> (forall a. IO a -> IO a)+withParentSpan parentSpan act =+  bracket setup teardown $ \_ -> act+  where+    setup = do+      ctx <- getContext+      adjustContext (insertSpan parentSpan)+      pure (lookupSpan ctx, ctx)+    teardown (originalParentSpan, _ctx) = do+      adjustContext $ \ctx -> maybe (removeSpan ctx) (`insertSpan` ctx) originalParentSpan++{- Note [Test parallelism]+Tasty runs tests in parallel by default, and we don't want to disturb that.+However, that means that any individual test case may be running on a random thread at tasty's+discretion, and so we can't rely on the thread-local context to link up spans.++Our solution is just to track (an action to access) the parent span manually as we traverse+the tree, so we can connect them up manually.+-}
+ tests/Main.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE ImportQualifiedPost #-}++module Main (main) where++import OpenTelemetry.Instrumentation.Tasty.Tests qualified+import Test.Tasty (TestTree, defaultMain, testGroup)+++main :: IO ()+main = defaultMain tests+++tests :: TestTree+tests =+  testGroup "Tasty instrumentation" $+    [OpenTelemetry.Instrumentation.Tasty.Tests.tests]
+ tests/OpenTelemetry/Instrumentation/Tasty/Tests.hs view
@@ -0,0 +1,194 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}++module OpenTelemetry.Instrumentation.Tasty.Tests (tests) where++import Control.Concurrent (newEmptyMVar, putMVar, takeMVar)+import Control.Concurrent.Async (async)+import Control.Exception (bracket)+import Data.Functor (void)+import Data.IORef (atomicModifyIORef, newIORef, readIORef)+import Data.Map (Map)+import Data.Map qualified as Map+import Data.Maybe (fromMaybe)+import Data.Set qualified as Set+import Data.Text (Text)+import OpenTelemetry.Instrumentation.Tasty (instrumentTestTree)+import OpenTelemetry.Processor.Span (ShutdownResult (ShutdownSuccess), SpanProcessor, spanProcessorForceFlush, spanProcessorOnEnd, spanProcessorOnStart, spanProcessorShutdown, pattern SpanProcessor)+import OpenTelemetry.Trace (ImmutableSpan (ImmutableSpan, spanName, spanParent), createTracerProvider, defaultSpanArguments, emptyTracerProviderOptions, getGlobalTracerProvider, inSpan, makeTracer, setGlobalTracerProvider, shutdownTracerProvider, tracerOptions)+import OpenTelemetry.Trace.Core (unsafeReadSpan)+import Test.Tasty (DependencyType (AllFinish), TestTree, sequentialTestGroup, testGroup, withResource)+import Test.Tasty.HUnit (testCase, (@?=))+import Test.Tasty.Ingredients (tryIngredients)+import Test.Tasty.Ingredients.Basic (Quiet (Quiet), consoleTestReporter)+import Test.Tasty.Options (setOption)+++tests :: TestTree+-- each of these tests sets and tears down the global tracer provider,+-- so they have to run sequentially+tests =+  sequentialTestGroup+    "OpenTelemetry.Instrumentation.Tasty"+    AllFinish+    [ basic+    , simpleNesting+    , branching+    , testWithSpan+    , parallelism+    , resources+    ]+++basic :: TestTree+basic = testCase "basic" $ do+  (_, trees) <- spanTrees $ do+    testTree <- instrumentTestTree $ testCase "hello" $ pure ()+    runTests $ testTree+  trees @?= [Leaf "hello"]+++simpleNesting :: TestTree+simpleNesting = testCase "nested groups make a simple tree" $ do+  (_, trees) <- spanTrees $ do+    testTree <-+      instrumentTestTree $+        testGroup+          "g1"+          [ testGroup "g2" [testCase "t1" (pure ())]+          ]+    runTests $ testTree+  trees @?= [Branch "g1" [Branch "g2" [Leaf "t1"]]]+++branching :: TestTree+branching = testCase "nested groups make a branching tree" $ do+  (_, trees) <- spanTrees $ do+    testTree <-+      instrumentTestTree $+        testGroup+          "g1"+          [ testGroup "g2" [testCase "t1" (pure ()), testCase "t2" (pure ())]+          , testGroup "g3" [testCase "t3" (pure ())]+          ]+    runTests $ testTree+  trees @?= [Branch "g1" [Branch "g2" [Leaf "t1", Leaf "t2"], Branch "g3" [Leaf "t3"]]]+++testWithSpan :: TestTree+testWithSpan = testCase "test that has a span itself" $ do+  (_, trees) <- spanTrees $ do+    testTree <- instrumentTestTree $ testCase "hello" $ do+      tp <- getGlobalTracerProvider+      let tracer = makeTracer tp "test" tracerOptions+      inSpan tracer "inner" defaultSpanArguments $ pure ()+    runTests $ testTree+  trees @?= [Branch "hello" [Leaf "inner"]]+++parallelism :: TestTree+parallelism = testCase "parallelism works" $ do+  block <- newEmptyMVar+  (_, trees) <- spanTrees $ do+    testTree <-+      instrumentTestTree $+        testGroup+          "g1"+          -- Force t1 to wait for t2 before it can even begin, so we+          -- should definitely not start the span for t1 until then+          [ testGroup+              "g2"+              [ withResource (takeMVar block) (const $ pure ()) $ \_ ->+                  testCase "t1" (pure ())+              ]+          , testGroup "g3" [testCase "t2" (putMVar block ())]+          ]+    runTests $ testTree+  trees @?= [Branch "g1" [Branch "g2" [Leaf "acquire", Leaf "t1", Leaf "release"], Branch "g3" [Leaf "t2"]]]+++resources :: TestTree+resources = testCase "spans for resource setup and teardown" $ do+  (_, trees) <- spanTrees $ do+    tp <- getGlobalTracerProvider+    let tracer = makeTracer tp "test" tracerOptions+    let acquire = inSpan tracer "myAcquire" defaultSpanArguments $ pure ()+    let release _ = inSpan tracer "myRelease" defaultSpanArguments $ pure ()+    testTree <- instrumentTestTree $ withResource acquire release $ \_ -> testCase "hello" $ pure ()+    runTests $ testTree+  trees @?= [Leaf "hello", Branch "acquire" [Leaf "myAcquire"], Branch "release" [Leaf "myRelease"]]+++data Tree a = Branch a (Set.Set (Tree a)) | Leaf a+  deriving stock (Show, Eq, Ord)+++spanTrees :: IO a -> IO (a, Set.Set (Tree Text))+spanTrees act = do+  (processor, readSpans) <- recordingProcessor+  res <- bracket (setup processor) shutdownTracerProvider $ \_ -> do+    act+  spans <- readSpans+  trees <- spansToTrees spans+  pure (res, Set.fromList trees)+  where+    setup processor = do+      tp <- createTracerProvider [processor] emptyTracerProviderOptions+      setGlobalTracerProvider tp+      pure tp+++toChildMap :: [ImmutableSpan] -> ([Text], Map Text [Text]) -> IO ([Text], Map Text [Text])+toChildMap [] acc = pure acc+toChildMap (ImmutableSpan {spanParent, spanName} : spans) (accRoots, accChildren) = case spanParent of+  Just parent -> do+    ImmutableSpan {spanName = parentName} <- unsafeReadSpan parent+    let existingChildren = fromMaybe mempty $ Map.lookup parentName accChildren+    toChildMap spans (accRoots, Map.insert parentName (existingChildren ++ [spanName]) accChildren)+  Nothing -> toChildMap spans (spanName : accRoots, accChildren)+++toTree :: (Ord a) => Map a [a] -> a -> Tree a+toTree childMap node = case Map.lookup node childMap of+  Nothing -> Leaf node+  Just children ->+    if null children+      then Leaf node+      else Branch node $ Set.fromList $ fmap (toTree childMap) children+++spansToTrees :: [ImmutableSpan] -> IO [Tree Text]+spansToTrees spans = do+  (roots, childMap) <- toChildMap spans mempty+  let trees = fmap (toTree childMap) roots+  pure trees+++recordingProcessor :: IO (SpanProcessor, IO [ImmutableSpan])+recordingProcessor = do+  spans <- newIORef []++  let processor =+        SpanProcessor+          { spanProcessorOnStart = mempty+          , spanProcessorOnEnd = \spanRef -> do+              immutableSpan <- readIORef spanRef+              atomicModifyIORef spans $ \soFar -> (soFar ++ [immutableSpan], ())+          , spanProcessorShutdown = async $ pure ShutdownSuccess+          , spanProcessorForceFlush = mempty+          }++  setGlobalTracerProvider+    =<< createTracerProvider [processor] emptyTracerProviderOptions++  pure (processor, readIORef spans)+++runTests :: TestTree -> IO ()+runTests t = case tryIngredients [consoleTestReporter] (setOption (Quiet True) mempty) t of+  Just act -> void act+  Nothing -> error "no ingredient"