-- | EP-6 Redis backend acceptance. Round-trips a @CachedResponse@ through a live
-- Redis over the @cachedLLM@ memoizer + a counting stub provider: the first
-- request is a MISS (provider called once, entry stored), a subsequent request
-- is a HIT served from Redis (no further provider call).
--
-- The test connects to the UNIX socket named by @REDIS_SOCKET@ (set by the dev
-- shell; started by @just services@). When the variable is unset or no server is
-- reachable, the suite __skips cleanly__ (prints a notice and exits 0) so CI
-- without a Redis stays green, unless @SHIKUMI_REQUIRE_BACKENDS@ is set (CI sets
-- it), in which case the skip becomes a failure.
module Main (main) where
import Baikai (Context, Model, Options, Response, user, _Context, _Model, _Options, _Response)
import Control.Exception (SomeException, try)
import Control.Lens ((&), (.~))
import Control.Monad (void)
import Data.ByteString (ByteString)
import Data.Generics.Labels ()
import Data.IORef (IORef, modifyIORef', newIORef, readIORef)
import Data.List.NonEmpty (NonEmpty ((:|)))
import Data.Text.Encoding qualified as TE
import Data.Time.Clock (UTCTime)
import Data.Vector qualified as V
import Database.Redis qualified as R
import Effectful (Eff, IOE, liftIO, runEff, type (:>))
import Effectful.Dispatch.Dynamic (interpret)
import Shikumi.Cache
( CacheKey (unCacheKey),
CachedResponse (..),
cacheKey,
cachedLLM,
currentKeyVersion,
lookupCache,
storeCache,
)
import Shikumi.Cache.Backend.Redis
( RedisCache,
closeRedisCache,
openRedisCache,
openRedisCacheWithTTL,
runCacheRedis,
)
import Shikumi.Effect.Time (runTime)
import Shikumi.LLM (LLM (..), complete)
import System.Environment (lookupEnv)
import System.Exit (exitFailure, exitSuccess)
import System.IO (hPutStrLn, stderr)
import Test.Tasty (TestTree, defaultMain, testGroup)
import Test.Tasty.HUnit (assertBool, testCase, (@?=))
fixModel :: Model
fixModel = _Model & #modelId .~ "claude-sonnet-4-6" & #provider .~ "anthropic"
fixCtx :: Context
fixCtx = _Context & #systemPrompt .~ Just "You are helpful." & #messages .~ V.singleton (user "ping")
fixOpts :: Options
fixOpts = _Options & #temperature .~ Just 0.0 & #maxTokens .~ Just 1024
stubResponse :: Response
stubResponse = _Response
someTime :: UTCTime
someTime = read "2026-06-08 00:00:00 UTC"
entry :: CachedResponse
entry = CachedResponse stubResponse someTime currentKeyVersion
-- | A counting stub interpreter of EP-1's @LLM@: every completion bumps a
-- counter and returns a fixed response.
runCountingLLM :: (IOE :> es) => IORef Int -> Response -> Eff (LLM : es) a -> Eff es a
runCountingLLM ref resp = interpret $ \_ -> \case
Complete {} -> liftIO (modifyIORef' ref (+ 1)) >> pure resp
Stream {} -> pure []
main :: IO ()
main = do
msock <- lookupEnv "REDIS_SOCKET"
case msock of
Nothing -> skip "REDIS_SOCKET is not set"
Just sock -> do
let ci = R.defaultConnectInfo {R.connectAddr = R.ConnectAddrUnixSocket sock}
attempt <- try (openRedisCache ci) :: IO (Either SomeException RedisCache)
case attempt of
Left _ -> skip ("no Redis reachable at socket " <> sock)
Right cache -> do
clearKey ci
defaultMain (tests ci cache)
closeRedisCache cache
where
skip reason = do
required <- lookupEnv "SHIKUMI_REQUIRE_BACKENDS"
if maybe False (`notElem` ["", "0"]) required
then do
hPutStrLn stderr ("[FAIL] shikumi-cache-redis: SHIKUMI_REQUIRE_BACKENDS is set but " <> reason)
exitFailure
else do
let banner = replicate 72 '='
mapM_
putStrLn
[ banner,
"== SKIPPED: shikumi-cache-redis test suite ran ZERO tests",
"== reason: " <> reason,
"== to run for real: `just services-up` inside `nix develop .#ghc9124`",
"== CI enforcement of this skip is owned by docs/masterplans/9-ci-and-shared-test-infrastructure.md",
banner
]
exitSuccess
-- | Delete any entry a previous run left for the fixed request, via a throwaway
-- connection, so the MISS→HIT counter starts honest.
clearKey :: R.ConnectInfo -> IO ()
clearKey ci = clearKeyFor ci (cacheKey fixModel fixCtx fixOpts)
clearKeyFor :: R.ConnectInfo -> CacheKey -> IO ()
clearKeyFor ci key = do
conn <- R.checkedConnect ci
void $ R.runRedis conn (R.del (redisKeyFor key :| []))
R.disconnect conn
-- | Rebuild the backend's operational key (the backend keeps it private).
redisKeyFor :: CacheKey -> ByteString
redisKeyFor k = TE.encodeUtf8 ("shikumi:cache:" <> unCacheKey k)
tests :: R.ConnectInfo -> RedisCache -> TestTree
tests ci cache =
testGroup
"shikumi-cache-redis"
[ testCase "memoize: first request MISS (provider once), repeat is a Redis HIT" $ do
-- Two identical requests in one run: provider hit exactly once.
refA <- newIORef 0
(r1, r2) <-
runEff . runTime . runCacheRedis cache . runCountingLLM refA stubResponse . cachedLLM $ do
a <- complete fixModel fixCtx fixOpts
b <- complete fixModel fixCtx fixOpts
pure (a, b)
nA <- readIORef refA
nA @?= 1
r1 @?= r2
-- A fresh run (fresh counter) now finds the entry already in Redis → HIT.
refB <- newIORef 0
_ <-
runEff . runTime . runCacheRedis cache . runCountingLLM refB stubResponse . cachedLLM $
complete fixModel fixCtx fixOpts
nB <- readIORef refB
nB @?= 0,
testCase "a closed connection degrades to MISS / no-op" $ do
let key = cacheKey fixModel fixCtx (fixOpts & #temperature .~ Just 0.2)
clearKeyFor ci key
closed <- openRedisCache ci
closeRedisCache closed
got <- runEff . runCacheRedis closed $ lookupCache key
got @?= Nothing
runEff . runCacheRedis closed $
storeCache key entry,
testCase "storage TTL knob: opt-in SETEX vs default no-expiry" $ do
let key = cacheKey fixModel fixCtx (fixOpts & #temperature .~ Just 0.3)
clearKeyFor ci key
ttlCache <- openRedisCacheWithTTL 60 ci
runEff . runCacheRedis ttlCache $
storeCache key entry
ttlWithExpiry <- redisTTL ci key
closeRedisCache ttlCache
case ttlWithExpiry of
Right seconds -> assertBool ("SETEX should leave a positive TTL, got " <> show seconds) (seconds > 0)
Left err -> fail ("TTL lookup failed after SETEX: " <> show err)
clearKeyFor ci key
defaultCache <- openRedisCache ci
runEff . runCacheRedis defaultCache $
storeCache key entry
ttlNoExpiry <- redisTTL ci key
closeRedisCache defaultCache
ttlNoExpiry @?= Right (-1)
]
redisTTL :: R.ConnectInfo -> CacheKey -> IO (Either R.Reply Integer)
redisTTL ci key = do
conn <- R.checkedConnect ci
result <- R.runRedis conn (R.ttl (redisKeyFor key))
R.disconnect conn
pure result