-- | 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, emptyContext, emptyModel, emptyOptions, emptyResponse, user)
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 Effectful.Error.Static (runErrorNoCallStack)
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.Error (ShikumiError (..))
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 = emptyModel & #modelId .~ "claude-sonnet-4-6" & #provider .~ "anthropic"
fixCtx :: Context
fixCtx = emptyContext & #systemPrompt .~ Just "You are helpful." & #messages .~ V.singleton (user "ping")
fixOpts :: Options
fixOpts = emptyOptions & #temperature .~ Just 0.0 & #maxTokens .~ Just 1024
stubResponse :: Response
stubResponse = emptyResponse
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
Right (r1, r2) <-
runEff . runErrorNoCallStack @ShikumiError . 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 . runErrorNoCallStack @ShikumiError . 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