CacheSpec.hs

module Unit.Atelier.Effects.CacheSpec (spec_Cache) where

import Data.Time (UTCTime (..), addUTCTime, fromGregorian)
import Data.Time.Clock (NominalDiffTime)
import Effectful (runEff)
import Effectful.Concurrent (runConcurrent)
import Effectful.Reader.Static (runReader)
import Effectful.State.Static.Shared (evalState, modify)
import Hedgehog (forAll, (===))
import Test.Hspec (Spec, describe, it, shouldBe)
import Test.Hspec.Hedgehog (hedgehog)

import Effectful.Concurrent.STM qualified as STM
import Hedgehog.Gen qualified as Gen
import Hedgehog.Range qualified as Range

import Atelier.Effects.Cache
    ( Config (..)
    , cacheDelete
    , cacheInsert
    , cacheLookup
    , cacheModify
    , runCacheTtlWithWait
    )
import Atelier.Effects.Clock (runClockState)
import Atelier.Effects.Conc (runConc)
import Atelier.Effects.Delay (runDelay)
import Atelier.Effects.Log (runLogNoOp)


spec_Cache :: Spec
spec_Cache = do
    describe "Basic Operations" do
        it "lookup on absent key returns Nothing" do
            result <- runCacheTest $ cacheLookup 1
            result `shouldBe` Nothing

        it "lookup after insert returns Just value" do
            result <- runCacheTest do
                cacheInsert 1 42
                cacheLookup 1
            result `shouldBe` Just 42

        it "lookup after delete returns Nothing" do
            result <- runCacheTest $ do
                cacheInsert 1 42
                cacheDelete 1
                cacheLookup 1
            result `shouldBe` Nothing

        it "insert twice updates value" do
            result <- runCacheTest $ do
                cacheInsert 1 42
                cacheInsert 1 99
                cacheLookup 1
            result `shouldBe` Just 99

        it "delete on absent key is a no-op" do
            result <- runCacheTest $ do
                cacheDelete 1
                cacheLookup 1
            result `shouldBe` Nothing

    describe "Modify" do
        it "modify on absent key uses Nothing branch" do
            result <- runCacheTest $ cacheModify @Int @Int 1 (maybe 0 (+ 1))
            result `shouldBe` 0

        it "modify on present key uses Just branch" do
            result <- runCacheTest $ do
                cacheInsert 1 10
                cacheModify 1 (maybe 0 (+ 1))
            result `shouldBe` 11

        it "modify returns the new value" do
            result <- runCacheTest $ do
                _ <- cacheModify 1 (maybe 5 (+ 5))
                cacheModify 1 (maybe 5 (+ 5))
            result `shouldBe` 10

    describe "TTL Eviction" do
        it "entry is present before TTL expires" do
            result <- runBase . runCacheTestWithWait (STM.atomically STM.retry) $ do
                cacheInsert 1 42
                cacheLookup 1
            result `shouldBe` Just 42

        it "entry is evicted after cleanup thread fires past TTL" do
            result <- runBase do
                trigger <- STM.atomically STM.newEmptyTMVar
                done <- STM.atomically STM.newEmptyTMVar
                runCacheTestWithWait (cleanupBarrier done trigger) do
                    awaitReady done
                    cacheInsert 1 42
                    v1 <- cacheLookup 1
                    modify (addUTCTime (ttl + 1))
                    stepCleanup trigger done -- run one cleanup, block until it finishes
                    v2 <- cacheLookup 1
                    pure (v1, v2)
            result `shouldBe` (Just 42, Nothing)

        it "entry within TTL survives cleanup" do
            result <- runBase do
                trigger <- STM.atomically STM.newEmptyTMVar
                done <- STM.atomically STM.newEmptyTMVar
                runCacheTestWithWait (cleanupBarrier done trigger) do
                    awaitReady done
                    cacheInsert 1 42
                    modify (addUTCTime (ttl - 1))
                    stepCleanup trigger done
                    cacheLookup 1
            result `shouldBe` Just 42

        it "re-inserted entry retains original TTL window" do
            result <- runBase do
                trigger <- STM.atomically STM.newEmptyTMVar
                done <- STM.atomically STM.newEmptyTMVar
                runCacheTestWithWait (cleanupBarrier done trigger) do
                    awaitReady done
                    cacheInsert 1 42
                    v1 <- cacheLookup 1

                    -- re-insert before TTL expires: updates value but preserves createdAt = t0
                    modify (addUTCTime (ttl - 1))
                    stepCleanup trigger done
                    cacheInsert 1 99
                    v2 <- cacheLookup 1

                    -- advance clock past original TTL
                    modify (addUTCTime 2)
                    stepCleanup trigger done
                    v3 <- cacheLookup 1

                    pure (v1, v2, v3)
            -- createdAt was preserved from the first insert, so the entry is expired and evicted
            result `shouldBe` (Just 42, Just 99, Nothing)

    describe "Properties" do
        it "insert then lookup roundtrips value" $ hedgehog do
            v <- forAll $ Gen.int (Range.linear 0 1000)
            result <- liftIO $ runCacheTest $ do
                cacheInsert 1 v
                cacheLookup 1
            result === Just v

        it "distinct keys have independent values" $ hedgehog do
            m <- forAll $ Gen.int (Range.linear 1 20)
            n <- forAll $ Gen.int (Range.linear 1 20)
            (a, b) <- liftIO $ runCacheTest $ do
                cacheInsert 1 m
                cacheInsert 2 n
                va <- cacheLookup 1
                vb <- cacheLookup 2
                pure (va, vb)
            a === Just m
            b === Just n

        it "interleaved key access is independent" $ hedgehog do
            keys <- forAll $ Gen.list (Range.linear 1 50) Gen.bool
            -- count inserts per key by interleaving
            counts <- liftIO $ runCacheTest $ do
                let step True = cacheModify @Int 1 (maybe 1 (+ 1))
                    step False = cacheModify @Int 2 (maybe 1 (+ 1))
                traverse step keys
            let key1Counts = [c | (k, c) <- zip keys counts, k]
                key2Counts = [c | (k, c) <- zip keys counts, not k]
            key1Counts === [1 .. length key1Counts]
            key2Counts === [1 .. length key2Counts]

        it "concurrent inserts to different keys don't interfere" $ hedgehog do
            n <- forAll $ Gen.int (Range.linear 1 20)
            results <- liftIO $ runCacheTest $ do
                for_ [1 .. n] \i -> cacheInsert i i
                traverse (\i -> cacheLookup i) [1 .. n]
            results === map (Just . id) [1 .. n]

        it "modify is atomic under concurrency" $ hedgehog do
            n <- forAll $ Gen.int (Range.linear 1 50)
            finalVal <- liftIO $ runCacheTest $ do
                for_ [1 .. n] \_ -> cacheModify 1 (maybe 1 (+ 1))
                cacheLookup 1
            finalVal === Just n
  where
    runBase = runEff . runConcurrent
    runCacheTest = runBase . runCacheTestWithWait (STM.atomically STM.retry)
    runCacheTestWithWait wait =
        runLogNoOp
            . runConc
            . runDelay
            . evalState epoch
            . runClockState
            . runReader (Config {entryTtl = ttl, cleanupInterval = 3600})
            . runCacheTtlWithWait @Int @Int wait
    epoch = UTCTime (fromGregorian 1970 1 1) 0
    ttl = 3600 :: NominalDiffTime

    -- Deterministic control over the background cleanup thread, replacing
    -- real-time 'Delay.wait' guesses with a handshake. The thread runs its
    -- injected wait ('cleanupBarrier') once per loop: it acknowledges that the
    -- previous cycle finished (via 'done'), then blocks for the next trigger.
    -- 'stepCleanup' triggers one cycle and blocks until that cycle's eviction has
    -- completed, so look-ups afterwards observe a settled state.
    cleanupBarrier done trigger =
        STM.atomically (STM.putTMVar done ()) >> STM.atomically (STM.takeTMVar trigger)
    awaitReady done = STM.atomically (STM.takeTMVar done)
    stepCleanup trigger done =
        STM.atomically (STM.putTMVar trigger ()) >> STM.atomically (STM.takeTMVar done)