pg-wire 0.1.0.0 → 0.2.0.0
raw patch · 9 files changed
+1177/−27 lines, 9 filesdep +criteriondep −psqueuesdep ~bytestringdep ~containersdep ~deepseqPVP ok
version bump matches the API change (PVP)
Dependencies added: criterion
Dependencies removed: psqueues
Dependency ranges changed: bytestring, containers, deepseq
API changes (from Hackage documentation)
Files
- CHANGELOG.md +24/−0
- bench/Main.hs +131/−0
- pg-wire.cabal +25/−2
- src/PgWire/Cache/Sieve.hs +252/−0
- src/PgWire/Connection.hs +9/−12
- src/PgWire/Error.hs +43/−1
- src/PgWire/Pool.hs +34/−12
- test/Main.hs +2/−0
- test/PgWire/Cache/SieveSpec.hs +657/−0
CHANGELOG.md view
@@ -3,6 +3,29 @@ The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.1.0/), and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html). +## [0.2.0.0] - 2026-04-29++### Changed (breaking)++- Replaced the per-connection prepared-statement cache with SIEVE+ ([NSDI'24](https://www.usenix.org/conference/nsdi24/presentation/zhang-yazhuo)).+ In standalone microbenchmarks, SIEVE is 2.3-3.8x faster than the previous+ HashPSQ-based LRU across fill, hit-only, mixed, eviction-storm,+ uniform-random, and Zipf-skewed workloads.+- `Connection` record fields changed: `connStmtCache` is now+ `SieveCache ByteString ByteString` (was+ `IORef (HashPSQ ByteString Word64 ByteString)`), and `connStmtTick`+ was removed (SIEVE doesn't need a monotonic tick).++### Added++- `PgWire.Cache.Sieve.clear`, `capacity`, and `foldEntries` for managing+ and inspecting the per-connection cache.++### Removed++- `psqueues` dependency.+ ## [0.1.0.0] - 2026-04-25 Initial release. Pure-Haskell implementation of the PostgreSQL v3 wire@@ -22,4 +45,5 @@ [`valiant`](https://hackage.haskell.org/package/valiant) runtime. - Nine structured error types with column-by-column diagnostics. +[0.2.0.0]: https://github.com/joshburgess/valiant/releases/tag/pg-wire-v0.2.0.0 [0.1.0.0]: https://github.com/joshburgess/valiant/releases/tag/v0.1.0.0
+ bench/Main.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Microbenchmarks for the SIEVE-based prepared-statement cache+-- ('PgWire.Cache.Sieve'), used per-connection by 'Valiant.Execute' and+-- 'PgWire.Connection'.+module Main where++import Prelude hiding (lookup)++import Control.DeepSeq (NFData (..))+import Control.Monad (forM_, void)+import Criterion.Main+import Data.ByteString (ByteString)+import Data.ByteString.Char8 qualified as BS+import PgWire.Cache.Sieve (SieveCache, insert, lookup, newSieveCache)+import System.Random (mkStdGen, randomR)++-- 'SieveCache' is IORef-backed; for criterion's 'env' we just need a+-- handle that survives 'evaluate'. Forcing the IORefs would mutate+-- nothing useful, so we treat them as opaque.+instance NFData (SieveCache k v) where+ rnf _ = ()++------------------------------------------------------------------------+-- Workload generators+------------------------------------------------------------------------++mkKey :: Int -> ByteString+mkKey i = BS.pack (replicate (10 - length s) '0' ++ s)+ where s = show i++sequentialKeys :: Int -> [ByteString]+sequentialKeys n = map mkKey [0 .. n - 1]++uniformKeys :: Int -> Int -> [ByteString]+uniformKeys maxKey n = take n (go (mkStdGen 0xCAFE))+ where+ go g = let (k, g') = randomR (0, maxKey - 1) g in mkKey k : go g'++zipfKeys :: Int -> Int -> [ByteString]+zipfKeys maxKey n =+ let !table = zipfCdf maxKey 1.0+ in take n (go (mkStdGen 0xBEEF) table)+ where+ go g table =+ let (u, g') = randomR (0.0 :: Double, 1.0) g+ k = invertCdf table u+ in mkKey k : go g' table++zipfCdf :: Int -> Double -> [(Int, Double)]+zipfCdf maxKey s =+ let weights = [(i, 1 / fromIntegral i ** s) | i <- [1 .. maxKey]]+ total = sum (map snd weights)+ in scanl1 acc [(i, w / total) | (i, w) <- weights]+ where+ acc (_, c) (i, w) = (i, c + w)++invertCdf :: [(Int, Double)] -> Double -> Int+invertCdf [] _ = 0+invertCdf [(i, _)] _ = i+invertCdf ((i, c) : rest) u+ | u <= c = i+ | otherwise = invertCdf rest u++------------------------------------------------------------------------+-- Cache drivers+------------------------------------------------------------------------++runSieveInserts :: Int -> [ByteString] -> IO ()+runSieveInserts cap ks = do+ sc <- newSieveCache @ByteString @ByteString cap+ forM_ ks $ \k -> void (insert sc k k)++runSieveLookups :: SieveCache ByteString ByteString -> [ByteString] -> IO ()+runSieveLookups sc ks = forM_ ks (\k -> void (lookup sc k))++runSieveMixed :: Int -> [ByteString] -> IO ()+runSieveMixed cap ks = do+ sc <- newSieveCache @ByteString @ByteString cap+ forM_ ks $ \k -> do+ m <- lookup sc k+ case m of+ Just _ -> pure ()+ Nothing -> void (insert sc k k)++warmSieve :: Int -> [ByteString] -> IO (SieveCache ByteString ByteString)+warmSieve cap ks = do+ sc <- newSieveCache @ByteString @ByteString cap+ forM_ ks (\k -> void (insert sc k k))+ pure sc++------------------------------------------------------------------------+-- Workloads+------------------------------------------------------------------------++defaultCap :: Int+defaultCap = 100++opsCount :: Int+opsCount = 2000++main :: IO ()+main = do+ let !keysFill = sequentialKeys (defaultCap `div` 2)+ !keysFull = sequentialKeys defaultCap+ !keysSeq2x = sequentialKeys (defaultCap * 2)+ !keysHit = take opsCount (cycle keysFull)+ !keysSweep = take opsCount (cycle keysSeq2x)+ !keysMixed = take opsCount (cycle keysFull)+ !keysZipf = zipfKeys (defaultCap * 4) opsCount+ !keysUniform4x = uniformKeys (defaultCap * 4) opsCount++ defaultMain+ [ bench "fill (under capacity, no evictions)" $+ whnfIO (runSieveInserts defaultCap keysFill)+ , bench "fill (exactly to capacity)" $+ whnfIO (runSieveInserts defaultCap keysFull)+ , env (warmSieve defaultCap keysFull) $ \sc ->+ bench "hit-only (warm cache, all lookups hit)" $+ whnfIO (runSieveLookups sc keysHit)+ , bench "mixed lookup/insert (working set = cap, all hit after warmup)" $+ whnfIO (runSieveMixed defaultCap keysMixed)+ , bench "eviction storm (sequential, working set 2x cap)" $+ whnfIO (runSieveMixed defaultCap keysSweep)+ , bench "uniform random access (working set 4x cap)" $+ whnfIO (runSieveMixed defaultCap keysUniform4x)+ , bench "Zipf-skewed access (working set 4x cap, s=1.0)" $+ whnfIO (runSieveMixed defaultCap keysZipf)+ ]
pg-wire.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: pg-wire-version: 0.1.0.0+version: 0.2.0.0 synopsis: Pure Haskell PostgreSQL wire protocol driver description: A complete implementation of the PostgreSQL v3 wire protocol in@@ -53,6 +53,7 @@ PgWire.Auth.MD5 PgWire.Auth.ScramSHA256 PgWire.Binary.Types+ PgWire.Cache.Sieve PgWire.Cancel PgWire.Connection PgWire.Connection.Config@@ -96,7 +97,6 @@ , directory >=1.3 && <1.4 , hashable >=1.4 && <1.6 , nothunks >=0.1 && <0.3- , psqueues >=0.2.8 && <0.3 , random >=1.2 && <1.4 -- Concurrency / pool@@ -136,6 +136,7 @@ other-modules: PgWire.Auth.MD5Spec PgWire.Auth.ScramFieldsSpec+ PgWire.Cache.SieveSpec PgWire.CancelSpec PgWire.Connection.ConfigSpec PgWire.Connection.EscapingSpec@@ -156,6 +157,7 @@ , async >=2.2 && <2.3 , base >=4.17 && <5 , bytestring+ , containers , crypton , deepseq , hedgehog >=1.2 && <1.6@@ -166,3 +168,24 @@ , pg-wire , pg-wire:mockserver , vector++-- Pure microbenchmarks for the SIEVE-based prepared-statement cache+-- ('PgWire.Cache.Sieve'), used per-connection by 'Valiant.Execute' and+-- 'PgWire.Connection'.+-- Run with: cabal bench pg-wire-cache-bench+benchmark pg-wire-cache-bench+ import: warnings+ type: exitcode-stdio-1.0+ hs-source-dirs: bench+ main-is: Main.hs+ default-language: GHC2021+ default-extensions:+ OverloadedStrings+ build-depends:+ , base >=4.17 && <5+ , bytestring+ , criterion >=1.6 && <1.8+ , deepseq+ , pg-wire+ , random >=1.2 && <1.4+ ghc-options: -O2
+ src/PgWire/Cache/Sieve.hs view
@@ -0,0 +1,252 @@+-- | SIEVE cache eviction algorithm.+--+-- A simple, efficient eviction policy that outperforms FIFO and+-- approaches LRU quality with lower overhead. Based on the NSDI'24+-- paper "SIEVE is Simpler than LRU."+--+-- On cache hit: set a visited bit (no list mutation).+-- On eviction: sweep from hand pointer, skip visited entries (reset+-- their bit), evict the first unvisited entry.+--+-- This implementation uses IORef-based mutable linked list nodes,+-- suitable for single-threaded per-connection use.+module PgWire.Cache.Sieve+ ( SieveCache+ , newSieveCache+ , lookup+ , insert+ , delete+ , size+ , clear+ , capacity+ , foldEntries+ ) where++import Prelude hiding (lookup)+import Data.IORef+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map++-- | A SIEVE cache with keys @k@ and values @v@.+data SieveCache k v = SieveCache+ { scCapacity :: !Int+ , scSize :: !(IORef Int)+ , scMap :: !(IORef (Map k (Node k v)))+ , scHead :: !(IORef (Maybe (Node k v)))+ -- ^ Newest entry (insertion point).+ , scTail :: !(IORef (Maybe (Node k v)))+ -- ^ Oldest entry.+ , scHand :: !(IORef (Maybe (Node k v)))+ -- ^ Eviction sweep pointer. Starts at tail, moves toward head.+ }++-- | A node in the doubly-linked list.+data Node k v = Node+ { nodeKey :: !k+ , nodeVal :: !v+ , nodeVisited :: !(IORef Bool)+ , nodePrev :: !(IORef (Maybe (Node k v)))+ -- ^ Toward head (newer).+ , nodeNext :: !(IORef (Maybe (Node k v)))+ -- ^ Toward tail (older).+ }++-- | Create an empty SIEVE cache with the given capacity.+newSieveCache :: Int -> IO (SieveCache k v)+newSieveCache cap = do+ sz <- newIORef 0+ m <- newIORef Map.empty+ hd <- newIORef Nothing+ tl <- newIORef Nothing+ hand <- newIORef Nothing+ pure SieveCache+ { scCapacity = cap+ , scSize = sz+ , scMap = m+ , scHead = hd+ , scTail = tl+ , scHand = hand+ }++-- | Look up a key. On hit, marks the entry as visited.+lookup :: (Ord k) => SieveCache k v -> k -> IO (Maybe v)+lookup sc k = do+ m <- readIORef (scMap sc)+ case Map.lookup k m of+ Nothing -> pure Nothing+ Just node -> do+ writeIORef (nodeVisited node) True+ pure (Just (nodeVal node))++-- | Insert a key-value pair. If the cache is full, evicts an entry first.+-- If the key already exists, updates the value and marks as visited.+insert :: (Ord k) => SieveCache k v -> k -> v -> IO (Maybe (k, v))+ -- ^ Returns the evicted key and value, if any.+insert sc k v = do+ m <- readIORef (scMap sc)+ case Map.lookup k m of+ Just node -> do+ -- Key exists — update value and mark visited.+ deleteNode sc node+ insertFresh sc k v+ Nothing -> do+ sz <- readIORef (scSize sc)+ if sz >= scCapacity sc+ then do+ evicted <- evict sc+ insertNew sc k v+ pure evicted+ else do+ insertNew sc k v+ pure Nothing++-- | Delete a key from the cache.+delete :: (Ord k) => SieveCache k v -> k -> IO ()+delete sc k = do+ m <- readIORef (scMap sc)+ case Map.lookup k m of+ Nothing -> pure ()+ Just node -> deleteNode sc node++-- | Current number of entries.+size :: SieveCache k v -> IO Int+size sc = readIORef (scSize sc)++-- | The configured capacity of this cache.+capacity :: SieveCache k v -> Int+capacity = scCapacity++-- | Drop every entry. After 'clear', 'size' is 0 and the cache behaves+-- as if it had just been allocated.+clear :: SieveCache k v -> IO ()+clear sc = do+ writeIORef (scSize sc) 0+ writeIORef (scMap sc) Map.empty+ writeIORef (scHead sc) Nothing+ writeIORef (scTail sc) Nothing+ writeIORef (scHand sc) Nothing++-- | Walk every (key, value) pair currently in the cache. Order is+-- newest-first (insertion order at the head). Used by callers that+-- need to release server-side resources for cached entries on shutdown.+foldEntries :: SieveCache k v -> b -> (b -> k -> v -> IO b) -> IO b+foldEntries sc z f = do+ mHead <- readIORef (scHead sc)+ go z mHead+ where+ go acc Nothing = pure acc+ go acc (Just node) = do+ acc' <- f acc (nodeKey node) (nodeVal node)+ mNext <- readIORef (nodeNext node)+ go acc' mNext++------------------------------------------------------------------------+-- Internal+------------------------------------------------------------------------++-- | Insert a new entry at the head. Does NOT check capacity.+insertNew :: (Ord k) => SieveCache k v -> k -> v -> IO ()+insertNew sc k v = do+ visited <- newIORef False+ prev <- newIORef Nothing+ next <- newIORef Nothing+ let node = Node k v visited prev next++ mHead <- readIORef (scHead sc)+ case mHead of+ Nothing -> do+ -- Empty cache: node is both head and tail.+ writeIORef (scHead sc) (Just node)+ writeIORef (scTail sc) (Just node)+ writeIORef (scHand sc) (Just node)+ Just oldHead -> do+ -- Insert before old head.+ writeIORef (nodeNext node) (Just oldHead)+ writeIORef (nodePrev oldHead) (Just node)+ writeIORef (scHead sc) (Just node)++ modifyIORef' (scMap sc) (Map.insert k node)+ modifyIORef' (scSize sc) (+ 1)++-- | Insert fresh after a delete (for update). Returns Nothing.+insertFresh :: (Ord k) => SieveCache k v -> k -> v -> IO (Maybe (k, v))+insertFresh sc k v = do+ insertNew sc k v+ -- Mark as visited since it was just accessed.+ m <- readIORef (scMap sc)+ case Map.lookup k m of+ Just node -> writeIORef (nodeVisited node) True+ Nothing -> pure ()+ pure Nothing++-- | Remove a node from the linked list and map.+deleteNode :: (Ord k) => SieveCache k v -> Node k v -> IO ()+deleteNode sc node = do+ -- Fix hand pointer if it points to this node.+ mHand <- readIORef (scHand sc)+ case mHand of+ Just handNode | sameNode handNode node -> advanceHand sc node+ _ -> pure ()++ -- Unlink from doubly-linked list.+ mPrev <- readIORef (nodePrev node)+ mNext <- readIORef (nodeNext node)++ case mPrev of+ Just p -> writeIORef (nodeNext p) mNext+ Nothing -> writeIORef (scHead sc) mNext -- node was head++ case mNext of+ Just n -> writeIORef (nodePrev n) mPrev+ Nothing -> writeIORef (scTail sc) mPrev -- node was tail++ -- Remove from map and decrement size.+ modifyIORef' (scMap sc) (Map.delete (nodeKey node))+ modifyIORef' (scSize sc) (subtract 1)++-- | Evict one entry using the SIEVE sweep. Returns the evicted key and value.+evict :: (Ord k) => SieveCache k v -> IO (Maybe (k, v))+evict sc = do+ mHand <- readIORef (scHand sc)+ case mHand of+ Nothing -> pure Nothing+ Just startNode -> sweep sc startNode++-- | Sweep from the hand, skipping visited nodes (resetting their bit),+-- until finding an unvisited node to evict.+sweep :: (Ord k) => SieveCache k v -> Node k v -> IO (Maybe (k, v))+sweep sc node = do+ visited <- readIORef (nodeVisited node)+ if visited+ then do+ -- Give a second chance: reset visited bit, advance hand.+ writeIORef (nodeVisited node) False+ advanceHand sc node+ mNext <- readIORef (scHand sc)+ case mNext of+ Nothing -> pure Nothing -- should not happen+ Just nextNode -> sweep sc nextNode+ else do+ -- Evict this node.+ let k = nodeKey node+ v = nodeVal node+ advanceHand sc node+ deleteNode sc node+ pure (Just (k, v))++-- | Advance the hand pointer. Moves toward the tail (next pointer).+-- If at the tail, wraps to the head.+advanceHand :: SieveCache k v -> Node k v -> IO ()+advanceHand sc node = do+ mNext <- readIORef (nodeNext node)+ case mNext of+ Just n -> writeIORef (scHand sc) (Just n)+ Nothing -> do+ -- At tail, wrap to head.+ mHead <- readIORef (scHead sc)+ writeIORef (scHand sc) mHead++-- | Check if two nodes are the same (by IORef identity of visited).+sameNode :: Node k v -> Node k v -> Bool+sameNode a b = nodeVisited a == nodeVisited b+ -- IORef equality is pointer equality.
src/PgWire/Connection.hs view
@@ -65,14 +65,13 @@ import Data.ByteString (ByteString) import Data.ByteString.Char8 qualified as BS8 import Data.IORef-import Data.HashPSQ (HashPSQ)-import Data.HashPSQ qualified as PSQ import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Int (Int32) import Data.Vector qualified as V import Data.Vector (Vector) import Data.Word (Word32, Word64)+import PgWire.Cache.Sieve (SieveCache, newSieveCache) import PgWire.Async (AsyncWireConn (..), Request (..), Response (..), spawnAsyncWireConn, shutdownAsyncWireConn, submitRequest, submitExclusive) import PgWire.Auth.Cleartext (cleartextAuth) import PgWire.Auth.MD5 (md5Auth)@@ -95,13 +94,12 @@ , connConfig :: !ConnConfig , connBackendPid :: {-# UNPACK #-} !Int32 , connBackendKey :: {-# UNPACK #-} !Int32- , connStmtCache :: !(IORef (HashPSQ ByteString Word64 ByteString))- -- ^ LRU prepared statement cache. Keys are SQL text, priorities are- -- monotonic access ticks (lower = least recently used), values are- -- server-side statement names.+ , connStmtCache :: !(SieveCache ByteString ByteString)+ -- ^ Prepared statement cache (SIEVE eviction). Keys are SQL text,+ -- values are server-side statement names. Eviction is driven by+ -- per-entry visited bits and a sweep hand; lookups are O(1) and+ -- mutate only the visited bit, not the linked list. , connStmtCounter :: !(IORef Word64)- , connStmtTick :: !(IORef Word64)- -- ^ Monotonic tick counter for LRU cache priorities. , connSslActive :: !Bool , connPreparedStatements :: !Bool -- ^ Whether to use named prepared statements (default: True).@@ -281,9 +279,9 @@ pid <- readIORef pidRef key <- readIORef keyRef- stmtCache <- newIORef PSQ.empty+ let !cap = max 1 (ccMaxPreparedStatements cfg)+ stmtCache <- newSieveCache cap stmtCounter <- newIORef 0- stmtTick <- newIORef 0 let sslActive = case ccTls cfg of TlsDisable -> False _ -> True@@ -299,10 +297,9 @@ , connBackendKey = key , connStmtCache = stmtCache , connStmtCounter = stmtCounter- , connStmtTick = stmtTick , connSslActive = sslActive , connPreparedStatements = ccPreparedStatements cfg- , connMaxPreparedStatements = max 1 (ccMaxPreparedStatements cfg)+ , connMaxPreparedStatements = cap } -- | Connect using a connection string.
src/PgWire/Error.hs view
@@ -5,13 +5,15 @@ module PgWire.Error ( PgWireError (..) , throwPgWire+ , isFatal ) where import Control.Exception (Exception, throwIO) import Data.ByteString (ByteString)+import Data.ByteString qualified as BS import GHC.Generics (Generic) import NoThunks.Class (NoThunks)-import PgWire.Protocol.Backend (PgError)+import PgWire.Protocol.Backend (PgError (..)) -- | All runtime errors thrown by pg-wire. data PgWireError@@ -42,3 +44,43 @@ -- | Throw a 'PgWireError' as an exception. throwPgWire :: PgWireError -> IO a throwPgWire = throwIO++-- | Classify whether an error indicates the connection is unusable.+--+-- Fatal errors mean the connection should be destroyed rather than returned+-- to the pool. Recoverable errors (constraint violations, syntax errors,+-- serialization failures) leave the connection in a usable state.+--+-- Fatal error classes:+--+-- * 'ConnectionError', 'AuthError', 'ProtocolError', 'ConnectionDead' —+-- always fatal.+-- * SQLSTATE class @08@ — connection exception (server closed it).+-- * SQLSTATE class @57@ — operator intervention (admin shutdown, crash recovery).+-- * SQLSTATE class @58@ — system error (I\/O error, out of memory on server).+-- * SQLSTATE @F0000@ — configuration file error.+-- * SQLSTATE @XX000@ — internal error (server bug).+--+-- Everything else (constraint violations, query errors, transaction errors,+-- syntax errors, etc.) is recoverable.+isFatal :: PgWireError -> Bool+isFatal ConnectionError{} = True+isFatal AuthError{} = True+isFatal ProtocolError{} = True+isFatal ConnectionDead{} = True+isFatal PoolTimeout{} = False+isFatal PoolClosed{} = False+isFatal DecodeError{} = False+isFatal (QueryError err) = isFatalState (pgCode err)++-- | Check if a SQLSTATE code indicates a fatal error.+isFatalState :: ByteString -> Bool+isFatalState code+ | BS.length code >= 2 =+ let cls = BS.take 2 code+ in cls == "08" -- connection exception+ || cls == "57" -- operator intervention+ || cls == "58" -- system error+ || code == "F0000" -- configuration file error+ || code == "XX000" -- internal error+ | otherwise = False
src/PgWire/Pool.hs view
@@ -36,7 +36,7 @@ import Control.Concurrent (threadDelay) import Control.Concurrent.Async (Async, async, cancel, race) import Control.Concurrent.STM-import Control.Exception (AsyncException, SomeException, catch, mask, onException, throwIO, try)+import Control.Exception (AsyncException, SomeException, catch, fromException, mask, onException, throwIO, try) import Data.ByteString.Char8 qualified as BS8 import Data.IORef import Data.Int (Int32)@@ -45,10 +45,10 @@ import Data.Sequence (Seq (..)) import Data.Sequence qualified as Seq import Data.Time (NominalDiffTime, UTCTime, addUTCTime, diffUTCTime, getCurrentTime)-import Data.HashPSQ qualified as PSQ import PgWire.Async (AsyncWireConn (..))+import PgWire.Cache.Sieve qualified as Sieve import PgWire.Connection (Connection (..), close, connectString, simpleQuery)-import PgWire.Error (PgWireError (..), throwPgWire)+import PgWire.Error (PgWireError (..), isFatal, throwPgWire) import PgWire.Pool.Config (PoolConfig (..), QueueMode (..), RecyclingMethod (..)) import PgWire.Pool.Observation (PoolEvent (ConnectionAcquired, ConnectionCreated, ConnectionDestroyed, ConnectionRecycled, ConnectionReleased, HealthCheckFailed, AcquireTimeout, ReaperSwept, WarmerCreated, PoolResized, PoolShutdown)) import PgWire.TypeCache (TypeCache, newTypeCache)@@ -279,10 +279,23 @@ conn <- acquire pool t1 <- getCurrentTime observe pool (ConnectionAcquired (diffUTCTime t1 t0))- result <- restore (action conn) `onException` destroyConn pool conn "exception"- release pool conn- observe pool ConnectionReleased- pure result+ result <- try (restore (action conn))+ case result of+ Right val -> do+ release pool conn+ observe pool ConnectionReleased+ pure val+ Left ex -> do+ -- Recoverable PgWire errors (constraint violations, syntax errors,+ -- serialization failures) leave the connection healthy: return it+ -- to the pool. Anything else (fatal PgWireError, async exceptions,+ -- user IOExceptions) destroys the connection.+ case fromException ex of+ Just pgErr | not (isFatal pgErr) -> do+ release pool conn+ observe pool ConnectionReleased+ _ -> destroyConn pool conn "exception"+ throwIO (ex :: SomeException) -- | Like 'withResource' but with a custom acquire timeout. --@@ -301,10 +314,19 @@ conn <- acquireWithTimeout pool timeout t1 <- getCurrentTime observe pool (ConnectionAcquired (diffUTCTime t1 t0))- result <- restore (action conn) `onException` destroyConn pool conn "exception"- release pool conn- observe pool ConnectionReleased- pure result+ result <- try (restore (action conn))+ case result of+ Right val -> do+ release pool conn+ observe pool ConnectionReleased+ pure val+ Left ex -> do+ case fromException ex of+ Just pgErr | not (isFatal pgErr) -> do+ release pool conn+ observe pool ConnectionReleased+ _ -> destroyConn pool conn "exception"+ throwIO (ex :: SomeException) -- | Get an atomic snapshot of the pool's current statistics. --@@ -512,7 +534,7 @@ Right (Right _) -> do -- DISCARD ALL deallocates all prepared statements on the server, -- so the client-side cache must be cleared to stay in sync.- writeIORef (connStmtCache (peConn entry)) PSQ.empty+ Sieve.clear (connStmtCache (peConn entry)) pure True _ -> pure False
test/Main.hs view
@@ -2,6 +2,7 @@ import PgWire.Auth.MD5Spec qualified as MD5Spec import PgWire.Auth.ScramFieldsSpec qualified as ScramFieldsSpec+import PgWire.Cache.SieveSpec qualified as SieveSpec import PgWire.CancelSpec qualified as CancelSpec import PgWire.Connection.ConfigSpec qualified as ConfigSpec import PgWire.ErrorSpec qualified as ErrorSpec@@ -29,6 +30,7 @@ describe "PgWire.Error" ErrorSpec.spec describe "PgWire.Auth.MD5" MD5Spec.spec describe "PgWire.Auth.ScramFields" ScramFieldsSpec.spec+ describe "PgWire.Cache.Sieve" SieveSpec.spec describe "PgWire.Cancel" CancelSpec.spec describe "PgWire.Connection.Features" FeaturesSpec.spec describe "PgWire.Connection.Escaping" EscapingSpec.spec
+ test/PgWire/Cache/SieveSpec.hs view
@@ -0,0 +1,657 @@+{-# LANGUAGE LambdaCase #-}++module PgWire.Cache.SieveSpec (spec) where++import Prelude hiding (lookup)++import Control.Monad (foldM, forM_, when)+import Data.IORef+import Data.List (nub)+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Hedgehog+import Hedgehog.Gen qualified as Gen+import Hedgehog.Range qualified as Range+import PgWire.Cache.Sieve (SieveCache, capacity, clear, delete, foldEntries, insert, lookup, newSieveCache, size)+import Test.Hspec+import Test.Hspec.Hedgehog (hedgehog)++------------------------------------------------------------------------+-- Reference model+------------------------------------------------------------------------++-- | Pure model of the SIEVE cache's externally-observable state.+--+-- We do not model SIEVE's eviction order: it's an implementation+-- detail driven by the hand pointer and the visited bits. Instead,+-- when an insert evicts, we accept whatever key SIEVE chose and+-- reflect that in the model.+data Model k v = Model+ { mCap :: !Int+ , mMap :: !(Map k v)+ } deriving (Show)++newModel :: Int -> Model k v+newModel cap = Model cap Map.empty++modelSize :: Model k v -> Int+modelSize = Map.size . mMap++modelLookup :: (Ord k) => k -> Model k v -> Maybe v+modelLookup k = Map.lookup k . mMap++-- | Apply an insert in the model, given what SIEVE reported as evicted.+modelInsert :: (Ord k) => k -> v -> Maybe (k, v) -> Model k v -> Model k v+modelInsert k v evicted m =+ let m' = case evicted of+ Nothing -> m+ Just (ek, _) -> m { mMap = Map.delete ek (mMap m) }+ in m' { mMap = Map.insert k v (mMap m') }++modelDelete :: (Ord k) => k -> Model k v -> Model k v+modelDelete k m = m { mMap = Map.delete k (mMap m) }++------------------------------------------------------------------------+-- Operation generators+------------------------------------------------------------------------++data Op k v+ = OpInsert !k !v+ | OpLookup !k+ | OpDelete !k+ deriving (Show)++-- | Generate ops drawn from a small key universe so that hits, evictions,+-- and updates all exercise the cache. Operation mix is intentionally+-- skewed toward insert/lookup since that's the prepared-statement workload.+genOp :: Range.Range Int -> Gen (Op Int Int)+genOp keyRange = Gen.frequency+ [ (5, OpInsert <$> Gen.int keyRange <*> Gen.int (Range.linear 0 1000))+ , (4, OpLookup <$> Gen.int keyRange)+ , (1, OpDelete <$> Gen.int keyRange)+ ]++------------------------------------------------------------------------+-- spec+------------------------------------------------------------------------++spec :: Spec+spec = do+ -- Original unit tests, preserved.+ describe "basic operations" $ do+ it "empty cache has size 0" $ do+ sc <- newSieveCache @Int @Int 10+ sz <- size sc+ sz `shouldBe` 0++ it "insert increases size" $ do+ sc <- newSieveCache @Int @String 5+ _ <- insert sc 1 "a"+ sz <- size sc+ sz `shouldBe` 1++ it "lookup finds inserted entry" $ do+ sc <- newSieveCache @Int @String 5+ _ <- insert sc 1 "hello"+ val <- lookup sc 1+ val `shouldBe` Just "hello"++ it "lookup returns Nothing for missing key" $ do+ sc <- newSieveCache @Int @String 5+ _ <- insert sc 1 "hello"+ val <- lookup sc 2+ val `shouldBe` Nothing++ it "delete removes entry" $ do+ sc <- newSieveCache @Int @String 5+ _ <- insert sc 1 "hello"+ delete sc 1+ val <- lookup sc 1+ val `shouldBe` Nothing+ sz <- size sc+ sz `shouldBe` 0++ it "delete on missing key is a no-op" $ do+ sc <- newSieveCache @Int @String 5+ _ <- insert sc 1 "hello"+ delete sc 99+ sz <- size sc+ sz `shouldBe` 1++ it "insert returns Nothing when under capacity" $ do+ sc <- newSieveCache @Int @String 5+ evicted <- insert sc 1 "a"+ evicted `shouldBe` Nothing++ it "update existing key returns Nothing (no eviction)" $ do+ sc <- newSieveCache @Int @String 5+ _ <- insert sc 1 "a"+ evicted <- insert sc 1 "b"+ evicted `shouldBe` Nothing+ val <- lookup sc 1+ val `shouldBe` Just "b"++ describe "eviction" $ do+ it "evicts when at capacity" $ do+ sc <- newSieveCache @Int @String 2+ _ <- insert sc 1 "a"+ _ <- insert sc 2 "b"+ evicted <- insert sc 3 "c"+ case evicted of+ Nothing -> expectationFailure "expected an eviction"+ Just (k, _) -> k `shouldSatisfy` (`elem` [1, 2])+ sz <- size sc+ sz `shouldBe` 2++ it "size never exceeds capacity (deterministic)" $ do+ sc <- newSieveCache @Int @String 3+ mapM_ (\i -> insert sc i (show i)) [1..10 :: Int]+ sz <- size sc+ sz `shouldBe` 3++ it "visited entries survive eviction (second chance)" $ do+ sc <- newSieveCache @Int @String 2+ _ <- insert sc 1 "a"+ _ <- insert sc 2 "b"+ _ <- lookup sc 1+ evicted <- insert sc 3 "c"+ evicted `shouldBe` Just (2, "b")+ val <- lookup sc 1+ val `shouldBe` Just "a"++ it "evicts after all visited bits are reset" $ do+ sc <- newSieveCache @Int @String 2+ _ <- insert sc 1 "a"+ _ <- insert sc 2 "b"+ _ <- lookup sc 1+ _ <- lookup sc 2+ evicted <- insert sc 3 "c"+ case evicted of+ Nothing -> expectationFailure "expected an eviction"+ Just (k, _) -> k `shouldSatisfy` (`elem` [1, 2])+ sz <- size sc+ sz `shouldBe` 2++ it "capacity-1 cache evicts on every insert" $ do+ sc <- newSieveCache @Int @String 1+ _ <- insert sc 1 "a"+ evicted <- insert sc 2 "b"+ evicted `shouldBe` Just (1, "a")+ val <- lookup sc 1+ val `shouldBe` Nothing+ val2 <- lookup sc 2+ val2 `shouldBe` Just "b"++ describe "structural invariants (Hedgehog)" $ do+ it "size never exceeds capacity under arbitrary inserts" $ hedgehog $ do+ cap <- forAll (Gen.int (Range.linear 1 50))+ ops <- forAll (Gen.list (Range.linear 0 200) (Gen.int (Range.linear 0 100)))+ sz <- evalIO $ do+ sc <- newSieveCache @Int @Int cap+ mapM_ (\k -> insert sc k k) ops+ size sc+ assert (sz <= cap)++ it "size is non-negative under arbitrary mixed ops" $ hedgehog $ do+ cap <- forAll (Gen.int (Range.linear 1 30))+ ops <- forAll (Gen.list (Range.linear 0 150) (genOp (Range.linear 0 50)))+ sz <- evalIO $ do+ sc <- newSieveCache @Int @Int cap+ forM_ ops (runOp sc)+ size sc+ assert (sz >= 0)+ assert (sz <= cap)++ it "internal lookup count matches reported size" $ hedgehog $ do+ -- After arbitrary ops, the number of keys (drawn from a known+ -- universe) that lookup says are present must equal the reported size.+ cap <- forAll (Gen.int (Range.linear 1 20))+ let universe = [0 .. 30 :: Int]+ ops <- forAll (Gen.list (Range.linear 0 100) (genOp (Range.linear 0 30)))+ (sz, hits) <- evalIO $ do+ sc <- newSieveCache @Int @Int cap+ forM_ ops (runOp sc)+ s <- size sc+ h <- length . filter (== True) <$>+ mapM (\k -> (\m -> case m of Just _ -> True; Nothing -> False) <$> lookup sc k) universe+ pure (s, h)+ sz === hits++ it "size matches number of distinct keys when capacity is unbounded" $ hedgehog $ do+ keys <- forAll (Gen.list (Range.linear 0 20) (Gen.int (Range.linear 0 50)))+ sz <- evalIO $ do+ sc <- newSieveCache @Int @Int 1000+ mapM_ (\k -> insert sc k k) keys+ size sc+ sz === length (nub keys)++ it "all lookups after full population return Just" $ hedgehog $ do+ cap <- forAll (Gen.int (Range.linear 1 20))+ let keys = [0 .. cap - 1]+ results <- evalIO $ do+ sc <- newSieveCache @Int @Int cap+ mapM_ (\k -> insert sc k (k * 10)) keys+ mapM (lookup sc) keys+ results === map (\k -> Just (k * 10)) keys++ describe "membership semantics (Hedgehog)" $ do+ it "insert immediately makes the key findable" $ hedgehog $ do+ cap <- forAll (Gen.int (Range.linear 1 50))+ k <- forAll (Gen.int (Range.linear 0 100))+ v <- forAll (Gen.int (Range.linear 0 1000))+ val <- evalIO $ do+ sc <- newSieveCache @Int @Int cap+ _ <- insert sc k v+ lookup sc k+ val === Just v++ it "delete makes a present key absent" $ hedgehog $ do+ cap <- forAll (Gen.int (Range.linear 1 50))+ k <- forAll (Gen.int (Range.linear 0 100))+ val <- evalIO $ do+ sc <- newSieveCache @Int @Int cap+ _ <- insert sc k 42+ delete sc k+ lookup sc k+ val === Nothing++ it "double delete is idempotent" $ hedgehog $ do+ cap <- forAll (Gen.int (Range.linear 1 30))+ k <- forAll (Gen.int (Range.linear 0 100))+ (sz1, sz2, val) <- evalIO $ do+ sc <- newSieveCache @Int @Int cap+ _ <- insert sc k 1+ delete sc k+ s1 <- size sc+ delete sc k+ s2 <- size sc+ v <- lookup sc k+ pure (s1, s2, v)+ sz1 === sz2+ val === Nothing++ it "delete-of-absent is a no-op" $ hedgehog $ do+ cap <- forAll (Gen.int (Range.linear 1 30))+ keys <- forAll (Gen.list (Range.linear 0 10) (Gen.int (Range.linear 0 50)))+ ghost <- forAll (Gen.int (Range.linear 100 200)) -- disjoint from keys+ (szBefore, szAfter) <- evalIO $ do+ sc <- newSieveCache @Int @Int cap+ mapM_ (\k -> insert sc k k) keys+ s1 <- size sc+ delete sc ghost+ s2 <- size sc+ pure (s1, s2)+ szBefore === szAfter++ it "update preserves size" $ hedgehog $ do+ cap <- forAll (Gen.int (Range.linear 2 20))+ k <- forAll (Gen.int (Range.linear 0 100))+ (sz1, sz2) <- evalIO $ do+ sc <- newSieveCache @Int @String cap+ _ <- insert sc k "old"+ s1 <- size sc+ _ <- insert sc k "new"+ s2 <- size sc+ pure (s1, s2)+ sz1 === sz2++ it "update overwrites the stored value" $ hedgehog $ do+ cap <- forAll (Gen.int (Range.linear 1 20))+ k <- forAll (Gen.int (Range.linear 0 100))+ v1 <- forAll (Gen.int (Range.linear 0 1000))+ v2 <- forAll (Gen.int (Range.linear 1001 2000))+ val <- evalIO $ do+ sc <- newSieveCache @Int @Int cap+ _ <- insert sc k v1+ _ <- insert sc k v2+ lookup sc k+ val === Just v2++ describe "eviction signal accuracy (Hedgehog)" $ do+ it "no eviction when inserting under capacity" $ hedgehog $ do+ cap <- forAll (Gen.int (Range.linear 2 30))+ n <- forAll (Gen.int (Range.linear 1 (cap - 1)))+ evictions <- evalIO $ do+ sc <- newSieveCache @Int @Int cap+ mapM (\i -> insert sc i i) [0 .. n - 1]+ evictions === replicate n Nothing++ it "no eviction when updating an existing key (regardless of fullness)" $ hedgehog $ do+ cap <- forAll (Gen.int (Range.linear 1 20))+ let keys = [0 .. cap - 1]+ ev <- evalIO $ do+ sc <- newSieveCache @Int @Int cap+ mapM_ (\k -> insert sc k k) keys+ -- Cache is now full. Updating any existing key must not evict.+ mapM (\k -> insert sc k (k + 100)) keys+ ev === replicate cap Nothing++ it "evicted key was previously present" $ hedgehog $ do+ cap <- forAll (Gen.int (Range.linear 1 10))+ ops <- forAll (Gen.list (Range.linear 1 50) (Gen.int (Range.linear 0 30)))+ evalIO $ do+ sc <- newSieveCache @Int @Int cap+ let go inserted k = do+ ev <- insert sc k k+ case ev of+ Nothing -> pure (k : inserted)+ Just (ek, _) -> do+ -- Evicted key must have been previously inserted...+ when (ek `notElem` inserted) $+ fail $ "evicted key " <> show ek <> " was never inserted"+ -- ...and must not be findable after eviction.+ v <- lookup sc ek+ case v of+ Just _ -> fail $ "evicted key " <> show ek <> " still present"+ Nothing -> pure ()+ pure (k : filter (/= ek) inserted)+ _ <- foldM go [] ops+ pure ()++ it "size + evictions <= total inserts (each insert grows size or evicts, never both)" $ hedgehog $ do+ cap <- forAll (Gen.int (Range.linear 1 20))+ keys <- forAll (Gen.list (Range.linear 1 80) (Gen.int (Range.linear 0 50)))+ (evictionCount, sz) <- evalIO $ do+ sc <- newSieveCache @Int @Int cap+ evs <- mapM (\k -> insert sc k k) keys+ let !ec = length [() | Just _ <- evs]+ s <- size sc+ pure (ec, s)+ assert (sz + evictionCount <= length keys)+ assert (sz <= cap)++ it "with all-distinct keys: size + evictions = total inserts (no updates)" $ hedgehog $ do+ -- Distinct keys means no insert is ever an update, so every insert+ -- either grows the cache by one or evicts one entry.+ cap <- forAll (Gen.int (Range.linear 1 20))+ n <- forAll (Gen.int (Range.linear 1 80))+ let keys = [0 .. n - 1] -- all distinct+ (evictionCount, sz) <- evalIO $ do+ sc <- newSieveCache @Int @Int cap+ evs <- mapM (\k -> insert sc k k) keys+ let !ec = length [() | Just _ <- evs]+ s <- size sc+ pure (ec, s)+ sz + evictionCount === n++ describe "model agreement (Hedgehog state machine)" $ do+ -- After every operation in a random sequence, the SIEVE cache and+ -- the reference model agree on (a) reported size and (b) the+ -- presence and value of every key in the universe.+ it "SIEVE and Map model agree after every operation" $ hedgehog $ do+ cap <- forAll (Gen.int (Range.linear 1 15))+ let universe = [0 .. 25 :: Int]+ ops <- forAll (Gen.list (Range.linear 0 100) (genOp (Range.linear 0 25)))+ result <- evalIO $ runScenario cap universe ops+ result === Right ()++ describe "second-chance (visited bit) semantics (Hedgehog)" $ do+ it "looking up every key keeps capacity-many entries after one extra insert" $ hedgehog $ do+ -- Fill the cache, look up every entry (sets visited on all),+ -- then insert one new key. Even with all bits set, SIEVE must+ -- still evict exactly one entry (after a sweep that resets bits).+ cap <- forAll (Gen.int (Range.linear 2 30))+ let keys = [0 .. cap - 1]+ newKey = cap+ (sz, ev) <- evalIO $ do+ sc <- newSieveCache @Int @Int cap+ mapM_ (\k -> insert sc k k) keys+ mapM_ (lookup sc) keys+ e <- insert sc newKey 999+ s <- size sc+ pure (s, e)+ sz === cap+ case ev of+ Just _ -> success+ Nothing -> failure -- must have evicted++ it "an unvisited key is preferred for eviction over a visited one" $ hedgehog $ do+ -- Fill cache. Visit only one key. Insert one new key.+ -- The visited key must survive.+ cap <- forAll (Gen.int (Range.linear 2 20))+ let keys = [0 .. cap - 1]+ visitedKey = 0+ newKey = cap+ survived <- evalIO $ do+ sc <- newSieveCache @Int @Int cap+ mapM_ (\k -> insert sc k k) keys+ _ <- lookup sc visitedKey+ _ <- insert sc newKey 999+ lookup sc visitedKey+ survived === Just visitedKey++ describe "clear / capacity / foldEntries (Hedgehog)" $ do+ it "capacity reports the value passed to newSieveCache" $ hedgehog $ do+ cap <- forAll (Gen.int (Range.linear 1 1000))+ reported <- evalIO $ do+ sc <- newSieveCache @Int @Int cap+ pure (capacity sc)+ reported === cap++ it "clear empties the cache" $ hedgehog $ do+ cap <- forAll (Gen.int (Range.linear 1 30))+ ops <- forAll (Gen.list (Range.linear 0 100) (genOp (Range.linear 0 50)))+ let universe = [0 .. 50 :: Int]+ (sz, hits) <- evalIO $ do+ sc <- newSieveCache @Int @Int cap+ forM_ ops (runOp sc)+ clear sc+ s <- size sc+ h <- length . filter id <$>+ mapM (\k -> (\m -> case m of Just _ -> True; Nothing -> False) <$> lookup sc k) universe+ pure (s, h)+ sz === 0+ hits === 0++ it "after clear, the cache accepts cap fresh inserts without eviction" $ hedgehog $ do+ cap <- forAll (Gen.int (Range.linear 1 30))+ preops <- forAll (Gen.list (Range.linear 0 80) (genOp (Range.linear 0 50)))+ evictions <- evalIO $ do+ sc <- newSieveCache @Int @Int cap+ forM_ preops (runOp sc)+ clear sc+ mapM (\k -> insert sc k k) [0 .. cap - 1]+ evictions === replicate cap Nothing++ it "foldEntries enumerates exactly `size` keys, all findable by lookup" $ hedgehog $ do+ cap <- forAll (Gen.int (Range.linear 1 30))+ ops <- forAll (Gen.list (Range.linear 0 200) (genOp (Range.linear 0 60)))+ (sz, enumerated, allFound) <- evalIO $ do+ sc <- newSieveCache @Int @Int cap+ forM_ ops (runOp sc)+ s <- size sc+ ks <- foldEntries sc [] (\acc k _ -> pure (k : acc))+ -- Every enumerated key should be findable. lookup mutates the+ -- visited bit but not membership, so this is safe.+ found <- mapM (\k -> lookup sc k) ks+ pure (s, length ks, all (\m -> case m of Just _ -> True; Nothing -> False) found)+ enumerated === sz+ assert allFound++ describe "fuzz" $ do+ -- Long-running fuzzers. These crank up case counts and op-sequence+ -- lengths to surface rare interactions between the visited bit, the+ -- hand pointer, eviction, and updates.++ it "fuzz: model agreement at every step (wide universe)" $+ hedgehog $ do+ cap <- forAll (Gen.int (Range.linear 1 25))+ let universe = [0 .. 40 :: Int]+ ops <- forAll (Gen.list (Range.linear 0 200) (genOp (Range.linear 0 40)))+ result <- evalIO $ runScenario cap universe ops+ result === Right ()++ it "fuzz: model agreement, narrow universe (heavy collisions)" $+ hedgehog $ do+ cap <- forAll (Gen.int (Range.linear 1 8))+ let universe = [0 .. 15 :: Int]+ ops <- forAll (Gen.list (Range.linear 0 200) (genOp (Range.linear 0 15)))+ result <- evalIO $ runScenario cap universe ops+ result === Right ()++ it "fuzz: foldEntries always matches size after long random runs" $+ hedgehog $ do+ cap <- forAll (Gen.int (Range.linear 1 30))+ ops <- forAll (Gen.list (Range.linear 0 250) (genOp (Range.linear 0 60)))+ (sz, enumerated) <- evalIO $ do+ sc <- newSieveCache @Int @Int cap+ forM_ ops (runOp sc)+ s <- size sc+ n <- foldEntries sc 0 (\acc _ _ -> pure (acc + 1))+ pure (s, n)+ enumerated === sz++ it "fuzz: never reports an eviction for a key that wasn't recently present" $+ hedgehog $ do+ cap <- forAll (Gen.int (Range.linear 1 12))+ keys <- forAll (Gen.list (Range.linear 1 300) (Gen.int (Range.linear 0 30)))+ result <- evalIO $ do+ sc <- newSieveCache @Int @Int cap+ let go _ [] = pure (Right () :: Either String ())+ go inserted (k : ks) = do+ ev <- insert sc k k+ case ev of+ Nothing -> go (k : filter (/= k) inserted) ks+ Just (ek, ev') -> do+ if ek `notElem` inserted+ then pure (Left $ "phantom eviction: " <> show ek+ <> " (value " <> show ev' <> ") never inserted")+ else go (k : filter (/= ek) (filter (/= k) inserted)) ks+ go [] keys+ result === Right ()++ it "fuzz: clear-then-refill cycles preserve invariants" $+ hedgehog $ do+ cap <- forAll (Gen.int (Range.linear 1 20))+ cycles <- forAll (Gen.int (Range.linear 1 20))+ opsPerCycle <- forAll (Gen.int (Range.linear 1 200))+ sizes <- evalIO $ do+ sc <- newSieveCache @Int @Int cap+ let runCycle = do+ forM_ [0 .. opsPerCycle] $ \i -> do+ let !k = i `mod` (cap * 2)+ _ <- insert sc k i+ pure ()+ clear sc+ size sc+ mapM (const runCycle) [1 .. cycles]+ -- Every cycle ends with size 0 because of the trailing 'clear'.+ sizes === replicate cycles 0++ it "fuzz: deleting every key currently in the cache empties it" $+ hedgehog $ do+ cap <- forAll (Gen.int (Range.linear 1 20))+ ops <- forAll (Gen.list (Range.linear 0 300) (genOp (Range.linear 0 40)))+ finalSize <- evalIO $ do+ sc <- newSieveCache @Int @Int cap+ forM_ ops (runOp sc)+ ks <- foldEntries sc [] (\acc k _ -> pure (k : acc))+ forM_ ks (delete sc)+ size sc+ finalSize === 0++ it "fuzz: lookup never resurrects a previously evicted key" $+ hedgehog $ do+ -- Run a sequence of inserts; after each, sweep the universe+ -- looking up every key. Anything we observe missing must stay+ -- missing until it's explicitly re-inserted.+ cap <- forAll (Gen.int (Range.linear 1 8))+ keys <- forAll (Gen.list (Range.linear 1 200) (Gen.int (Range.linear 0 20)))+ let universe = [0 .. 20 :: Int]+ result <- evalIO $ do+ sc <- newSieveCache @Int @Int cap+ let step missing k = do+ _ <- insert sc k k+ -- Sweep universe and rebuild the missing set.+ missing' <- foldM (\acc u -> do+ m <- lookup sc u+ case m of+ Nothing -> pure (u : acc)+ Just _ -> pure acc) [] universe+ -- Anything in `missing` that we didn't just re-insert+ -- (k) but which is now present must NOT happen.+ let resurrected =+ [u | u <- missing, u /= k, u `notElem` missing']+ if null resurrected+ then pure (Right missing')+ else pure (Left $ "resurrected keys: " <> show resurrected)+ go _ [] = pure (Right () :: Either String ())+ go missing (k : ks) = do+ r <- step missing k+ case r of+ Left e -> pure (Left e)+ Right missing' -> go missing' ks+ go [] keys+ result === Right ()++------------------------------------------------------------------------+-- Helpers+------------------------------------------------------------------------++runOp :: (Ord k) => SieveCache k v -> Op k v -> IO ()+runOp sc op = case op of+ OpInsert k v -> () <$ insert sc k v+ OpLookup k -> () <$ lookup sc k+ OpDelete k -> delete sc k++------------------------------------------------------------------------+-- Scenario runner: agreement check between SIEVE and the model.+------------------------------------------------------------------------++-- | Run a sequence of operations on both a real SIEVE cache and the+-- reference model, returning Right () if they agree at every step or+-- Left explaining the divergence.+runScenario :: Int -> [Int] -> [Op Int Int] -> IO (Either String ())+runScenario cap universe ops = do+ sc <- newSieveCache @Int @Int cap+ modelRef <- newIORef (newModel cap)+ go sc modelRef ops+ where+ go _ _ [] = pure (Right ())+ go sc modelRef (op : rest) = do+ m0 <- readIORef modelRef+ case op of+ OpLookup k -> do+ actual <- lookup sc k+ let expected = modelLookup k m0+ if actual /= expected+ then pure (Left $ "lookup " <> show k <> ": SIEVE=" <> show actual+ <> " model=" <> show expected)+ else checkInvariants sc m0 universe op >>= \case+ Left e -> pure (Left e)+ Right () -> go sc modelRef rest+ OpInsert k v -> do+ ev <- insert sc k v+ let m1 = modelInsert k v ev m0+ writeIORef modelRef m1+ checkInvariants sc m1 universe op >>= \case+ Left e -> pure (Left e)+ Right () -> go sc modelRef rest+ OpDelete k -> do+ delete sc k+ let m1 = modelDelete k m0+ writeIORef modelRef m1+ checkInvariants sc m1 universe op >>= \case+ Left e -> pure (Left e)+ Right () -> go sc modelRef rest++ checkInvariants sc m universe' op = do+ sz <- size sc+ if sz /= modelSize m+ then pure (Left $ "after " <> show op+ <> ": size=" <> show sz <> " modelSize=" <> show (modelSize m))+ else do+ mismatches <- foldM (\acc k -> do+ actual <- lookup sc k+ -- N.B. lookup mutates SIEVE state (sets visited bit) but+ -- doesn't change membership, so iterating universe is safe.+ let expected = modelLookup k m+ pure $ if actual == expected+ then acc+ else (k, actual, expected) : acc+ ) [] universe'+ case mismatches of+ [] -> pure (Right ())+ ((k, a, e) : _) ->+ pure (Left $ "after " <> show op <> ": key " <> show k+ <> " SIEVE=" <> show a <> " model=" <> show e)