diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,25 @@ ## Unreleased +## 0.1.2.0 - 2026-07-05 + +### Added + +- `CacheConfig`, `defaultCacheConfig`, and `cachedLLMWith` for a shared policy + layer across cache backends, including optional TTL-based entry expiry. +- `Shikumi.Cache.Backend.Effort` for best-effort backend error handling and + `stripMessageTimestamps` for canonical cache-key inspection. + +### Changed + +- Cache keys now include endpoint identity, default/per-call headers, provider + compatibility settings, and omit message construction timestamps. This bumps + `currentKeyVersion` to `shikumi-cache/v2`, invalidating old cache entries and + old trace replay keys. +- `cachedLLM` no longer stores in-band provider error responses, and persistent + backend lookup/store failures degrade to cache misses or no-ops. +- Refreshed the internal `shikumi` bound for the `0.3` series. + ## 0.1.1.0 - 2026-06-28 ### Changed diff --git a/shikumi-cache.cabal b/shikumi-cache.cabal --- a/shikumi-cache.cabal +++ b/shikumi-cache.cabal @@ -1,6 +1,6 @@ cabal-version: 3.4 name: shikumi-cache -version: 0.1.1.0 +version: 0.1.2.0 synopsis: Content-addressed response caching for shikumi (EP-6) category: AI description: @@ -36,6 +36,7 @@ hs-source-dirs: src exposed-modules: Shikumi.Cache + Shikumi.Cache.Backend.Effort Shikumi.Cache.Backend.Memory Shikumi.Cache.Backend.SQLite Shikumi.Cache.Key @@ -44,7 +45,7 @@ build-depends: , aeson - , baikai >=0.2 && <0.3 + , baikai >=0.3 && <0.4 , base >=4.20 && <5 , blake3 , bytestring @@ -54,7 +55,7 @@ , generic-lens , lens ^>=5.3 , scientific - , shikumi ^>=0.2.0.0 + , shikumi ^>=0.3.0.0 , stm , text ^>=2.1 , time @@ -68,18 +69,19 @@ ghc-options: -threaded -with-rtsopts=-N build-depends: , aeson - , baikai >=0.2 && <0.3 + , baikai >=0.3 && <0.4 , base , bytestring , containers + , direct-sqlite , directory , effectful , filepath , generic-lens , lens , process - , shikumi ^>=0.2.0.0 - , shikumi-cache ^>=0.1.1.0 + , shikumi ^>=0.3.0.0 + , shikumi-cache ^>=0.1.2.0 , stm , tasty , tasty-hunit diff --git a/src/Shikumi/Cache.hs b/src/Shikumi/Cache.hs --- a/src/Shikumi/Cache.hs +++ b/src/Shikumi/Cache.hs @@ -16,7 +16,10 @@ storeCache, -- * The memoizing policy + CacheConfig (..), + defaultCacheConfig, cachedLLM, + cachedLLMWith, -- * Re-exports CacheKey (..), @@ -26,8 +29,15 @@ ) where +import Baikai (Response, StopReason (ErrorReason)) +import Control.Lens ((^.)) +import Control.Monad (when) +import Data.Generics.Labels () +import Data.Maybe (isNothing) +import Data.Time.Clock (NominalDiffTime, diffUTCTime) import Effectful (Dispatch (Dynamic), DispatchOf, Eff, Effect, (:>)) import Effectful.Dispatch.Dynamic (interpose, passthrough, send) +import GHC.Generics (Generic) import Shikumi.Cache.Key (CacheKey (..), cacheKey, currentKeyVersion) import Shikumi.Cache.Types (CachedResponse (..)) import Shikumi.Effect.Time (Time, getCurrentTime) @@ -48,25 +58,72 @@ storeCache :: (Cache :> es) => CacheKey -> CachedResponse -> Eff es () storeCache k v = send (StoreCache k v) +-- | Policy knobs for 'cachedLLMWith', shared by every backend. +-- +-- 'entryTTL' is the maximum age of a usable entry, measured against +-- 'CachedResponse.storedAt' at lookup time. 'Nothing' (the default) means +-- entries never expire, which is the uniform default across Memory, SQLite, +-- Redis, and Postgres. Expiry is enforced here, at the policy layer, so it +-- behaves identically no matter which backend interprets the 'Cache' effect; an +-- expired entry is treated as a MISS and overwritten by the fresh response. +newtype CacheConfig = CacheConfig + { entryTTL :: Maybe NominalDiffTime + } + deriving stock (Eq, Show, Generic) + +-- | No expiry. +defaultCacheConfig :: CacheConfig +defaultCacheConfig = CacheConfig {entryTTL = Nothing} + -- | Memoize EP-1's @LLM@ @complete@ through the 'Cache' effect: on a HIT (a key --- present whose 'keyVersion' matches the live namespace) return the stored --- response without contacting the provider; on a MISS delegate to the underlying --- @LLM@ handler, store the result, and return it. A stale-version entry is --- treated as a MISS (it is overwritten on re-fetch). The streaming op is passed +-- present whose 'keyVersion' matches the live namespace and whose age satisfies +-- 'defaultCacheConfig') return the stored response without contacting the +-- provider; on a MISS delegate to the underlying @LLM@ handler, store the +-- result if it is successful, and return it. Cache backends are best-effort: +-- lookup failures are MISSes and store failures are no-ops. Entries never +-- expire unless 'entryTTL' is set via 'cachedLLMWith'. In-band error responses +-- are never cached. Under concurrent identical requests both callers may miss +-- and call the provider; this accepted check-then-act race is harmless because +-- stores are idempotent upserts keyed by content. The streaming op is passed -- through unchanged — streams are not cached. cachedLLM :: (Cache :> es, LLM :> es, Time :> es) => Eff es a -> Eff es a -cachedLLM = interpose $ \env -> \case +cachedLLM = cachedLLMWith defaultCacheConfig + +-- | A configured variant of 'cachedLLM'. See 'CacheConfig' for the shared TTL +-- policy. +cachedLLMWith :: + (Cache :> es, LLM :> es, Time :> es) => + CacheConfig -> + Eff es a -> + Eff es a +cachedLLMWith cfg = interpose $ \env -> \case Complete model ctx opts -> do let key = cacheKey model ctx opts hit <- lookupCache key + now <- getCurrentTime case hit of - Just cr | keyVersion cr == currentKeyVersion -> pure (response cr) + Just cr + | keyVersion cr == currentKeyVersion, + fresh (entryTTL cfg) now (storedAt cr) -> + pure (response cr) _ -> do resp <- complete model ctx opts - now <- getCurrentTime - storeCache key (CachedResponse resp now currentKeyVersion) + stored <- getCurrentTime + when (cacheable resp) $ + storeCache key (CachedResponse resp stored currentKeyVersion) pure resp other -> passthrough env other + where + fresh Nothing _ _ = True + fresh (Just ttl) now written = diffUTCTime now written <= ttl + +-- | Only successful responses are memoized. An in-band error response reports a +-- transient provider failure; caching it would replay the outage as the +-- permanent answer. +cacheable :: Response -> Bool +cacheable resp = + (resp ^. #message . #stopReason) /= ErrorReason + && isNothing (resp ^. #errorInfo) diff --git a/src/Shikumi/Cache/Backend/Effort.hs b/src/Shikumi/Cache/Backend/Effort.hs new file mode 100644 --- /dev/null +++ b/src/Shikumi/Cache/Backend/Effort.hs @@ -0,0 +1,15 @@ +-- | The one error posture every persistent cache backend shares: best-effort. +-- A failed storage action degrades to its fallback (a MISS for lookups, a no-op +-- for stores) instead of throwing. Asynchronous exceptions such as thread +-- cancellation and timeouts are re-thrown so structured concurrency keeps +-- working correctly. +module Shikumi.Cache.Backend.Effort (bestEffortIO) where + +import Control.Exception (SomeAsyncException (..), SomeException, catch, fromException, throwIO) + +bestEffortIO :: a -> IO a -> IO a +bestEffortIO fallback act = + act `catch` \(e :: SomeException) -> + case fromException e of + Just (SomeAsyncException _) -> throwIO e + Nothing -> pure fallback diff --git a/src/Shikumi/Cache/Backend/SQLite.hs b/src/Shikumi/Cache/Backend/SQLite.hs --- a/src/Shikumi/Cache/Backend/SQLite.hs +++ b/src/Shikumi/Cache/Backend/SQLite.hs @@ -11,7 +11,9 @@ -- The store is a thin embedded SQLite database (no server) accessed via -- @direct-sqlite@. A single 'Database.SQLite3.Database' handle is guarded by an -- 'MVar' so the 'Cache' effect's lookups and stores are serialized (SQLite's --- default threading mode does not allow concurrent use of one connection). +-- default threading mode does not allow concurrent use of one connection). WAL +-- mode and a busy timeout make separate processes cooperate better. Lookup and +-- store failures are best-effort: they degrade to a MISS or no-op. module Shikumi.Cache.Backend.SQLite ( SQLiteCache, openSQLiteCache, @@ -39,6 +41,7 @@ import Effectful (Eff, IOE, liftIO, (:>)) import Effectful.Dispatch.Dynamic (interpret) import Shikumi.Cache (Cache (..), CacheKey (unCacheKey), CachedResponse (..)) +import Shikumi.Cache.Backend.Effort (bestEffortIO) -- | A handle to an open SQLite-backed cache. The 'Database' is behind an 'MVar' -- so all access through the 'Cache' effect is serialized. @@ -46,7 +49,8 @@ -- | The schema. The @key@ is the 64-hex 'CacheKey' (already version-namespaced -- via the @version@ field baked into the hash). @value@ is the UTF-8 JSON of --- 'CachedResponse'. @stored_at@ is ISO-8601 for inspection/eviction. +-- 'CachedResponse'. @stored_at@ is ISO-8601 for inspection; policy-layer TTL +-- uses the same timestamp inside the JSON value. createTableSQL :: Text createTableSQL = """ @@ -78,6 +82,8 @@ openSQLiteCache path = do db <- SQL.open (T.pack path) SQL.exec db createTableSQL + SQL.exec db "PRAGMA journal_mode=WAL;" + SQL.exec db "PRAGMA busy_timeout=5000;" SQLiteCache <$> newMVar db -- | Close the underlying database handle. @@ -93,8 +99,8 @@ -- simply re-fetched and overwritten — never returned. runCacheSQLite :: (IOE :> es) => SQLiteCache -> Eff (Cache : es) a -> Eff es a runCacheSQLite (SQLiteCache mv) = interpret $ \_ -> \case - LookupCache k -> liftIO (withMVar mv (sqliteLookup k)) - StoreCache k v -> liftIO (withMVar mv (\db -> sqliteStore db k v)) + LookupCache k -> liftIO (bestEffortIO Nothing (withMVar mv (sqliteLookup k))) + StoreCache k v -> liftIO (bestEffortIO () (withMVar mv (\db -> sqliteStore db k v))) -- | SELECT the JSON for a key and decode it; 'Nothing' on absent key or decode -- failure. diff --git a/src/Shikumi/Cache/Key.hs b/src/Shikumi/Cache/Key.hs --- a/src/Shikumi/Cache/Key.hs +++ b/src/Shikumi/Cache/Key.hs @@ -3,13 +3,18 @@ -- | The content-addressed cache key (EP-6) — the MasterPlan's integration point -- #7. A 'CacheKey' is a BLAKE3 256-bit digest (64 lowercase hex chars) over a -- /canonical/ JSON serialization of everything about a request that can change --- the model's answer: the model routing identity, the rendered prompt, the --- tools, and the per-call options. Latency, response ids, API keys, timeouts, --- headers, and per-call metadata are excluded — they do not affect the output. +-- the model's answer: the model routing identity including base URL, model +-- default headers, and compat shim; per-call headers; the rendered prompt with +-- message timestamps excluded; tools; and sampling options. Latency, response +-- ids, API keys, timeouts, and per-call metadata are excluded — they do not +-- affect a successful response's content. -- -- The serialization is canonical (object keys sorted by Unicode code point, no -- insignificant whitespace, UTF-8) so the bytes — and therefore the key — are --- reproducible. The replay engine in +-- reproducible. Any change to the field set requires bumping +-- 'currentKeyVersion'; a bump invalidates all cache entries and makes previously +-- recorded @shikumi-trace@ files unreplayable, with replay failing closed via +-- @ReplayDivergence@. The replay engine in -- @docs/plans/7-hierarchical-tracing-observability-and-replay.md@ (EP-7) reuses -- 'cacheKey' verbatim, so both plans agree byte-for-byte; the golden test in the -- test suite pins the exact hex for a fixed request to catch any drift. @@ -20,6 +25,7 @@ requestToCanonicalValue, requestToCanonicalValueVersioned, currentKeyVersion, + stripMessageTimestamps, ) where @@ -44,9 +50,12 @@ -- | The current cache key-namespace version. Baked into every hashed request -- (the @version@ field) and into 'Shikumi.Cache.Types.CachedResponse.keyVersion'. -- Bumping it changes every key, making all prior entries unreachable — a clean --- invalidation with no row deletion. +-- invalidation with no row deletion. Because @shikumi-trace@ stores cache keys +-- in trace files and recomputes them during replay, a version bump also makes +-- previously recorded trace files unreplayable; replay fails closed with +-- @ReplayDivergence@ rather than serving stale responses. currentKeyVersion :: Text -currentKeyVersion = "shikumi-cache/v1" +currentKeyVersion = "shikumi-cache/v2" -- | A content-addressed cache key: the 64-hex BLAKE3 digest of a request's -- canonical serialization. A @newtype@ so it cannot be confused with arbitrary @@ -71,9 +80,10 @@ -- | Assemble the canonical request 'Value' under an explicit version string. -- Exposed so a test can prove that bumping the version changes the key. The -- top-level object carries exactly the integration-point-#7 field set: --- @api, maxTokens, messages, model, provider, responseFormat, systemPrompt, --- temperature, thinking, toolChoice, tools, version@. 'canonicalJSON' sorts the --- keys, so the listing order here is irrelevant. +-- @api, baseUrl, compat, maxTokens, messages, model, modelHeaders, +-- optionsHeaders, provider, responseFormat, systemPrompt, temperature, +-- thinking, toolChoice, tools, version@. 'canonicalJSON' sorts the keys, so the +-- listing order here is irrelevant. requestToCanonicalValueVersioned :: Text -> Model -> Context -> Options -> Value requestToCanonicalValueVersioned version m ctx opts = object @@ -81,12 +91,16 @@ "model" .= (m ^. #modelId), "provider" .= (m ^. #provider), "api" .= toJSON (m ^. #api), + "baseUrl" .= (m ^. #baseUrl), + "modelHeaders" .= toJSON (m ^. #headers), + "compat" .= toJSON (m ^. #compat), "systemPrompt" .= (ctx ^. #systemPrompt), - "messages" .= toJSON (ctx ^. #messages), + "messages" .= stripMessageTimestamps (toJSON (ctx ^. #messages)), "tools" .= toJSON (ctx ^. #tools), "toolChoice" .= toJSON (opts ^. #toolChoice), "temperature" .= (toScientific <$> (opts ^. #temperature)), "maxTokens" .= (opts ^. #maxTokens), + "optionsHeaders" .= toJSON (opts ^. #headers), "thinking" .= toJSON (opts ^. #thinking), "responseFormat" .= toJSON (opts ^. #responseFormat) ] @@ -95,6 +109,26 @@ -- temperature serialize identically regardless of how the Double was built. toScientific :: Double -> Scientific toScientific = realToFrac + +-- | Delete the payload-level @timestamp@ of every message in a serialized +-- message vector. baikai's 'Baikai.Message.Message' encodes as +-- @{"tag": ..., "contents": {..., "timestamp": ...}}@; the timestamp records +-- when the message value was built, never what the provider sees, so two +-- requests differing only in it must share a cache key. Only the +-- @contents.timestamp@ level is deleted — a @"timestamp"@ key nested inside +-- content blocks or tool arguments is real request data and is preserved. +stripMessageTimestamps :: Value -> Value +stripMessageTimestamps (Array msgs) = Array (fmap stripOne msgs) + where + stripOne (Object msg) = + Object $ + case KM.lookup "contents" msg of + Nothing -> msg + Just contents -> KM.insert "contents" (dropTs contents) msg + stripOne v = v + dropTs (Object payload) = Object (KM.delete "timestamp" payload) + dropTs v = v +stripMessageTimestamps v = v -- | Render a 'Value' to canonical JSON bytes: every object's keys are emitted in -- ascending Unicode code-point order, with no insignificant whitespace. We do diff --git a/src/Shikumi/Cache/ResponseJSON.hs b/src/Shikumi/Cache/ResponseJSON.hs --- a/src/Shikumi/Cache/ResponseJSON.hs +++ b/src/Shikumi/Cache/ResponseJSON.hs @@ -57,7 +57,12 @@ usageOptions = defaultOptions {fieldLabelModifier = camelTo2 '_'} -- | Parse a required object field as 'Scientific' and lift it to 'Rational', --- inverting baikai's @Rational -> Scientific@ cost encoding. +-- inverting baikai's @Rational -> Scientific@ cost encoding. A synthetic cost +-- with a non-terminating decimal expansion, such as @1 % 3@, does not satisfy +-- 'Eq' after an encode/decode round-trip because baikai's encoder drops the +-- repetend index. Real USD pricing rates are decimal, so real provider costs +-- terminate; do not rely on round-tripped 'CachedResponse' equality for +-- synthetic non-decimal costs. ratField :: Object -> Key -> Parser Rational ratField o k = toRational <$> (o .: k :: Parser Scientific) diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -12,13 +12,32 @@ -- process. module Main (main) where -import Baikai (Context, Model, Options, Response, user, _Context, _Model, _Options, _Response) +import Baikai + ( Compat (CompatAnthropicMessages), + Context, + Model, + Options, + Response, + StopReason (ErrorReason), + defaultAnthropicMessagesCompat, + user, + userAt, + _Context, + _Model, + _Options, + _Response, + ) +import Control.Exception (bracket) import Control.Lens ((&), (.~)) +import Data.Aeson (object, toJSON, (.=)) import Data.Generics.Labels () import Data.IORef (IORef, modifyIORef', newIORef, readIORef) +import Data.Map.Strict qualified as Map import Data.Text qualified as T import Data.Time.Clock (UTCTime) import Data.Vector qualified as V +import Database.SQLite3 (Database, SQLData (SQLText), StepResult (Done)) +import Database.SQLite3 qualified as SQL import Effectful (Eff, IOE, liftIO, runEff, type (:>)) import Effectful.Concurrent (runConcurrent) import Effectful.Dispatch.Dynamic (interpret) @@ -27,13 +46,16 @@ CachedResponse (..), cacheKey, cachedLLM, + cachedLLMWith, currentKeyVersion, + defaultCacheConfig, + entryTTL, lookupCache, storeCache, ) import Shikumi.Cache.Backend.Memory (newMemoryCache, runCacheMemory) import Shikumi.Cache.Backend.SQLite (runCacheSQLite, withSQLiteCache) -import Shikumi.Cache.Key (canonicalJSON, requestToCanonicalValueVersioned) +import Shikumi.Cache.Key (canonicalJSON, requestToCanonicalValueVersioned, stripMessageTimestamps) import Shikumi.Effect.Time (runTime) import Shikumi.LLM (LLM (..), complete) import System.Environment (getEnvironment, getExecutablePath, lookupEnv) @@ -64,7 +86,7 @@ -- reproduce. Captured from a first run; any drift in field set, canonical JSON, -- or hash breaks this test. pinnedKey :: T.Text -pinnedKey = "30b2015562ec8b5cd4fdb64c7cc671c84f56f80d24891deec6676c521f008113" +pinnedKey = "b31fd70140abbd0198c6b7caec748a8389bf93be909164bdcc340731b7032564" stubResponse :: Response stubResponse = _Response @@ -148,7 +170,48 @@ testCase "a different request yields a different key" $ assertBool "temperature change must change the key" - (cacheKey fixModel fixCtx fixOpts /= cacheKey fixModel fixCtx (fixOpts & #temperature .~ Just 0.7)) + (cacheKey fixModel fixCtx fixOpts /= cacheKey fixModel fixCtx (fixOpts & #temperature .~ Just 0.7)), + testCase "baseUrl changes the key" $ + assertBool + "endpoint routing must be part of the key" + (cacheKey fixModel fixCtx fixOpts /= cacheKey (fixModel & #baseUrl .~ "https://proxy.internal") fixCtx fixOpts), + testCase "model headers change the key" $ + assertBool + "model default headers must be part of the key" + ( cacheKey fixModel fixCtx fixOpts + /= cacheKey (fixModel & #headers .~ Map.singleton "anthropic-beta" "context-1m-2025-08-07") fixCtx fixOpts + ), + testCase "options headers change the key" $ + assertBool + "per-call headers must be part of the key" + ( cacheKey fixModel fixCtx fixOpts + /= cacheKey fixModel fixCtx (fixOpts & #headers .~ Map.singleton "anthropic-beta" "output-128k-2025-02-19") + ), + testCase "compat shim changes the key" $ + assertBool + "compat request-shaping flags must be part of the key" + ( cacheKey fixModel fixCtx fixOpts + /= cacheKey (fixModel & #compat .~ CompatAnthropicMessages defaultAnthropicMessagesCompat) fixCtx fixOpts + ), + testCase "message timestamps do not affect the key" $ do + let t1 = read "2026-01-01 00:00:00 UTC" :: UTCTime + t2 = read "2026-06-30 12:34:56 UTC" :: UTCTime + ctxAt t = fixCtx & #messages .~ V.singleton (userAt t "ping") + cacheKey fixModel (ctxAt t1) fixOpts @?= cacheKey fixModel (ctxAt t2) fixOpts + cacheKey fixModel fixCtx fixOpts @?= cacheKey fixModel (ctxAt t1) fixOpts, + testCase "stripMessageTimestamps removes only the payload-level timestamp" $ do + let msg inner = + object + [ "tag" .= ("UserMessage" :: T.Text), + "contents" + .= object + [ "timestamp" .= ("2026-01-01T00:00:00Z" :: T.Text), + "content" .= [object ["args" .= object ["timestamp" .= inner]]] + ] + ] + stripped x = stripMessageTimestamps (toJSON [msg (x :: T.Text)]) + assertBool "nested timestamps still discriminate" (stripped "a" /= stripped "b") + stripped "a" @?= stripped "a" ] memoryTests :: TestTree @@ -195,9 +258,44 @@ (wc, _, werr) <- runPhase "write" assertBool ("write phase failed: " <> werr) (wc == ExitSuccess) (rc, _, rerr) <- runPhase "read" - assertBool ("read phase did not find the on-disk entry: " <> rerr) (rc == ExitSuccess) + assertBool ("read phase did not find the on-disk entry: " <> rerr) (rc == ExitSuccess), + testCase "a corrupt row decodes as a MISS" $ + withSystemTempDirectory "shikumi-sqlite" $ \dir -> do + let file = dir "corrupt.db" + got <- withSQLiteCache file $ \c -> do + insertRawSQLiteRow file restartKey "not json" + runEff . runCacheSQLite c $ lookupCache restartKey + got @?= Nothing, + testCase "a dropped table degrades lookup/store to MISS / no-op" $ + withSystemTempDirectory "shikumi-sqlite" $ \dir -> do + let file = dir "dropped.db" + withSQLiteCache file $ \c -> do + withRawSQLite file (`SQL.exec` "DROP TABLE shikumi_cache;") + got <- runEff . runCacheSQLite c $ lookupCache restartKey + got @?= Nothing + runEff . runCacheSQLite c $ storeCache restartKey restartEntry ] +withRawSQLite :: FilePath -> (Database -> IO a) -> IO a +withRawSQLite file = bracket (SQL.open (T.pack file)) SQL.close + +insertRawSQLiteRow :: FilePath -> CacheKey -> T.Text -> IO () +insertRawSQLiteRow file key rawValue = + withRawSQLite file $ \db -> + bracket + ( SQL.prepare + db + """ + INSERT OR REPLACE INTO shikumi_cache (key, value, stored_at) + VALUES (?, ?, ?); + """ + ) + SQL.finalize + $ \stmt -> do + SQL.bind stmt [SQLText (unCacheKey key), SQLText rawValue, SQLText "2026-06-08T00:00:00Z"] + res <- SQL.step stmt + res @?= Done + memoizeTests :: TestTree memoizeTests = testGroup @@ -221,7 +319,32 @@ _ <- complete fixModel fixCtx fixOpts complete fixModel fixCtx (fixOpts & #temperature .~ Just 0.7) n <- readIORef ref - n @?= 2 + n @?= 2, + testCase "an in-band error response is not memoized" $ do + tv <- newMemoryCache + ref <- newIORef 0 + let errResp = stubResponse & #message . #stopReason .~ ErrorReason + _ <- + runEff . runConcurrent . runTime . runCacheMemory tv . runCountingLLM ref errResp . cachedLLM $ do + _ <- complete fixModel fixCtx fixOpts + complete fixModel fixCtx fixOpts + n <- readIORef ref + n @?= 2, + testCase "an entry older than entryTTL is a MISS; the refetched entry is a HIT" $ do + tv <- newMemoryCache + ref <- newIORef 0 + let key = cacheKey fixModel fixCtx fixOpts + cfg = defaultCacheConfig {entryTTL = Just 3600} + runEff . runConcurrent . runCacheMemory tv $ + storeCache key (CachedResponse stubResponse someTime currentKeyVersion) + _ <- + runEff . runConcurrent . runTime . runCacheMemory tv . runCountingLLM ref stubResponse . cachedLLMWith cfg $ + complete fixModel fixCtx fixOpts + _ <- + runEff . runConcurrent . runTime . runCacheMemory tv . runCountingLLM ref stubResponse . cachedLLMWith cfg $ + complete fixModel fixCtx fixOpts + n <- readIORef ref + n @?= 1 ] versioningTests :: TestTree @@ -246,8 +369,8 @@ n @?= 1, testCase "bumping the namespace version changes the hashed bytes" $ assertBool - "v1 and v2 canonical serializations must differ" - ( canonicalJSON (requestToCanonicalValueVersioned "shikumi-cache/v1" fixModel fixCtx fixOpts) - /= canonicalJSON (requestToCanonicalValueVersioned "shikumi-cache/v2" fixModel fixCtx fixOpts) + "current and next-version canonical serializations must differ" + ( canonicalJSON (requestToCanonicalValueVersioned currentKeyVersion fixModel fixCtx fixOpts) + /= canonicalJSON (requestToCanonicalValueVersioned "shikumi-cache/v3" fixModel fixCtx fixOpts) ) ]