atelier-core 0.3.0.0 → 0.4.0.0

raw patch · 18 files changed

+85/−1107 lines, 18 filesdep −asyncdep −contra-tracerdep −hs-opentelemetry-sdkdep ~aesondep ~atelier-coredep ~atelier-preludePVP ok

version bump matches the API change (PVP)

Dependencies removed: async, contra-tracer, hs-opentelemetry-sdk

Dependency ranges changed: aeson, atelier-core, atelier-prelude, http-api-data, time

API changes (from Hackage documentation)

Files

• CHANGELOG.md +28/−0
• atelier-core.cabal +11/−23
• src/Atelier/Component.hs +0/−132
• src/Atelier/Effects/Cache/Singleflight.hs +7/−15
• src/Atelier/Effects/Conc/Traced.hs +0/−86
• src/Atelier/Effects/Env.hs +10/−2
• src/Atelier/Effects/FileSystem.hs +20/−2
• src/Atelier/Effects/Monitoring/Metrics.hs +0/−125
• src/Atelier/Effects/Monitoring/Metrics/Registry.hs +0/−119
• src/Atelier/Effects/Monitoring/Metrics/Server.hs +0/−50
• src/Atelier/Effects/Monitoring/Tracing.hs +0/−293
• src/Atelier/Effects/Monitoring/Tracing/Provider.hs +0/−70
• src/Atelier/Effects/Publishing.hs +3/−45
• test/Unit/Atelier/Effects/Cache/SingleflightSpec.hs +1/−3
• test/Unit/Atelier/Effects/Conc/TeardownStressSpec.hs +2/−3
• test/Unit/Atelier/Effects/Conc/TracedSpec.hs +0/−131
• test/Unit/Atelier/Effects/IteratorSpec.hs +1/−3
• test/Unit/Atelier/Effects/PublishingSpec.hs +2/−5

@@ -7,6 +7,34 @@  ## [Unreleased] +## [0.4.0.0] - 2026-08-14++### Added++- `Atelier.Effects.Env`: `lookupEnv` picks out a single environment variable.++### Changed++- Major version bump for the following dependencies' upper version bounds:+  - `aeson`+  - `http-api-data`+  - `time`++### Removed++- Move all metrics and observability tooling to `atelier-monitoring`:+  - `Atelier.Component`: moved to `atelier-monitoring`.+  - `Atelier.Effects.Conc.Traced`: moved to `atelier-monitoring`.+  - `Atelier.Effects.Monitoring.Metrics`: moved to `atelier-monitoring`.+  - `Atelier.Effects.Monitoring.Metrics.Server`: moved to `atelier-monitoring`.+  - `Atelier.Effects.Monitoring.Metrics.Registry`: moved to `atelier-monitoring`.+  - `Atelier.Effects.Cache.Singleflight`: removed tracing capability. Old version+    with tracing capability is available in `atelier-monitoring` as+    `Atelier.Effects.Cache.Singleflight.Traced`.+  - `Atelier.Effects.Publishing#runPubSub`: moved to `atelier-monitoring` in+    `Atelier.Effects.Publishing.Traced`.+  - `Atelier.Effects.Publshing#runPubSub_`: renamed to `runPubSub`.+ ## [0.3.0.0] - 2026-08-06  ### Added

@@ -5,14 +5,14 @@ -- see: https://github.com/sol/hpack  name:           atelier-core-version:        0.3.0.0+version:        0.4.0.0 synopsis:       Foundational Effectful-based effects and utilities description:    Core effects and utilities for effect-based applications, built on Effectful — part of the atelier toolkit. category:       Control homepage:       https://github.com/tweag/tricorder#readme bug-reports:    https://github.com/tweag/tricorder/issues-author:         Christian Georgii-maintainer:     christian.georgii@tweag.io+author:         Victor Nascimento Bakke+maintainer:     victor.bakke@tweag.io license:        MIT license-file:   LICENSE build-type:     Simple@@ -31,7 +31,6 @@  library   exposed-modules:-      Atelier.Component       Atelier.Config       Atelier.Effects.Arguments       Atelier.Effects.Await@@ -41,7 +40,6 @@       Atelier.Effects.Chan       Atelier.Effects.Clock       Atelier.Effects.Conc-      Atelier.Effects.Conc.Traced       Atelier.Effects.Console       Atelier.Effects.Debounce       Atelier.Effects.Delay@@ -54,11 +52,6 @@       Atelier.Effects.Internal.Coroutine       Atelier.Effects.Iterator       Atelier.Effects.Log-      Atelier.Effects.Monitoring.Metrics-      Atelier.Effects.Monitoring.Metrics.Registry-      Atelier.Effects.Monitoring.Metrics.Server-      Atelier.Effects.Monitoring.Tracing-      Atelier.Effects.Monitoring.Tracing.Provider       Atelier.Effects.Posix.Daemons       Atelier.Effects.Posix.IO       Atelier.Effects.Process@@ -104,14 +97,13 @@       TypeFamilies   ghc-options: -Weverything -Wno-unsafe -Wno-missing-safe-haskell-mode -Wno-monomorphism-restriction -Wno-missing-kind-signatures -Wno-missing-local-signatures -Wno-missing-import-lists -Wno-implicit-prelude -Wno-unticked-promoted-constructors -Wno-unused-packages -Wno-all-missed-specialisations -Wno-missed-specialisations -fplugin=Effectful.Plugin -threaded   build-depends:-      aeson ==2.2.*-    , atelier-prelude ==0.1.*+      aeson >=2.2 && <2.4+    , atelier-prelude >=0.1 && <0.3     , base >=4.18 && <4.23     , base64-bytestring ==1.2.*     , bytestring >=0.11 && <0.13     , casing ==0.1.*     , containers >=0.6 && <0.9-    , contra-tracer ==0.2.*     , daemons ==0.4.*     , data-default ==0.8.*     , directory ==1.3.*@@ -121,9 +113,7 @@     , effectful-th ==1.0.*     , filepath >=1.4 && <1.6     , fsnotify ==0.4.*-    , hs-opentelemetry-api ==0.3.*-    , hs-opentelemetry-sdk ==0.1.*-    , http-api-data ==0.7.*+    , http-api-data >=0.5.1 && <0.8     , http-types ==0.12.*     , ki ==1.0.*     , list-t ==1.0.*@@ -134,7 +124,7 @@     , stm ==2.5.*     , stm-containers ==1.2.*     , text ==2.1.*-    , time >=1.12 && <1.16+    , time >=1.12 && <1.17     , time-units ==1.0.*     , typed-process ==0.2.*     , unagi-chan ==0.4.*@@ -159,7 +149,6 @@       Unit.Atelier.Effects.CacheSpec       Unit.Atelier.Effects.ChanSpec       Unit.Atelier.Effects.Conc.TeardownStressSpec-      Unit.Atelier.Effects.Conc.TracedSpec       Unit.Atelier.Effects.ConcSpec       Unit.Atelier.Effects.ConsoleSpec       Unit.Atelier.Effects.DebounceSpec@@ -200,10 +189,9 @@   build-tool-depends:       tasty-discover:tasty-discover   build-depends:-      aeson ==2.2.*-    , async ==2.2.*-    , atelier-core ==0.3.*-    , atelier-prelude ==0.1.*+      aeson >=2.2 && <2.4+    , atelier-core >=0.3 && <0.5+    , atelier-prelude >=0.1 && <0.3     , base >=4.18 && <4.23     , bytestring >=0.11 && <0.13     , containers >=0.6 && <0.9@@ -219,7 +207,7 @@     , stm-containers ==1.2.*     , tasty ==1.5.*     , tasty-hspec ==1.2.*-    , time >=1.12 && <1.16+    , time >=1.12 && <1.17   mixins:       base hiding (Prelude)   default-language: GHC2021

@@ -1,132 +0,0 @@--- | A small component model for assembling long-running applications.------ A 'Component' bundles a named unit of work with a lifecycle: one-off 'setup',--- a set of 'listeners' and 'triggers' that run as forked threads, and a--- post-'start' action. 'runSystem' drives a collection of components through--- these phases in lockstep, so that (for example) every component has finished--- 'setup' before any 'start' action runs and publishes events the others react--- to.-module Atelier.Component-    ( -- * Components-      Component (..)-    , defaultComponent-    , Listener-    , Trigger--      -- * Running-    , runComponent-    , runSystem-    ) where--import Text.Casing (fromHumps, toQuietSnake)--import Atelier.Effects.Conc (Conc)-import Atelier.Effects.Log (Log)-import Atelier.Effects.Monitoring.Tracing (Tracing, withSpan)--import Atelier.Effects.Conc qualified as Conc-import Atelier.Effects.Log qualified as Log----- | A listener reacts to events and runs forever; it never returns normally,--- hence the 'Void' result.-type Listener es = Eff es Void----- | A trigger initiates periodic or scheduled work and, like a 'Listener', runs--- forever and never returns normally.-type Trigger es = Eff es Void----- | A named unit of application work together with its lifecycle hooks.------ Build one by overriding the fields of 'defaultComponent' you care about.-data Component es = Component-    { name :: ~Text-    -- ^ Component name for tracing-    , setup :: Eff es ()-    -- ^ Setup component (runs before listeners/triggers start)-    , listeners :: Eff es [Listener es]-    -- ^ Event listeners (react to events)-    , triggers :: Eff es [Trigger es]-    -- ^ Triggers (initiate periodic/scheduled work)-    , start :: Eff es ()-    -- ^ Post-start actions (runs after all components have started)-    }----- | A 'Component' with no-op lifecycle hooks and no listeners or triggers.------ Override the fields you need. 'name' is deliberately left as an 'error' so a--- component created without a name fails fast rather than tracing anonymously.-defaultComponent :: (HasCallStack) => Component es-defaultComponent =-    Component-        { name = error "Missing component name"-        , setup = pure ()-        , listeners = pure []-        , triggers = pure []-        , start = pure ()-        }----- | Run a component by forking its listeners and triggers-runComponent :: (Conc :> es, Tracing :> es) => Component es -> Eff es ()-runComponent c = withSpan c.name $ do-    ls <- c.listeners-    ts <- c.triggers-    traverse_ Conc.fork_ ls-    traverse_ Conc.fork_ ts----- | Run multiple components with structured lifecycle coordination------ Executes components in three sequential phases:---   1. Run @setup for all components (initialization before activation)---   2. Fork all listeners and triggers (components become active)---   3. Fork @start for all components (background startup actions)------ This separation allows components to prepare resources during setup, then perform--- work during start that depends on listeners already running (e.g., publishing events).--- The start phase is forked to allow parallel execution across components.-runSystem-    :: forall es-     . (Conc :> es, Log :> es, Tracing :> es)-    => [Component es]-    -> Eff es ()-runSystem components = Conc.scoped do-    -- Phase 1: Setup all components-    traverse_ setupComponent components--    -- Phase 2: Start all components (fork listeners/triggers)-    traverse_ startComponent components--    -- Phase 3: Fork post-start actions-    traverse_ postStartComponent components--    Conc.awaitAll-  where-    setupComponent :: Component es -> Eff es ()-    setupComponent c = do-        let name = formatName c.name-        Log.debug $ "Setting up component: " <> name-        withSpan (name <> ":setup")-            $ c.setup--    startComponent :: Component es -> Eff es ()-    startComponent c = do-        let name = formatName c.name-        Log.debug $ "Starting listeners/triggers for component: " <> name-        runComponent c--    postStartComponent :: Component es -> Eff es ()-    postStartComponent c = do-        let name = formatName c.name-        Log.debug $ "Forking start phase for component: " <> name-        void . Conc.fork-            $ withSpan (name <> ":start")-            $ c.start---formatName :: Text -> Text-formatName = toText . toQuietSnake . fromHumps . toString

@@ -4,10 +4,9 @@ -- When several threads request the same key at once, the first runs the -- computation while the rest wait and share its result — so an expensive lookup -- happens once per key per in-flight window. Results (and exceptions) can also--- be seeded with 'updateCache' or invalidated with 'removeFromCache'. Each--- operation is traced (see "Atelier.Effects.Monitoring.Tracing").+-- be seeded with 'updateCache' or invalidated with 'removeFromCache'. module Atelier.Effects.Cache.Singleflight-    ( Singleflight+    ( Singleflight (..)     , withCache     , updateCache     , removeFromCache@@ -26,9 +25,7 @@ import Effectful.Concurrent.STM qualified as STM import StmContainers.Map qualified as Map -import Atelier.Effects.Monitoring.Tracing (Tracing, addAttribute, withSpan) - -- | Singleflight cache effect for deduplicating concurrent computations -- -- When multiple concurrent operations request the same key:@@ -55,7 +52,7 @@ -- | Run the Singleflight effect with an in-memory cache runSingleflight     :: forall key value es a-     . (Concurrent :> es, Hashable key, Tracing :> es)+     . (Concurrent :> es, Hashable key)     => Eff (Singleflight key value : es) a     -> Eff es a runSingleflight action = do@@ -64,7 +61,7 @@      -- Run with the cache in Reader context, interpreting Singleflight operations     interpretWith action $ \env -> \case-        WithCache key computation -> localSeqUnlift env $ \unlift -> withSpan "singleflight.with_cache" do+        WithCache key computation -> localSeqUnlift env $ \unlift -> do             -- Singleflight pattern: check if computation is already in-flight.             -- Also attempt a non-blocking read of any existing result in the same transaction.             (mvar, isFirst, mResult) <- STM.atomically $ do@@ -81,13 +78,10 @@              case (isFirst, mResult) of                 (_, Just (Right value)) -> do-                    addAttribute @Text "singleflight.outcome" "hit"                     pure value                 (_, Just (Left exception)) -> do-                    addAttribute @Text "singleflight.outcome" "hit"                     throwIO exception                 (True, Nothing) -> do-                    addAttribute @Text "singleflight.outcome" "compute"                     result <- unlift $ trySync computation                      -- Try to fill the TMVar with result (success or failure) for waiters@@ -113,15 +107,13 @@                             Left exception -> throwIO exception                             Right value -> pure value                 (False, Nothing) -> do-                    addAttribute @Text "singleflight.outcome" "wait"                     result <--                        withSpan "singleflight.wait"-                            $ STM.atomically+                        STM.atomically                             $ STM.readTMVar mvar                     case result of                         Left exception -> throwIO exception                         Right value -> pure value-        UpdateCache entries -> withSpan "singleflight.update_cache" do+        UpdateCache entries -> do             STM.atomically $ do                 forM_ entries $ \(key, value) -> do                     existing <- Map.lookup key cache@@ -136,5 +128,5 @@                             -- No in-flight computation: create fresh TMVar with value                             tmvar <- STM.newTMVar (Right value)                             Map.insert tmvar key cache-        RemoveFromCache keys -> withSpan "singleflight.remove_from_cache" do+        RemoveFromCache keys -> do             STM.atomically $ forM_ keys $ \key -> Map.delete key cache

@@ -1,86 +0,0 @@--- | Tracing integration for the 'Conc' effect.------ Provides interpreters and interposers that automatically propagate--- OpenTelemetry trace context across thread boundaries using span links.-module Atelier.Effects.Conc.Traced-    ( -- * Interpreters-      runConc-    , runConcByConfig-    , runConcTraced--      -- * Interposers-    , withConcTracingLinks-    )-where--import Effectful (IOE, raise, withEffToIO)-import Effectful.Concurrent (Concurrent)-import Effectful.Dispatch.Dynamic (interpose, localLend, localUnlift, passthrough)-import Effectful.Reader.Static (Reader, asks)--import Ki qualified--import Atelier.Effects.Conc (Conc (..), Scope (..), concStrat, fork, forkTry, fork_, runConcBase)-import Atelier.Effects.Monitoring.Tracing (Tracing, TracingConfig (..))--import Atelier.Effects.Conc qualified as Conc-import Atelier.Effects.Monitoring.Tracing qualified as Tracing----- | Run 'Conc' effect with automatic trace context propagation in a new scope.-runConc :: (Concurrent :> es, IOE :> es, Tracing :> es) => Eff (Conc : es) a -> Eff es a-runConc eff = withEffToIO concStrat $ \unlift ->-    Ki.scoped $ \scope ->-        unlift $ runConcTraced (Scope scope) eff----- | Run 'Conc' effect, selecting the interpreter based on tracing config.------ If tracing is enabled, uses 'runConc' for automatic span link propagation.--- If tracing is disabled, falls back to 'Conc.runConc' to skip the overhead.-runConcByConfig-    :: ( Concurrent :> es-       , IOE :> es-       , Reader TracingConfig :> es-       , Tracing :> es-       )-    => Eff (Conc : es) a -> Eff es a-runConcByConfig eff = do-    tracingEnabled <- asks @TracingConfig (.enabled)-    if tracingEnabled then runConc eff else Conc.runConc eff----- | Run 'Conc' effect with automatic trace context propagation.------ All fork variants ('fork', 'fork_', 'forkTry') use span links, i.e. forked--- threads start a fresh trace whose root spans carry a link back to the--- originating span.-runConcTraced-    :: ( Concurrent :> es-       , IOE :> es-       , Tracing :> es-       )-    => Scope -> Eff (Conc : es) a -> Eff es a-runConcTraced scope = runConcBase scope . withConcTracingLinks----- | Intercept fork operations and wrap the forked action with span link propagation.------ Re-dispatches to the underlying 'Conc' handler via 'fork', 'fork_', 'forkTry'.-withConcTracingLinks :: (Conc :> es, Tracing :> es) => Eff es a -> Eff es a-withConcTracingLinks = interpose \env -> \case-    Fork action -> tracedFork env action fork-    Fork_ action -> tracedFork env action fork_-    ForkTry action -> tracedFork env action forkTry-    other -> passthrough env other-  where-    tracedFork env action kiOp = do-        parentCtx <- Tracing.getSpanContext-        localUnlift env concStrat \unliftEff ->-            localLend @'[Tracing] env concStrat \lend ->-                kiOp-                    $ unliftEff-                        . lend-                        . Tracing.withLinkPropagation parentCtx-                        . raise @Tracing-                    $ action

@@ -5,6 +5,7 @@ module Atelier.Effects.Env     ( Env     , getEnvironment+    , lookupEnv     , runEnv     , runEnvConst     ) where@@ -13,6 +14,7 @@ import Effectful.Dispatch.Dynamic (interpret_) import Effectful.TH (makeEffect) +import Data.List qualified as List import System.Environment qualified as System  @@ -20,6 +22,8 @@ data Env :: Effect where     -- | The full environment as a list of @(name, value)@ pairs.     GetEnvironment :: Env m [(String, String)]+    -- | Pick out one value from the environment.+    LookupEnv :: String -> Env m (Maybe String)   makeEffect ''Env@@ -27,9 +31,13 @@  -- | Interpret 'Env' against the real process environment. runEnv :: (IOE :> es) => Eff (Env : es) a -> Eff es a-runEnv = interpret_ $ \GetEnvironment -> liftIO System.getEnvironment+runEnv = interpret_ $ \case+    GetEnvironment -> liftIO System.getEnvironment+    LookupEnv key -> liftIO $ System.lookupEnv key   -- | Interpret 'Env' with a fixed environment, for tests. runEnvConst :: [(String, String)] -> Eff (Env : es) a -> Eff es a-runEnvConst env = interpret_ $ \GetEnvironment -> pure env+runEnvConst env = interpret_ $ \case+    GetEnvironment -> pure env+    LookupEnv key -> pure $ List.lookup key env

@@ -12,9 +12,12 @@     , followFile     , doesFileExist     , doesPathExist+    , doesDirectoryExist     , listDirectory     , createDirectoryIfMissing     , removeFile+    , writeFileBS+    , writeFileLBS     , canonicalizePath     , getCurrentDirectory     , getXdgRuntimeDir@@ -51,17 +54,23 @@     -- | Read a file's full contents strictly.     ReadFileBs :: FilePath -> FileSystem m ByteString     -- | Read a file from the given byte offset to the end, lazily.-    ReadFileLbsFrom :: FilePath -> FileOffset -> FileSystem m LBS.ByteString+    ReadFileLbsFrom :: FilePath -> FileOffset -> FileSystem m LByteString     -- | Does a regular file exist at the path?     DoesFileExist :: FilePath -> FileSystem m Bool     -- | Does anything (file or directory) exist at the path?     DoesPathExist :: FilePath -> FileSystem m Bool+    -- | Does a directory exist at the path?+    DoesDirectoryExist :: FilePath -> FileSystem m Bool     -- | List the entries of a directory.     ListDirectory :: FilePath -> FileSystem m [FilePath]     -- | Create a directory. The 'Bool' requests creation of missing parents.     CreateDirectoryIfMissing :: Bool -> FilePath -> FileSystem m ()     -- | Delete a file.     RemoveFile :: FilePath -> FileSystem m ()+    -- | Write a 'ByteString' to a file path.+    WriteFileBS :: FilePath -> ByteString -> FileSystem m ()+    -- | Write a (lazy) 'LByteString' to a file path.+    WriteFileLBS :: FilePath -> LByteString -> FileSystem m ()     -- | Resolve a path to a canonical, absolute form.     CanonicalizePath :: FilePath -> FileSystem m FilePath     -- | The process's current working directory.@@ -74,7 +83,7 @@   -- | Read a file's full contents lazily (equivalent to reading from offset 0).-readFileLbs :: (FileSystem :> es) => FilePath -> Eff es LBS.ByteString+readFileLbs :: (FileSystem :> es) => FilePath -> Eff es LByteString readFileLbs path = readFileLbsFrom path 0  @@ -106,9 +115,12 @@                 (readFdFrom offset)     DoesFileExist path -> liftIO $ Dir.doesFileExist path     DoesPathExist path -> liftIO $ Dir.doesPathExist path+    DoesDirectoryExist path -> liftIO $ Dir.doesDirectoryExist path     ListDirectory path -> liftIO $ Dir.listDirectory path     CreateDirectoryIfMissing p path -> liftIO $ Dir.createDirectoryIfMissing p path     RemoveFile path -> liftIO $ Dir.removeFile path+    WriteFileBS path bytes -> liftIO $ BS.writeFile path bytes+    WriteFileLBS path bytes -> liftIO $ LBS.writeFile path bytes     CanonicalizePath path -> liftIO $ Dir.canonicalizePath path     GetCurrentDirectory -> liftIO Dir.getCurrentDirectory     GetXdgRuntimeDir -> liftIO $ fromMaybe "/tmp" <$> lookupEnv "XDG_RUNTIME_DIR"@@ -122,9 +134,12 @@     ReadFileLbsFrom _ _ -> pure mempty     DoesFileExist _ -> pure False     DoesPathExist _ -> pure False+    DoesDirectoryExist _ -> pure False     ListDirectory _ -> pure []     CreateDirectoryIfMissing _ _ -> pure ()     RemoveFile _ -> pure ()+    WriteFileBS _ _ -> pure ()+    WriteFileLBS _ _ -> pure ()     CanonicalizePath path -> pure path     GetCurrentDirectory -> pure "."     GetXdgRuntimeDir -> pure "/tmp"@@ -150,9 +165,12 @@             $ contents     DoesFileExist fp -> gets $ M.member fp     DoesPathExist fp -> gets $ any (\p -> fp `isPrefixOf` p && fp /= p) . M.keys+    DoesDirectoryExist fp -> gets $ any (\p -> fp `isPrefixOf` p) . M.keys     ListDirectory fp -> gets $ filter (\p -> fp `isPrefixOf` p && fp /= p) . M.keys     CreateDirectoryIfMissing _ _ -> pure ()     RemoveFile fp -> modify $ M.delete fp+    WriteFileBS fp bytes -> modify $ M.insert fp bytes+    WriteFileLBS fp bytes -> modify $ M.insert fp $ toStrict bytes     CanonicalizePath fp -> pure fp     GetCurrentDirectory -> pure "/"     GetXdgRuntimeDir -> pure "/tmp"

@@ -1,125 +0,0 @@--- | Metrics effect for Prometheus metrics collection.------ Provides operations for tracking application metrics.------ == Basic Usage------ @--- myComponent :: (Metrics :> es) => Eff es ()--- myComponent = do---     gaugeSet "hoard_connected_peers" 5.0---     counterInc "hoard_blocks_received_total"--- @------ == Available Metric Types------ * Gauges: Point-in-time values that can go up or down--- * Counters: Monotonically increasing values--- * Histograms: Distributions with buckets for measuring durations-module Atelier.Effects.Monitoring.Metrics-    ( -- * Effect-      Metrics--      -- * Gauge Operations-    , gaugeSet-    , gaugeInc-    , gaugeDec--      -- * Counter Operations-    , counterInc-    , counterAdd--      -- * Histogram Operations-    , histogramObserve-    , withHistogramTiming--      -- * Export Operations-    , exportMetrics--      -- * Interpreters-    , runMetrics-    , runMetricsNoOp-    ) where--import Data.Time.Clock (diffUTCTime)-import Effectful (Effect, IOE)-import Effectful.Dispatch.Dynamic (interpret, interpretWith, localSeqUnlift)-import Effectful.TH (makeEffect)--import Prometheus qualified as Prom-import Prometheus.Metric.GHC qualified as GHC--import Atelier.Effects.Clock (Clock, currentTime)-import Atelier.Effects.Monitoring.Tracing (Tracing, withSpan)--import Atelier.Effects.Monitoring.Metrics.Registry qualified as Registry----- | Metrics effect for tracking application metrics-data Metrics :: Effect where-    -- | Set a named gauge to a specific value.-    GaugeSet :: Text -> Double -> Metrics m ()-    -- | Increment a named gauge by 1.-    GaugeInc :: Text -> Metrics m ()-    -- | Decrement a named gauge by 1.-    GaugeDec :: Text -> Metrics m ()-    -- | Increment a named counter by 1.-    CounterInc :: Text -> Metrics m ()-    -- | Add a value to a named counter.-    CounterAdd :: Text -> Double -> Metrics m ()-    -- | Observe a value in a named histogram.-    HistogramObserve :: Text -> Double -> Metrics m ()-    -- | Time an action and record its duration to a histogram metric-    WithHistogramTiming :: Text -> m a -> Metrics m a-    -- | Export all collected metrics in Prometheus text format.-    ExportMetrics :: Metrics m Text---makeEffect ''Metrics----- | Run the Metrics effect with prometheus-client------ Initializes the metric registry and registers GHC metrics automatically.-runMetrics-    :: forall es a-     . (Clock :> es, IOE :> es, Tracing :> es)-    => Eff (Metrics : es) a-    -> Eff es a-runMetrics action = do-    -- Initialize metrics registry and register GHC metrics--    handles <- withSpan "metrics.setup" do-        void $ liftIO $ Prom.register GHC.ghcMetrics-        liftIO Registry.initMetricHandles--    interpretWith action \env -> \case-        GaugeSet name value -> withSpan "metrics.gauge_set" $ liftIO $ Registry.setGauge handles name value-        GaugeInc name -> withSpan "metrics.gauge_inc" $ liftIO $ Registry.incGauge handles name-        GaugeDec name -> withSpan "metrics.gauge_dec" $ liftIO $ Registry.decGauge handles name-        CounterInc name -> withSpan "metrics.counter_inc" $ liftIO $ Registry.incCounter handles name-        CounterAdd name value -> withSpan "metrics.counter_add" $ liftIO $ Registry.addCounter handles name value-        HistogramObserve name value -> withSpan "metrics.histogram_observe" $ liftIO $ Registry.observeHistogram handles name value-        WithHistogramTiming metricName eff -> do-            start <- currentTime-            result <- localSeqUnlift env \unlift -> unlift eff-            end <- currentTime-            let duration = realToFrac $ diffUTCTime end start-            withSpan "metrics.with_histogram_timing.histogram_observe"-                $ liftIO-                $ Registry.observeHistogram handles metricName duration-            pure result-        ExportMetrics -> withSpan "metrics.export_metrics" $ liftIO $ decodeUtf8 <$> Prom.exportMetricsAsText----- | No-op interpreter that discards all metrics operations-runMetricsNoOp :: Eff (Metrics : es) a -> Eff es a-runMetricsNoOp = interpret \env -> \case-    GaugeSet _ _ -> pure ()-    GaugeInc _ -> pure ()-    GaugeDec _ -> pure ()-    CounterInc _ -> pure ()-    CounterAdd _ _ -> pure ()-    HistogramObserve _ _ -> pure ()-    WithHistogramTiming _ eff -> localSeqUnlift env \unlift -> unlift eff-    ExportMetrics -> pure ""

@@ -1,119 +0,0 @@--- | Metric registry for managing Prometheus metrics.------ The actual implementation of the `runMetrics` handler.-module Atelier.Effects.Monitoring.Metrics.Registry-    ( MetricHandles-    , initMetricHandles-    , setGauge-    , incGauge-    , decGauge-    , incCounter-    , addCounter-    , observeHistogram-    ) where--import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef)--import Data.Map.Strict qualified as Map-import Prometheus qualified as Prom----- | Mutable handles to the registered Prometheus metrics, keyed by name and--- created on first use.-data MetricHandles = MetricHandles-    { gauges :: IORef (Map Text Prom.Gauge)-    , counters :: IORef (Map Text Prom.Counter)-    , histograms :: IORef (Map Text Prom.Histogram)-    }----- | Initialize empty metric handles-initMetricHandles :: IO MetricHandles-initMetricHandles = do-    MetricHandles-        <$> newIORef mempty-        <*> newIORef mempty-        <*> newIORef mempty----- | Set a gauge to a specific value-setGauge :: MetricHandles -> Text -> Double -> IO ()-setGauge handles name value = do-    g <- getOrCreateGauge handles name-    Prom.setGauge g value----- | Increment a gauge by 1-incGauge :: MetricHandles -> Text -> IO ()-incGauge handles name = do-    g <- getOrCreateGauge handles name-    Prom.incGauge g----- | Decrement a gauge by 1-decGauge :: MetricHandles -> Text -> IO ()-decGauge handles name = do-    g <- getOrCreateGauge handles name-    Prom.decGauge g----- | Increment a counter by 1-incCounter :: MetricHandles -> Text -> IO ()-incCounter handles name = do-    c <- getOrCreateCounter handles name-    Prom.incCounter c----- | Add a value to a counter-addCounter :: MetricHandles -> Text -> Double -> IO ()-addCounter handles name value = do-    c <- getOrCreateCounter handles name-    void $ Prom.addCounter c value----- | Observe a value in a histogram-observeHistogram :: MetricHandles -> Text -> Double -> IO ()-observeHistogram handles name value = do-    h <- getOrCreateHistogram handles name-    Prom.observe h value----- | Get or create a gauge metric-getOrCreateGauge :: MetricHandles -> Text -> IO Prom.Gauge-getOrCreateGauge handles name = do-    gaugeMap <- readIORef handles.gauges-    case Map.lookup name gaugeMap of-        Just g -> pure g-        Nothing -> do-            g <- Prom.register $ Prom.gauge (Prom.Info name "")-            atomicModifyIORef' handles.gauges $ \m ->-                (Map.insert name g m, ())-            pure g----- | Get or create a counter metric-getOrCreateCounter :: MetricHandles -> Text -> IO Prom.Counter-getOrCreateCounter handles name = do-    counterMap <- readIORef handles.counters-    case Map.lookup name counterMap of-        Just c -> pure c-        Nothing -> do-            c <- Prom.register $ Prom.counter (Prom.Info name "")-            atomicModifyIORef' handles.counters $ \m ->-                (Map.insert name c m, ())-            pure c----- | Get or create a histogram metric-getOrCreateHistogram :: MetricHandles -> Text -> IO Prom.Histogram-getOrCreateHistogram handles name = do-    histogramMap <- readIORef handles.histograms-    case Map.lookup name histogramMap of-        Just h -> pure h-        Nothing -> do-            -- Default buckets for duration metrics: 1ms, 10ms, 100ms, 1s, 10s-            let buckets = [0.001, 0.01, 0.1, 1.0, 10.0]-            h <- Prom.register $ Prom.histogram (Prom.Info name "") buckets-            atomicModifyIORef' handles.histograms $ \m ->-                (Map.insert name h m, ())-            pure h

@@ -1,50 +0,0 @@--- | Effect for running the Prometheus metrics HTTP server.------ Wraps a Warp server that exposes the current metrics registry over HTTP, so--- callers start it through the effect system rather than raw 'IO'.-module Atelier.Effects.Monitoring.Metrics.Server-    ( -- * Effect-      MetricsServer--      -- * Operations-    , runMetricsServer--      -- * Interpreters-    , runMetricsServerIO-    ) where--import Effectful (Effect, IOE)-import Effectful.Dispatch.Dynamic (interpret_)-import Effectful.TH (makeEffect)-import Network.HTTP.Types (status200)-import Network.Wai (Application, responseLBS)--import Network.Wai.Handler.Warp qualified as Warp-import Prometheus qualified as Prom----- | Running the Prometheus metrics HTTP server.-data MetricsServer :: Effect where-    -- | Start an HTTP server that exposes Prometheus metrics at any path on the-    -- given port. Blocks until the server stops, which normally only happens on-    -- error; intended to be run in a background thread.-    RunMetricsServer :: Int -> MetricsServer m ()---makeEffect ''MetricsServer----- | Interpret 'MetricsServer' by running a real Warp HTTP server.-runMetricsServerIO :: (IOE :> es) => Eff (MetricsServer : es) a -> Eff es a-runMetricsServerIO = interpret_ \case-    RunMetricsServer port -> liftIO $ Warp.run port metricsApp---metricsApp :: Application-metricsApp _req respond = do-    payload <- Prom.exportMetricsAsText-    respond-        $ responseLBS-            status200-            [("Content-Type", "text/plain; version=0.0.4; charset=utf-8")]-            payload

@@ -1,293 +0,0 @@--- | Tracing effect for distributed tracing with OpenTelemetry.------ Provides operations for creating spans, adding attributes, and propagating trace context.------ == Basic Usage------ @--- myHandler :: (Tracing :> es) => Eff es ()--- myHandler = do---     withSpan "api.create_user" $ do---         addAttribute "user.id" "123"---         -- ... do work ...---         setStatus Ok--- @-module Atelier.Effects.Monitoring.Tracing-    ( -- * Effect-      Tracing (..)--      -- * Span Operations-    , withSpan-    , withSpanLinked-    , withLinkPropagation-    , addAttribute-    , addEvent-    , setStatus-    , getSpanContext-    , OT.ToAttribute (..)-    , Attr (..)-    , ToAttributeShow (..)--      -- * Interpreters-    , runTracing-    , runTracingFromConfig-    , runTracingNoOp--      -- * Configuration-    , TracingConfig (..)--      -- * Re-exports-    , SpanStatus (..)-    , SpanContext-    ) where--import Data.Aeson (FromJSON, ToJSON)-import Data.Default (Default (..))-import Effectful (Effect, IOE, Limit (..), Persistence (..), UnliftStrategy (..))-import Effectful.Dispatch.Dynamic (interposeWith, interpret, interpretWith, localSeqUnlift, localUnlift)-import Effectful.Exception (bracket, onException)-import Effectful.Reader.Static (Reader, ask)-import Effectful.TH (makeEffect)--import Data.HashMap.Strict qualified as HashMap-import OpenTelemetry.Context qualified as Context-import OpenTelemetry.Context.ThreadLocal qualified as ThreadLocal-import OpenTelemetry.Trace qualified as OT-import OpenTelemetry.Trace.Core qualified as OT--import Atelier.Effects.Timeout (Timeout, timeout)-import Atelier.Time (Second)-import Atelier.Types.QuietSnake (QuietSnake (..))-import Atelier.Types.WithDefaults (WithDefaults (..))--import Atelier.Effects.Monitoring.Tracing.Provider qualified as Provider----- | Tracing configuration for OpenTelemetry-data TracingConfig = TracingConfig-    { enabled :: Bool-    -- ^ Enable tracing-    , serviceName :: Text-    -- ^ Service name for traces-    , otlpEndpoint :: Text-    -- ^ OTLP endpoint (e.g., "http://localhost:4318")-    }-    deriving stock (Eq, Generic, Show)-    deriving (ToJSON) via QuietSnake TracingConfig-    deriving (FromJSON) via WithDefaults (QuietSnake TracingConfig)---instance Default TracingConfig where-    def =-        TracingConfig-            { enabled = False-            , serviceName = "hoard"-            , otlpEndpoint = "http://localhost:4318"-            }----- | Span status for indicating success or failure-data SpanStatus-    = -- | The operation completed successfully.-      Ok-    | -- | The operation failed, with an explanatory message.-      Error Text-    deriving stock (Eq, Show)----- | Opaque span context for correlating traces with metrics-type SpanContext = OT.SpanContext----- | Tracing effect for distributed tracing-data Tracing :: Effect where-    -- | Execute an action within a named span (bracket-style, automatic cleanup)-    WithSpan :: Text -> m a -> Tracing m a-    -- | Execute an action within a named span with links to other span contexts-    WithSpanLinked :: Text -> [SpanContext] -> m a -> Tracing m a-    -- | Add an attribute to the current span-    AddAttribute :: (OT.ToAttribute attr) => Text -> attr -> Tracing m ()-    -- | Add an event to the current span-    AddEvent :: (OT.ToAttribute attr) => Text -> [(Text, attr)] -> Tracing m ()-    -- | Set the status of the current span-    SetStatus :: SpanStatus -> Tracing m ()-    -- | Get the current span context (for exemplars)-    GetSpanContext :: Tracing m (Maybe SpanContext)-    -- | Get the current OpenTelemetry context (internal use)-    GetCurrentContext :: Tracing m Context.Context----- | Useful to create a heterogeneous list of attribute values. These two are equivalent:------ @--- addEvent "foo" [OT.toAttribute 1, OT.toAttribute "foo"]--- addEvent "foo" [Attr 1, Attr "foo"]--- @-data Attr where-    Attr :: (OT.ToAttribute a) => a -> Attr---instance OT.ToAttribute Attr where-    toAttribute (Attr a) = OT.toAttribute a----- | Wrapper that turns any 'Show'able value into an OpenTelemetry attribute via--- its 'Show' instance. Derive an attribute instance @via 'ToAttributeShow' T@,--- or wrap a value directly.-newtype ToAttributeShow a = ToAttributeShow-    { getToAttributeShow :: a-    }---instance (Show a) => OT.ToPrimitiveAttribute (ToAttributeShow a) where-    toPrimitiveAttribute = OT.TextAttribute . show . getToAttributeShow---instance (Show a) => OT.ToAttribute (ToAttributeShow a)---makeEffect ''Tracing----- | Run an action with automatic span link propagation for fire-and-forget forks.------ Any span created with no current parent (i.e., a root span) will automatically--- receive a link to @parentCtx@. Nested spans inside those are unaffected — they--- already have a parent and follow normal child semantics.------ This avoids the trace growth problem caused by parent-child propagation in--- long-running loops: each loop iteration's work becomes its own trace, linked--- back to the originating span rather than piling spans onto a single trace.-withLinkPropagation :: (Tracing :> es) => Maybe SpanContext -> Eff es a -> Eff es a-withLinkPropagation Nothing action = action-withLinkPropagation (Just parentSpanCtx) action =-    interposeWith action $ \env -> \case-        WithSpan name m -> do-            currentCtx <- getCurrentContext-            localUnlift env (ConcUnlift Persistent Unlimited) $ \unlift ->-                case Context.lookupSpan currentCtx of-                    Nothing -> withSpanLinked name [parentSpanCtx] (unlift m)-                    Just _ -> withSpan name (unlift m)-        WithSpanLinked name ctxs m ->-            localUnlift env (ConcUnlift Persistent Unlimited) $ \unlift ->-                withSpanLinked name ctxs (unlift m)-        AddAttribute key val -> addAttribute key val-        AddEvent name attrs -> addEvent name attrs-        SetStatus status -> setStatus status-        GetSpanContext -> getSpanContext-        GetCurrentContext -> getCurrentContext----- | Run the Tracing effect with OpenTelemetry------ Initializes the tracer provider and manages span lifecycle.-runTracing-    :: (IOE :> es, Timeout :> es)-    => Bool-    -- ^ Tracing enabled flag-    -> Text-    -- ^ Service name-    -> Text-    -- ^ OTLP endpoint-    -> Eff (Tracing : es) a-    -> Eff es a-runTracing enabled serviceName otlpEndpoint action-    | not enabled = runTracingNoOp action-    | otherwise =-        bracket-            (liftIO $ Provider.initTracingState serviceName otlpEndpoint)-            (\tracingState -> void $ timeout (3 :: Second) $ liftIO $ Provider.shutdownTracingState tracingState)-            $ \tracingState -> interpretWith action $ \env -> \case-                WithSpan spanName innerAction -> localSeqUnlift env $ \unlift -> do-                    currentCtx <- liftIO ThreadLocal.getContext-                    newSpan <- liftIO $ OT.createSpan tracingState.tracer currentCtx spanName OT.defaultSpanArguments-                    let newCtx = Context.insertSpan newSpan currentCtx-                    oldCtx <- liftIO $ ThreadLocal.attachContext newCtx-                    innerResult <--                        unlift innerAction `onException` do-                            liftIO $ OT.setStatus newSpan (OT.Error "Exception occurred")-                    -- Restore the old context-                    liftIO $ void $ case oldCtx of-                        Just ctx -> ThreadLocal.attachContext ctx-                        Nothing -> ThreadLocal.detachContext-                    liftIO $ OT.endSpan newSpan Nothing-                    pure innerResult-                WithSpanLinked spanName linkedContexts innerAction -> localSeqUnlift env $ \unlift -> do-                    currentCtx <- liftIO ThreadLocal.getContext-                    let spanArgs =-                            OT.defaultSpanArguments-                                { OT.links = map (\ctx -> OT.NewLink ctx mempty) linkedContexts-                                }-                    newSpan <- liftIO $ OT.createSpan tracingState.tracer currentCtx spanName spanArgs-                    let newCtx = Context.insertSpan newSpan currentCtx-                    oldCtx <- liftIO $ ThreadLocal.attachContext newCtx-                    innerResult <--                        unlift innerAction `onException` do-                            liftIO $ OT.setStatus newSpan (OT.Error "Exception occurred")--                    -- Restore the old context-                    liftIO $ void $ case oldCtx of-                        Just ctx -> ThreadLocal.attachContext ctx-                        Nothing -> ThreadLocal.detachContext-                    liftIO $ OT.endSpan newSpan Nothing-                    pure innerResult-                AddAttribute key value -> do-                    currentCtx <- liftIO ThreadLocal.getContext-                    case Context.lookupSpan currentCtx of-                        Just currentSpan ->-                            liftIO $ OT.addAttribute currentSpan key (OT.toAttribute value)-                        Nothing ->-                            -- No active span, ignore-                            pure ()-                AddEvent eventName attributes -> do-                    currentCtx <- liftIO ThreadLocal.getContext-                    case Context.lookupSpan currentCtx of-                        Just currentSpan -> do-                            let attrMap = HashMap.fromList $ map (\(k, v) -> (k, OT.toAttribute v)) attributes-                            let event = OT.NewEvent eventName attrMap Nothing-                            liftIO $ OT.addEvent currentSpan event-                        Nothing ->-                            -- No active span, ignore-                            pure ()-                SetStatus status -> do-                    currentCtx <- liftIO ThreadLocal.getContext-                    case Context.lookupSpan currentCtx of-                        Just currentSpan ->-                            liftIO $ case status of-                                Ok -> OT.setStatus currentSpan OT.Ok-                                Error msg -> OT.setStatus currentSpan (OT.Error msg)-                        Nothing ->-                            -- No active span, ignore-                            pure ()-                GetSpanContext -> do-                    currentCtx <- liftIO ThreadLocal.getContext-                    case Context.lookupSpan currentCtx of-                        Just currentSpan -> do-                            spanCtx <- liftIO $ OT.getSpanContext currentSpan-                            pure $ Just spanCtx-                        Nothing -> pure Nothing-                GetCurrentContext -> liftIO ThreadLocal.getContext----- | Run the Tracing effect with config from Reader------ Convenience wrapper that reads TracingConfig from the Reader effect.-runTracingFromConfig-    :: (IOE :> es, Reader TracingConfig :> es, Timeout :> es)-    => Eff (Tracing : es) a-    -> Eff es a-runTracingFromConfig action = do-    TracingConfig {enabled, serviceName, otlpEndpoint} <- ask-    runTracing enabled serviceName otlpEndpoint action----- | No-op interpreter that discards all tracing operations-runTracingNoOp :: Eff (Tracing : es) a -> Eff es a-runTracingNoOp = interpret $ \env -> \case-    WithSpan _ act -> localSeqUnlift env $ \unlift -> unlift act-    WithSpanLinked _ _ act -> localSeqUnlift env $ \unlift -> unlift act-    AddAttribute _ _ -> pure ()-    AddEvent _ _ -> pure ()-    SetStatus _ -> pure ()-    GetSpanContext -> pure Nothing-    GetCurrentContext -> pure Context.empty

@@ -1,70 +0,0 @@--- | Tracing provider for managing OpenTelemetry TracerProvider and span stack.------ The actual implementation backing the `runTracing` handler.-module Atelier.Effects.Monitoring.Tracing.Provider-    ( TracingState (..)-    , initTracingState-    , shutdownTracingState-    ) where--import System.Environment (setEnv)--import OpenTelemetry.Attributes qualified as OT-import OpenTelemetry.Trace qualified as OT----- | Handles to the initialised OpenTelemetry tracer provider and a tracer--- derived from it.-data TracingState = TracingState-    { tracerProvider :: OT.TracerProvider-    -- ^ The global tracer provider; flushed and shut down on teardown.-    , tracer :: OT.Tracer-    -- ^ The tracer used to create spans.-    }----- | Initialize tracing state using global tracer provider------ This uses initializeGlobalTracerProvider which reads configuration from--- environment variables (OTEL_SERVICE_NAME, OTEL_EXPORTER_OTLP_ENDPOINT)--- and properly sets up ID generation.-initTracingState-    :: Text-    -- ^ Service name-    -> Text-    -- ^ OTLP endpoint (e.g., "http://localhost:4318")-    -> IO TracingState-initTracingState serviceName otlpEndpoint = do-    -- Set environment variables for OpenTelemetry SDK-    setEnv "OTEL_SERVICE_NAME" (toString serviceName)-    setEnv "OTEL_EXPORTER_OTLP_ENDPOINT" (toString otlpEndpoint)--    -- Initialize the global tracer provider-    -- This reads from environment variables and sets up proper ID generation-    provider <- OT.initializeGlobalTracerProvider--    -- Create instrumentation library-    let instrumentationLibrary =-            OT.InstrumentationLibrary-                serviceName -- Library name-                "" -- Version (empty for now)-                "" -- Schema URL (empty for now)-                OT.emptyAttributes -- Attributes--    -- Get a tracer from the provider-    let tracerInstance = OT.makeTracer provider instrumentationLibrary OT.tracerOptions--    pure-        TracingState-            { tracerProvider = provider-            , tracer = tracerInstance-            }----- | Shutdown tracing state gracefully------ Flushes any remaining spans and cleans up resources.-shutdownTracingState :: TracingState -> IO ()-shutdownTracingState tracingState = do-    -- Force shutdown of the tracer provider to flush spans-    OT.shutdownTracerProvider tracingState.tracerProvider

@@ -1,69 +1,27 @@ module Atelier.Effects.Publishing     ( runPubSub-    , runPubSub_     ) where  import Data.Time (UTCTime)-import Effectful.Dispatch.Dynamic (interpret, interpretWith, interpretWith_, interpret_, localSeqUnlift)+import Effectful.Dispatch.Dynamic (interpret, interpret_, localSeqUnlift)  import Atelier.Effects.Chan (Chan) import Atelier.Effects.Clock (Clock)-import Atelier.Effects.Monitoring.Tracing (SpanContext, Tracing) import Atelier.Effects.Publishing.Pub (Pub (..)) import Atelier.Effects.Publishing.Sub (Sub (..))  import Atelier.Effects.Chan qualified as Chan import Atelier.Effects.Clock qualified as Clock-import Atelier.Effects.Monitoring.Tracing qualified as Tracing  --- | Internal wrapper for events with trace context-data TracedEvent event = TracedEvent-    { event :: event-    , timestamp :: UTCTime-    , publisherSpanContext :: Maybe SpanContext-    }-- -- | Runs 'Pub' and 'Sub' effects with an internal channel for a specific event--- type. Automatically captures span context from the publisher and creates--- linked spans in listeners.-runPubSub-    :: forall event es a-     . ( Chan :> es-       , Clock :> es-       , Tracing :> es-       )-    => Eff (Pub event : Sub event : es) a -> Eff es a-runPubSub action = do-    (inChan, _) <- Chan.newChan @(TracedEvent event)--    let handlePub eff = interpretWith_ eff \case-            Publish event -> do-                timestamp <- Clock.currentTime-                -- Capture the current span context from the publisher-                publisherSpanContext <- Tracing.getSpanContext-                Chan.writeChan inChan TracedEvent {event, timestamp, publisherSpanContext}--        handleSub eff = interpretWith eff \env -> \case-            ListenWith onSubscribed listener -> localSeqUnlift env \unlift -> do-                chan <- Chan.dupChan inChan-                unlift onSubscribed-                forever do-                    TracedEvent {event, timestamp, publisherSpanContext} <- Chan.readChan chan-                    Tracing.withLinkPropagation publisherSpanContext $ unlift $ listener timestamp event--    handleSub . handlePub $ action----- | Runs 'Pub' and 'Sub' effects with an internal channel for a specific event -- type.-runPubSub_+runPubSub     :: forall event es a      . (Chan :> es, Clock :> es)     => Eff (Pub event : Sub event : es) a -> Eff es a-runPubSub_ action = do+runPubSub action = do     (inChan, _) <- Chan.newChan @(UTCTime, event)     let handlePub = interpret_ \case             Publish event -> do

@@ -9,7 +9,6 @@ import Atelier.Effects.Cache.Singleflight (Singleflight, runSingleflight, updateCache, withCache) import Atelier.Effects.Conc (Conc, runConc) import Atelier.Effects.Delay (Delay, runDelay)-import Atelier.Effects.Monitoring.Tracing (Tracing, runTracingNoOp) import Atelier.Time (Millisecond) import Atelier.Types.Semaphore (Semaphore) @@ -26,13 +25,12 @@  -- | Run a Singleflight test with execution counter runSingleflightTest-    :: Eff [Singleflight Int Int, State Int, Delay, Tracing, Conc, Concurrent, IOE] a+    :: Eff [Singleflight Int Int, State Int, Delay, Conc, Concurrent, IOE] a     -> IO (a, Int) runSingleflightTest action =     runEff         . runConcurrent         . runConc-        . runTracingNoOp         . runDelay         . runState @Int 0         . runSingleflight @Int @Int

@@ -27,7 +27,6 @@ import Atelier.Effects.Chan (Chan, runChan) import Atelier.Effects.Clock (Clock, runClock) import Atelier.Effects.Conc (Conc, fork, fork_, runConc, scoped)-import Atelier.Effects.Monitoring.Tracing (Tracing, runTracingNoOp) import Atelier.Effects.Publishing (runPubSub) import Atelier.Effects.Publishing.Pub (Pub) import Atelier.Effects.Publishing.Sub (Sub)@@ -122,5 +121,5 @@   -- | Mirrors 'IteratorSpec.runTest' — the full effect stack the real victim runs on.-runIterTest :: Eff '[Pub Int, Sub Int, Chan, Clock, Tracing, Conc, Concurrent, IOE] a -> IO a-runIterTest = runEff . runConcurrent . runConc . runTracingNoOp . runClock . runChan . runPubSub @Int+runIterTest :: Eff '[Pub Int, Sub Int, Chan, Clock, Conc, Concurrent, IOE] a -> IO a+runIterTest = runEff . runConcurrent . runConc . runClock . runChan . runPubSub @Int

@@ -1,131 +0,0 @@-module Unit.Atelier.Effects.Conc.TracedSpec (spec_ConcTraced) where--import Control.Concurrent (newEmptyMVar, putMVar, takeMVar, threadDelay)-import Data.IORef-import Effectful (IOE, runEff)-import Effectful.Concurrent (runConcurrent)-import Effectful.Dispatch.Dynamic (interpret, localUnlift)-import OpenTelemetry.Common (TraceFlags (..))-import OpenTelemetry.Internal.Trace.Id (SpanId (..), TraceId (..))-import OpenTelemetry.Trace.TraceState (TraceState (..))-import Test.Hspec (Spec, describe, it, shouldReturn, shouldSatisfy)--import OpenTelemetry.Context qualified as Context-import OpenTelemetry.Context.ThreadLocal qualified as ThreadLocal-import OpenTelemetry.Trace.Core qualified as OT--import Atelier.Effects.Conc (await, concStrat, fork, fork_)-import Atelier.Effects.Conc.Traced (runConc)-import Atelier.Effects.Monitoring.Tracing (SpanContext, Tracing (..), withLinkPropagation, withSpan)---spec_ConcTraced :: Spec-spec_ConcTraced = do-    describe "withLinkPropagation" $ do-        it "passes through when no parent context" $ do-            ops <- newIORef []-            runEff . runTracingCapture ops-                $ withLinkPropagation Nothing-                $ withSpan "foo"-                $ pure ()-            readIORef ops `shouldReturn` [PlainSpan "foo"]--        it "converts root span to linked span when parent context given" $ do-            ops <- newIORef []-            runEff . runTracingCapture ops-                $ withLinkPropagation (Just fakeSpanCtx)-                $ withSpan "foo"-                $ pure ()-            readIORef ops `shouldReturn` [LinkedSpan "foo"]--        it "does not convert nested spans (they already have a parent)" $ do-            ops <- newIORef []-            runEff . runTracingCapture ops-                $ withSpan "outer"-                $ withLinkPropagation (Just fakeSpanCtx)-                $ withSpan "inner"-                $ pure ()-            readIORef ops `shouldReturn` [PlainSpan "outer", PlainSpan "inner"]--    describe "withConcTracingLinks" $ do-        it "does not link when forking outside any span" $ do-            ops <- newIORef []-            runEff . runConcurrent . runTracingCapture ops . runConc $ do-                t <- fork $ withSpan "child" $ pure ()-                await t-            readIORef ops `shouldReturn` [PlainSpan "child"]--        it "links forked thread's root span to the parent span" $ do-            ops <- newIORef []-            runEff . runConcurrent . runTracingCapture ops . runConc $ do-                withSpan "parent" $ do-                    t <- fork $ withSpan "child" $ pure ()-                    await t-            readIORef ops `shouldReturn` [PlainSpan "parent", LinkedSpan "child"]--        it "links fork_ thread's root span to the parent span" $ do-            ops <- newIORef []-            spanRecorded <- newEmptyMVar-            runEff . runConcurrent . runTracingCapture ops . runConc $ do-                withSpan "parent" $ do-                    fork_ $ do-                        withSpan "bg" $ pure ()-                        liftIO $ putMVar spanRecorded ()-                        liftIO $ forever $ threadDelay maxBound-                    liftIO $ takeMVar spanRecorded-            readIORef ops >>= (`shouldSatisfy` elem (LinkedSpan "bg"))-------------------------------------------------------------------------------------- Test Infrastructure-----------------------------------------------------------------------------------data SpanOp-    = PlainSpan Text-    | LinkedSpan Text-    deriving stock (Eq, Show)----- | A fake but valid span context for testing.-fakeSpanCtx :: SpanContext-fakeSpanCtx =-    OT.SpanContext-        (TraceFlags 0x01)-        False-        (TraceId "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\1")-        (SpanId "\0\0\0\0\0\0\0\1")-        (TraceState [])----- | Test interpreter that records 'PlainSpan' vs 'LinkedSpan' operations.------ Uses real thread-local storage for context tracking so that forked threads--- correctly start with an empty context (as they would in production), allowing--- 'withLinkPropagation' to distinguish root spans from nested ones.-runTracingCapture-    :: (IOE :> es)-    => IORef [SpanOp]-    -> Eff (Tracing : es) a-    -> Eff es a-runTracingCapture log = interpret $ \env -> \case-    WithSpan name act -> do-        liftIO $ modifyIORef' log (<> [PlainSpan name])-        currentCtx <- liftIO ThreadLocal.getContext-        let newCtx = Context.insertSpan (OT.wrapSpanContext fakeSpanCtx) currentCtx-        oldCtx <- liftIO $ ThreadLocal.attachContext newCtx-        result <- localUnlift env concStrat $ \unlift -> unlift act-        liftIO $ void $ case oldCtx of-            Just ctx -> ThreadLocal.attachContext ctx-            Nothing -> ThreadLocal.detachContext-        pure result-    WithSpanLinked name _ act -> do-        liftIO $ modifyIORef' log (<> [LinkedSpan name])-        localUnlift env concStrat $ \unlift -> unlift act-    GetSpanContext -> do-        ctx <- liftIO ThreadLocal.getContext-        liftIO $ traverse OT.getSpanContext (Context.lookupSpan ctx)-    GetCurrentContext ->-        liftIO ThreadLocal.getContext-    AddAttribute _ _ -> pure ()-    AddEvent _ _ -> pure ()-    SetStatus _ -> pure ()

@@ -8,7 +8,6 @@ import Atelier.Effects.Chan (Chan, runChan) import Atelier.Effects.Clock (Clock, runClock) import Atelier.Effects.Conc (Conc, fork, runConc)-import Atelier.Effects.Monitoring.Tracing (Tracing, runTracingNoOp) import Atelier.Effects.Publishing (runPubSub) import Atelier.Effects.Publishing.Pub (Pub) import Atelier.Effects.Publishing.Sub (Sub)@@ -110,12 +109,11 @@ -- Test Helpers -------------------------------------------------------------------------------- -runTest :: Eff '[Pub Int, Sub Int, Chan, Clock, Tracing, Conc, Concurrent, IOE] a -> IO a+runTest :: Eff '[Pub Int, Sub Int, Chan, Clock, Conc, Concurrent, IOE] a -> IO a runTest =     runEff         . runConcurrent         . runConc-        . runTracingNoOp         . runClock         . runChan         . runPubSub @Int

@@ -9,7 +9,6 @@ import Atelier.Effects.Chan (Chan, runChan) import Atelier.Effects.Clock (Clock, runClock, runClockConst) import Atelier.Effects.Conc (Conc, runConc)-import Atelier.Effects.Monitoring.Tracing (Tracing, runTracingNoOp) import Atelier.Effects.Publishing (runPubSub) import Atelier.Effects.Publishing.Pub (Pub) import Atelier.Effects.Publishing.Sub (Sub)@@ -62,13 +61,12 @@ --------------------------------------------------------------------------------  runPubSubTest-    :: Eff '[Pub TestEvent, Sub TestEvent, Chan, Clock, Tracing, Conc, Concurrent, IOE] a+    :: Eff '[Pub TestEvent, Sub TestEvent, Chan, Clock, Conc, Concurrent, IOE] a     -> IO a runPubSubTest =     runEff         . runConcurrent         . runConc-        . runTracingNoOp         . runClock         . runChan         . runPubSub @TestEvent@@ -76,13 +74,12 @@  runPubSubTestWithClock     :: UTCTime-    -> Eff '[Pub TestEvent, Sub TestEvent, Chan, Clock, Tracing, Conc, Concurrent, IOE] a+    -> Eff '[Pub TestEvent, Sub TestEvent, Chan, Clock, Conc, Concurrent, IOE] a     -> IO a runPubSubTestWithClock t =     runEff         . runConcurrent         . runConc-        . runTracingNoOp         . runClockConst t         . runChan         . runPubSub @TestEvent