sofetch-otel (empty) → 0.1.0.0
raw patch · 3 files changed
+370/−0 lines, 3 filesdep +basedep +hs-opentelemetry-apidep +hspec
Dependencies added: base, hs-opentelemetry-api, hspec, sofetch, sofetch-otel, unordered-containers
Files
- sofetch-otel.cabal +56/−0
- src/Fetch/OpenTelemetry.hs +107/−0
- test/Spec.hs +207/−0
+ sofetch-otel.cabal view
@@ -0,0 +1,56 @@+cabal-version: 2.2++-- This file has been generated from package.yaml by hpack version 0.38.1.+--+-- see: https://github.com/sol/hpack++name: sofetch-otel+version: 0.1.0.0+description: OpenTelemetry instrumentation for sofetch+category: Data+homepage: https://github.com/iand675/sofetch#readme+bug-reports: https://github.com/iand675/sofetch/issues+author: Ian Duncan+maintainer: ian@iankduncan.com+copyright: 2026 Ian Duncan+license: BSD-3-Clause+build-type: Simple++source-repository head+ type: git+ location: https://github.com/iand675/sofetch++library+ exposed-modules:+ Fetch.OpenTelemetry+ other-modules:+ Paths_sofetch_otel+ autogen-modules:+ Paths_sofetch_otel+ hs-source-dirs:+ src+ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints+ build-depends:+ base >=4.7 && <5+ , hs-opentelemetry-api+ , sofetch+ default-language: Haskell2010++test-suite sofetch-otel-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Paths_sofetch_otel+ autogen-modules:+ Paths_sofetch_otel+ hs-source-dirs:+ test+ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ base >=4.7 && <5+ , hs-opentelemetry-api+ , hspec+ , sofetch+ , sofetch-otel+ , unordered-containers+ default-language: Haskell2010
+ src/Fetch/OpenTelemetry.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | OpenTelemetry instrumentation for sofetch.+--+-- Creates a root span @sofetch.fetch@ covering the entire computation,+-- with child spans @sofetch.round@ wrapping each batch round.+--+-- When no 'TracerProvider' is configured (the default), all tracing+-- operations are no-ops with negligible overhead.+--+-- @+-- import OpenTelemetry.Trace.Core (makeTracer, tracerOptions)+--+-- tracer <- makeTracer tracerProvider "sofetch" tracerOptions+-- let cfg = fetchConfig id liftIO+-- result <- runFetchWithOTel cfg tracer myFetchAction+-- @+module Fetch.OpenTelemetry+ ( runFetchWithOTel+ ) where++import Fetch+ ( Fetch, FetchConfig(..), FetchEnv(..)+ , CacheRef, newCacheRef+ , Batches, batchSourceCount, batchSize+ , RoundStats(..)+ , runLoopWith+ )++import Data.IORef+import Data.Int (Int64)+import OpenTelemetry.Trace.Core+ ( Tracer+ , SpanArguments(..), SpanKind(..), defaultSpanArguments+ , addAttribute, inSpan'+ )++-- | Run a 'Fetch' computation with OpenTelemetry instrumentation.+--+-- Creates:+--+-- * A root span @sofetch.fetch@ covering the entire computation.+-- * A child span @sofetch.round@ for each batch round, wrapping+-- the actual batch execution (not just the scheduling).+--+-- Root span attributes:+--+-- * @sofetch.total_rounds@: number of batch rounds executed+-- * @sofetch.total_keys@: total keys fetched across all rounds+-- * @sofetch.max_sources_per_round@: max distinct data sources in any round+--+-- Round span attributes:+--+-- * @sofetch.round.number@: 1-based round index+-- * @sofetch.round.sources@: data sources dispatched this round+-- * @sofetch.round.keys@: keys dispatched this round+-- * @sofetch.round.cache_hits@: keys served from cache this round+--+-- To share a cache across runs, set @configCache = Just cRef@ on the+-- 'FetchConfig'.+runFetchWithOTel :: forall m a.+ Monad m+ => FetchConfig m+ -> Tracer+ -> Fetch m a+ -> m a+runFetchWithOTel cfg tracer action = do+ let lower = configLower cfg+ lift = configLift cfg+ cRef <- case configCache cfg of+ Just ref -> pure ref+ Nothing -> lift newCacheRef+ lift $ inSpan' tracer "sofetch.fetch" defaultSpanArguments { kind = Internal } $ \rootSpan -> do+ statsRef <- newIORef (0 :: Int, 0 :: Int, 0 :: Int)++ let e = FetchEnv+ { fetchCache = cRef+ , fetchLower = lower+ , fetchLift = lift+ }++ -- Wrap each round in an OTel span, then accumulate stats.+ withRound :: Int -> Batches m -> m RoundStats -> m ()+ withRound !n batches exec = do+ let nSources = batchSourceCount batches+ nKeys = batchSize batches+ rs <- lift $ inSpan' tracer "sofetch.round" defaultSpanArguments { kind = Internal } $ \roundSpan -> do+ addAttribute roundSpan "sofetch.round.number" (fromIntegral n :: Int64)+ addAttribute roundSpan "sofetch.round.sources" (fromIntegral nSources :: Int64)+ addAttribute roundSpan "sofetch.round.keys" (fromIntegral nKeys :: Int64)+ rs <- lower exec+ addAttribute roundSpan "sofetch.round.cache_hits" (fromIntegral (roundCacheHits rs) :: Int64)+ pure rs+ lift $ modifyIORef' statsRef $ \(r, k', s) ->+ (r + 1, k' + roundKeys rs, max s (roundSources rs))++ result <- lower $ runLoopWith e withRound action++ (rounds, keys, sources) <- readIORef statsRef+ addAttribute rootSpan "sofetch.total_rounds" (fromIntegral rounds :: Int64)+ addAttribute rootSpan "sofetch.total_keys" (fromIntegral keys :: Int64)+ addAttribute rootSpan "sofetch.max_sources_per_round" (fromIntegral sources :: Int64)++ pure result
+ test/Spec.hs view
@@ -0,0 +1,207 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}++module Main (main) where++import Fetch+import Fetch.OpenTelemetry++import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HM+import Data.IORef+import qualified Data.List.NonEmpty as NE+import Data.Maybe (mapMaybe)+import GHC.Generics (Generic)+import OpenTelemetry.Trace.Core+ ( Tracer, makeTracer, getGlobalTracerProvider+ , InstrumentationLibrary(..), tracerOptions+ )+import OpenTelemetry.Attributes (emptyAttributes)+import Test.Hspec++-- ══════════════════════════════════════════════+-- Test key types+-- ══════════════════════════════════════════════++newtype UserId = UserId Int+ deriving stock (Eq, Ord, Show, Generic)+ deriving anyclass (Hashable)++instance FetchKey UserId where+ type Result UserId = String++newtype PostId = PostId Int+ deriving stock (Eq, Ord, Show, Generic)+ deriving anyclass (Hashable)++instance FetchKey PostId where+ type Result PostId = String++newtype FailKey = FailKey Int+ deriving stock (Eq, Ord, Show, Generic)+ deriving anyclass (Hashable)++instance FetchKey FailKey where+ type Result FailKey = String++-- ══════════════════════════════════════════════+-- Test monad & data sources+-- ══════════════════════════════════════════════++data TestEnv = TestEnv+ { envUsers :: HashMap UserId String+ , envUserLog :: IORef [[UserId]]+ , envPosts :: HashMap PostId String+ }++mkTestEnv :: IO TestEnv+mkTestEnv = TestEnv+ <$> pure (HM.fromList [(UserId 1, "Alice"), (UserId 2, "Bob")])+ <*> newIORef []+ <*> pure (HM.fromList [(PostId 10, "Hello World")])++newtype TestM a = TestM { unTestM :: TestEnv -> IO a }++instance Functor TestM where+ fmap f (TestM g) = TestM $ \env -> fmap f (g env)++instance Applicative TestM where+ pure a = TestM $ \_ -> pure a+ TestM ff <*> TestM fx = TestM $ \env -> ff env <*> fx env++instance Monad TestM where+ TestM ma >>= f = TestM $ \env -> do+ a <- ma env+ unTestM (f a) env++askTestEnv :: TestM TestEnv+askTestEnv = TestM pure++testLiftIO :: IO a -> TestM a+testLiftIO io = TestM $ \_ -> io++runTestM :: TestEnv -> TestM a -> IO a+runTestM env (TestM f) = f env++instance DataSource TestM UserId where+ batchFetch keysNE = do+ let keys = NE.toList keysNE+ env <- askTestEnv+ testLiftIO $ modifyIORef' (envUserLog env) (keys :)+ pure $ HM.fromList+ (mapMaybe (\k -> fmap (\v -> (k, v)) (HM.lookup k (envUsers env))) keys)++instance DataSource TestM PostId where+ batchFetch keysNE = do+ let keys = NE.toList keysNE+ env <- askTestEnv+ pure $ HM.fromList+ (mapMaybe (\k -> fmap (\v -> (k, v)) (HM.lookup k (envPosts env))) keys)++instance DataSource TestM FailKey where+ batchFetch _ = error "FailKey data source exploded"++-- ══════════════════════════════════════════════+-- Helpers+-- ══════════════════════════════════════════════++mkNoopTracer :: IO Tracer+mkNoopTracer = do+ tp <- getGlobalTracerProvider+ pure $ makeTracer tp+ (InstrumentationLibrary "sofetch-otel-test" "" "" emptyAttributes)+ tracerOptions++-- ══════════════════════════════════════════════+-- Tests+-- ══════════════════════════════════════════════++main :: IO ()+main = hspec $ describe "Fetch.OpenTelemetry" $ do++ it "single fetch returns correct value" $ do+ env <- mkTestEnv+ tracer <- mkNoopTracer+ result <- runTestM env $+ runFetchWithOTel (fetchConfig (runTestM env) testLiftIO) tracer $ fetch (UserId 1)+ result `shouldBe` "Alice"++ it "applicative batching works" $ do+ env <- mkTestEnv+ tracer <- mkNoopTracer+ (a, b) <- runTestM env $+ runFetchWithOTel (fetchConfig (runTestM env) testLiftIO) tracer $+ (,) <$> fetch (UserId 1) <*> fetch (UserId 2)+ a `shouldBe` "Alice"+ b `shouldBe` "Bob"+ batches <- readIORef (envUserLog env)+ length batches `shouldBe` 1++ it "monadic >>= creates separate rounds" $ do+ env <- mkTestEnv+ tracer <- mkNoopTracer+ _ <- runTestM env $+ runFetchWithOTel (fetchConfig (runTestM env) testLiftIO) tracer $ do+ _ <- fetch (UserId 1)+ fetch (UserId 2)+ batches <- readIORef (envUserLog env)+ length batches `shouldBe` 2++ it "multi-source batching works" $ do+ env <- mkTestEnv+ tracer <- mkNoopTracer+ (user, post) <- runTestM env $+ runFetchWithOTel (fetchConfig (runTestM env) testLiftIO) tracer $+ (,) <$> fetch (UserId 1) <*> fetch (PostId 10)+ user `shouldBe` "Alice"+ post `shouldBe` "Hello World"++ it "tryFetch returns Left for missing key" $ do+ env <- mkTestEnv+ tracer <- mkNoopTracer+ result <- runTestM env $+ runFetchWithOTel (fetchConfig (runTestM env) testLiftIO) tracer $ tryFetch (UserId 999)+ case result of+ Left _ -> pure ()+ Right _ -> expectationFailure "Expected Left for missing key"++ it "data source exceptions are caught by tryFetch" $ do+ env <- mkTestEnv+ tracer <- mkNoopTracer+ result <- runTestM env $+ runFetchWithOTel (fetchConfig (runTestM env) testLiftIO) tracer $ tryFetch (FailKey 1)+ case result of+ Left _ -> pure ()+ Right _ -> expectationFailure "Expected Left for failed source"++ it "shared cache across runs via configCache" $ do+ env <- mkTestEnv+ tracer <- mkNoopTracer+ cRef <- newCacheRef+ _ <- runTestM env $+ runFetchWithOTel ((fetchConfig (runTestM env) testLiftIO) { configCache = Just cRef }) tracer $ fetch (UserId 1)+ _ <- runTestM env $+ runFetchWithOTel ((fetchConfig (runTestM env) testLiftIO) { configCache = Just cRef }) tracer $ fetch (UserId 1)+ batches <- readIORef (envUserLog env)+ length batches `shouldBe` 1++ it "primeCache seeds cache through OTel runner" $ do+ env <- mkTestEnv+ tracer <- mkNoopTracer+ cRef <- newCacheRef+ _ <- runTestM env $+ runFetchWithOTel ((fetchConfig (runTestM env) testLiftIO) { configCache = Just cRef }) tracer $ do+ primeCache (UserId 1) "OTel-Seeded"+ result <- runTestM env $+ runFetchWithOTel ((fetchConfig (runTestM env) testLiftIO) { configCache = Just cRef }) tracer $ fetch (UserId 1)+ result `shouldBe` "OTel-Seeded"+ batches <- readIORef (envUserLog env)+ length batches `shouldBe` 0