diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,26 @@ +Copyright 2026 drlkf + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +2. 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. + +3. Neither the name of the copyright holder nor the names of its 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 HOLDER 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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,15 @@ +# effectful-data-cache-opentelemetry + +`traceCache` wraps every operation in an OpenTelemetry span +(`cache.insert`, `cache.lookup`, …), with `cache.hit` on lookups and +`cache.size` on `size`/`keys`. Keys and values are never recorded. + +```haskell +import Effectful.Cache.OpenTelemetry (traceCache) + +main = runEff . runCache Nothing . traceCache tracer $ do + insert "key" (42 :: Int) +``` + +It is an interposer, so it layers over any interpreter and can be omitted +without touching call sites. diff --git a/effectful-data-cache-opentelemetry.cabal b/effectful-data-cache-opentelemetry.cabal new file mode 100644 --- /dev/null +++ b/effectful-data-cache-opentelemetry.cabal @@ -0,0 +1,68 @@ +cabal-version: 2.2 + +-- This file has been generated from package.yaml by hpack version 0.39.6. +-- +-- see: https://github.com/sol/hpack + +name: effectful-data-cache-opentelemetry +version: 0.2.0.2 +synopsis: OpenTelemetry instrumentation for effectful-data-cache +description: Please see the README on GitHub at +category: cache +homepage: https://github.com/haskell-github-trust/effectful-data-cache#readme +bug-reports: https://github.com/haskell-github-trust/effectful-data-cache/issues +author: drlkf +maintainer: drlkf +copyright: 2026 drlkf +license: BSD-3-Clause +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + +source-repository head + type: git + location: https://github.com/haskell-github-trust/effectful-data-cache + +library + exposed-modules: + Effectful.Cache.OpenTelemetry + other-modules: + Paths_effectful_data_cache_opentelemetry + autogen-modules: + Paths_effectful_data_cache_opentelemetry + hs-source-dirs: + src + ghc-options: -Wall -Wextra -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints + build-depends: + base >=4.7 && <5 + , effectful-core >=2.3 && <3 + , effectful-data-cache >=0.1.0.4 && <0.3 + , hs-opentelemetry-api ==1.0.* + , text >=2.1 && <3 + default-language: Haskell2010 + +test-suite effectful-data-cache-opentelemetry-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Effectful.Cache.OpenTelemetrySpec + Paths_effectful_data_cache_opentelemetry + autogen-modules: + Paths_effectful_data_cache_opentelemetry + hs-source-dirs: + test + ghc-options: -Wall -Wextra -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N + build-tool-depends: + hspec-discover:hspec-discover + build-depends: + base >=4.7 && <5 + , effectful-core + , effectful-data-cache + , effectful-data-cache-opentelemetry + , hs-opentelemetry-api + , hs-opentelemetry-exporter-in-memory + , hs-opentelemetry-sdk + , hspec + , text + default-language: Haskell2010 diff --git a/src/Effectful/Cache/OpenTelemetry.hs b/src/Effectful/Cache/OpenTelemetry.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Cache/OpenTelemetry.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +-- | OpenTelemetry instrumentation for 'Cache', layered over any interpreter. +-- +-- > runEff . runCache Nothing . traceCache tracer $ do ... +module Effectful.Cache.OpenTelemetry ( + traceCache, +) where + +import Data.Maybe (isJust) +import Data.Text (Text) +import Effectful +import Effectful.Cache (Cache (..)) +import Effectful.Dispatch.Dynamic (interpose, passthrough) +import OpenTelemetry.Trace.Core ( + Tracer, + addAttribute, + defaultSpanArguments, + inSpan', + ) + +-- | Wrap every cache operation in a span. Keys and values are never recorded: +-- unbounded cardinality, and likely user data. +-- +-- @since 0.1.0.1 +traceCache + :: forall k v es a + . Cache k v :> es + => IOE :> es + => Tracer + -> Eff es a + -> Eff es a +traceCache tracer = interpose @(Cache k v) $ \env op -> + inSpan' tracer (opName op) defaultSpanArguments $ \sp -> do + r <- passthrough env op + case op of + Lookup _ -> addAttribute sp "cache.hit" (isJust r) + Lookup' _ -> addAttribute sp "cache.hit" (isJust r) + Size -> addAttribute sp "cache.size" r + Keys -> addAttribute sp "cache.size" (length r) + _ -> pure () + pure r + +opName + :: Cache k v m a + -> Text +opName = \case + Insert{} -> "cache.insert" + Insert'{} -> "cache.insert" + Lookup{} -> "cache.lookup" + Lookup'{} -> "cache.lookup" + Keys{} -> "cache.keys" + Delete{} -> "cache.delete" + FilterWithKey{} -> "cache.filterWithKey" + Purge{} -> "cache.purge" + PurgeExpired{} -> "cache.purgeExpired" + Size{} -> "cache.size" + DefaultExpiration{} -> "cache.defaultExpiration" + SetDefaultExpiration{} -> "cache.setDefaultExpiration" diff --git a/test/Effectful/Cache/OpenTelemetrySpec.hs b/test/Effectful/Cache/OpenTelemetrySpec.hs new file mode 100644 --- /dev/null +++ b/test/Effectful/Cache/OpenTelemetrySpec.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Effectful.Cache.OpenTelemetrySpec (spec) where + +import Data.IORef (readIORef) +import Data.Text (Text) +import Effectful +import Effectful.Cache +import Effectful.Cache.OpenTelemetry (traceCache) +import OpenTelemetry.Attributes (Attribute (..), PrimitiveAttribute (..), lookupAttribute) +import OpenTelemetry.Exporter.InMemory.Span (inMemoryListExporter) +import OpenTelemetry.Trace ( + ImmutableSpan (..), + createTracerProvider, + emptyTracerProviderOptions, + makeTracer, + shutdownTracerProvider, + tracerOptions, + ) +import OpenTelemetry.Trace.Core (SpanHot (..)) +import Test.Hspec +import Prelude hiding (lookup) + +-- | Run the given cache program under a traced interpreter, returning its +-- result plus every span that was exported. +traced + :: Eff '[Cache String Int, IOE] a + -> IO (a, [SpanHot]) +traced prog = do + (processor, ref) <- inMemoryListExporter + provider <- createTracerProvider [processor] emptyTracerProviderOptions + let tracer = makeTracer provider "effectful-data-cache-test" tracerOptions + r <- runEff . runCache @String @Int Nothing $ traceCache @String @Int tracer prog + _ <- shutdownTracerProvider provider Nothing + spans <- traverse (readIORef . spanHot) . reverse =<< readIORef ref + pure (r, spans) + +attr + :: SpanHot + -> Text + -> Maybe Attribute +attr s = lookupAttribute (hotAttributes s) + +spec :: Spec +spec = do + it "emits a span per operation" $ do + (_, spans) <- traced $ do + insert @String @Int "a" (1 :: Int) + _ <- lookup @String @Int "a" + purge @String @Int + fmap hotName spans `shouldBe` ["cache.insert", "cache.lookup", "cache.purge"] + + it "records hits and misses" $ do + (_, spans) <- traced $ do + insert @String @Int "a" (1 :: Int) + _ <- lookup @String @Int "a" + _ <- lookup @String @Int "nope" + pure () + let hits = [attr s "cache.hit" | s <- spans, hotName s == "cache.lookup"] + hits + `shouldBe` [ Just (AttributeValue (BoolAttribute True)) + , Just (AttributeValue (BoolAttribute False)) + ] + + it "records the size" $ do + (_, spans) <- traced $ do + insert @String @Int "a" (1 :: Int) + insert @String @Int "b" (2 :: Int) + _ <- size @String @Int + pure () + [attr s "cache.size" | s <- spans, hotName s == "cache.size"] + `shouldBe` [Just (AttributeValue (IntAttribute 2))] + + it "still returns the underlying result" $ do + (r, _) <- traced $ do + insert @String @Int "a" (1 :: Int) + lookup @String @Int "a" + r `shouldBe` Just 1 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}